guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 03/04: Fix boxing of non-fixnum negative u64 values


From: Andy Wingo
Subject: [Guile-commits] 03/04: Fix boxing of non-fixnum negative u64 values
Date: Wed, 25 Sep 2024 11:46:03 -0400 (EDT)

wingo pushed a commit to branch main
in repository guile.

commit e45b70dcded37eb77e71ec30445b12040b6bb1b7
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Wed Sep 25 17:24:51 2024 +0200

    Fix boxing of non-fixnum negative u64 values
    
    * module/language/cps/specialize-numbers.scm (u64->fixnum/truncate): New
    helper.
    (specialize-operations): Fix specialized boxing of u64 values to
    truncate possibly-negative values, to avoid confusing CSE.  Fixes
    https://debbugs.gnu.org/cgi/bugreport.cgi?bug=71891.
---
 module/language/cps/specialize-numbers.scm | 21 ++++++++++++++++++++-
 1 file changed, 20 insertions(+), 1 deletion(-)

diff --git a/module/language/cps/specialize-numbers.scm 
b/module/language/cps/specialize-numbers.scm
index f70c28e08..b46919a40 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -115,6 +115,13 @@
     (letk ks64 ($kargs ('s64) (s64) ,tag-body))
     (build-term
       ($continue ks64 src ($primcall 'u64->s64 #f (u64))))))
+(define (u64->fixnum/truncate cps k src u64 bits)
+  (with-cps cps
+    (letv truncated)
+    (let$ tag-body (u64->fixnum k src truncated))
+    (letk ku64 ($kargs ('truncated) (truncated) ,tag-body))
+    (build-term
+      ($continue ku64 src ($primcall 'ulogand/immediate bits (u64))))))
 (define-simple-primcall scm->u64)
 (define-simple-primcall scm->u64/truncate)
 (define-simple-primcall u64->scm)
@@ -473,7 +480,19 @@ BITS indicating the significant bits needed for a 
variable.  BITS may be
     (define (box-s64 result)
       (if (fixnum-result? result) tag-fixnum s64->scm))
     (define (box-u64 result)
-      (if (fixnum-result? result) u64->fixnum u64->scm))
+      (call-with-values
+          (lambda ()
+            (lookup-post-type types label result 0))
+        (lambda (type min max)
+          (cond
+           ((and (type<=? type &exact-integer)
+                 (<= 0 min max (target-most-positive-fixnum)))
+            u64->fixnum)
+           ((only-fixnum-bits-used? result)
+            (lambda (cps k src u64)
+              (u64->fixnum/truncate cps k src u64 (intmap-ref sigbits 
result))))
+           (else
+            u64->scm)))))
     (define (box-f64 result)
       f64->scm)
 



reply via email to

[Prev in Thread] Current Thread [Next in Thread]