[Guile-commits] 26/30: Better unboxing for logand over s64 values

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 3ae2a88c15e6d0bc37e2832686c7423fea93a849
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 22 11:34:25 2017 +0100

    Better unboxing for logand over s64 values
    
    * module/language/cps/specialize-numbers.scm (specialize-operations): Do
      a better job unboxing logand if we know the result is a u64, even if
      arguments are s64.
---
 module/language/cps/specialize-numbers.scm | 20 ++++++++++++++++++++
 1 file changed, 20 insertions(+)

diff --git a/module/language/cps/specialize-numbers.scm 
b/module/language/cps/specialize-numbers.scm
index df570bc..a0c4b15 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -484,6 +484,26 @@ BITS indicating the significant bits needed for a 
variable.  BITS may be
                               (unbox-u64 a) (unbox-u64 b) (box-u64 result)))
                   (setk label ($kargs names vars ,body)))))
 
+             (((or 'logand 'logior 'logxor 'logsub)
+               (? u64-result?) #f (? s64-operand? a) (? s64-operand? b))
+              (let ((op (match op
+                          ('logand 'ulogand) ('logior 'ulogior)
+                          ('logxor 'ulogxor) ('logsub 'ulogsub))))
+                (define (unbox-u64* x)
+                  (let ((unbox-s64 (unbox-s64 x)))
+                    (lambda (cps k src x)
+                      (with-cps cps
+                        (letv s64)
+                        (letk ks64 ($kargs ('s64) (s64)
+                                     ($continue k src
+                                       ($primcall 's64->u64 #f (s64)))))
+                        ($ (unbox-s64 k src x))))))
+                (with-cps cps
+                  (let$ body (specialize-binop
+                              k src op a b
+                              (unbox-u64* a) (unbox-u64* b) (box-u64 result)))
+                  (setk label ($kargs names vars ,body)))))
+
              (((or 'add 'sub 'mul)
                (? s64-result?) #f (? s64-operand? a) (? s64-operand? b))
               (let ((op (match op