mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Optimize truncate-bits

Browse source 
* module/system/base/types/internal.scm (truncate-bits): Inline cases
for 16, 32, and 64, to avoid allocating bignums for the boundary
conditions.
This commit is contained in:
Andy Wingo 2021-05-06 21:49:13 +02:00
parent f10bc1a864
commit 05614f792b
1 changed files with 17 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

21
module/system/base/types/internal.scm
View file

@ -1,5 +1,5 @@
;;; Details on internal value representation.
;;; Copyright (C) 2014, 2015, 2017, 2018, 2020 Free Software Foundation, Inc.
;;; Copyright (C) 2014, 2015, 2017, 2018, 2020, 2021 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as published by
@ -230,9 +230,22 @@ may not fit into a word on the target platform."
(else (error "value does not fit in bits" x bits))))
(define (truncate-bits x bits signed?)
(let ((x' (logand x (1- (ash 1 bits)))))
(and (eq? x (if signed? (sign-extend x' bits) x'))
x')))
(define-syntax-rule (bits-case bits)
(let ((umax (1- (ash 1 bits)))
(smin (ash -1 (1- bits)))
(smax (1- (ash 1 (1- bits)))))
(and (if signed?
(<= smin x smax)
(<= 0 x umax))
(logand x umax))))
(case bits
((16) (bits-case 16))
((32) (bits-case 32))
((64) (bits-case 64))
(else
(let ((x' (logand x (1- (ash 1 bits)))))
(and (eq? x (if signed? (sign-extend x' bits) x'))
x')))))
;; See discussion in tags.h and boolean.h.
(eval-when (expand)