[Guile-commits] branch master updated: Optimize truncate-bits

[Andy Wingo]

This is an automated email from the git hooks/post-receive script.

wingo pushed a commit to branch master
in repository guile.

The following commit(s) were added to refs/heads/master by this push:
     new 05614f7  Optimize truncate-bits
05614f7 is described below

commit 05614f792bfabbc33798863edd0bb67c744e9299
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu May 6 21:49:13 2021 +0200

    Optimize truncate-bits
    
    * module/system/base/types/internal.scm (truncate-bits): Inline cases
    for 16, 32, and 64, to avoid allocating bignums for the boundary
    conditions.
---
 module/system/base/types/internal.scm | 21 +++++++++++++++++----
 1 file changed, 17 insertions(+), 4 deletions(-)

diff --git a/module/system/base/types/internal.scm 
b/module/system/base/types/internal.scm
index c75ca3b..0514d7b 100644
--- a/module/system/base/types/internal.scm
+++ b/module/system/base/types/internal.scm
@@ -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)