[Guile-commits] 01/30: ursh, ursh/immediate, etc only residualized if count < 64

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 8ce6f359bb6ca7fdb987840ea0c74237ecd0e5df
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 15 19:54:10 2017 +0100

    ursh, ursh/immediate, etc only residualized if count < 64
    
    * module/language/cps/reify-primitives.scm (reify-primitives): Remove
      cases for ursh/immediate etc, as these should all be within range, by
      construction.
    * module/language/cps/specialize-numbers.scm (specialize-operations):
      Only reify ursh/immediate, etc if the shift count is less than 64.
    * module/language/cps/specialize-primcalls.scm (specialize-primcalls):
      Remove specialization cases for ursh/immediate etc; this is the domain
      of specialize-numbers.
    * module/language/cps/types.scm (ursh, srsh, ulsh): Limit arguments to
      be less than 63.
      (ulsh/immediate): Assume parameter is in range.
---
 module/language/cps/reify-primitives.scm     |  7 ++++---
 module/language/cps/specialize-numbers.scm   |  4 +++-
 module/language/cps/specialize-primcalls.scm |  3 ---
 module/language/cps/types.scm                | 13 ++++++-------
 4 files changed, 13 insertions(+), 14 deletions(-)

diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
index 680c1b7..bac85ad 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -199,9 +199,10 @@
               ((umul/immediate (u8? y) x) (umul x y))
               ((rsh/immediate (u6? y) x) (rsh x y))
               ((lsh/immediate (u6? y) x) (lsh x y))
-              ((ursh/immediate (u6? y) x) (ursh x y))
-              ((srsh/immediate (u6? y) x) (srsh x y))
-              ((ulsh/immediate (u6? y) x) (ulsh x y))
+              ;; These should all be u6's by construction.
+              ;; ((ursh/immediate (u6? y) x) (ursh x y))
+              ;; ((srsh/immediate (u6? y) x) (srsh x y))
+              ;; ((ulsh/immediate (u6? y) x) (ulsh x y))
               (_ cps))))))
         (param (error "unexpected param to reified primcall" name))
         (else
diff --git a/module/language/cps/specialize-numbers.scm 
b/module/language/cps/specialize-numbers.scm
index 0e8ae93..52ac703 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -453,6 +453,8 @@ BITS indicating the significant bits needed for a variable. 
 BITS may be
           (and (type<=? type &type) (<= &min min max &max)))))
     (define (u64-operand? var)
       (operand-in-range? var &exact-integer 0 (1- (ash 1 64))))
+    (define (u6-operand? var)
+      (operand-in-range? var (logior &s64 &u64) 0 63))
     (define (s64-operand? var)
       (operand-in-range? var &exact-integer (ash -1 63) (1- (ash 1 63))))
     (define (fixnum-operand? var)
@@ -608,7 +610,7 @@ BITS indicating the significant bits needed for a variable. 
 BITS may be
                 (setk label ($kargs names vars ,body))))
 
              (((or 'lsh 'rsh)
-               (? u64-result?) #f (? u64-operand? a) b)
+               (? u64-result?) #f (? u64-operand? a) (? u6-operand? b))
               (with-cps cps
                 (let$ body (specialize-u64-shift
                             k src op a b
diff --git a/module/language/cps/specialize-primcalls.scm 
b/module/language/cps/specialize-primcalls.scm
index eedc28b..a5ce739 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -73,9 +73,6 @@
         (('usub x (? uint? y)) (usub/immediate y (x)))
         (('umul x (? uint? y)) (umul/immediate y (x)))
         (('umul (? uint? y) x) (umul/immediate y (x)))
-        (('ursh x (? uint? y)) (ursh/immediate y (x)))
-        (('srsh x (? uint? y)) (srsh/immediate y (x)))
-        (('ulsh x (? uint? y)) (ulsh/immediate y (x)))
         (('scm->f64 (? f64? var)) (load-f64 var ()))
         (('scm->u64 (? u64? var)) (load-u64 var ()))
         (('scm->u64/truncate (? u64? var)) (load-u64 var ()))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index f56ce0f..3edd9ef 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1382,8 +1382,8 @@ minimum, and maximum."
 
 (define-type-inferrer (ursh a b result)
   (define! result &u64
-    (ash (&min/0 a) (- (min 64 (&max/u64 b))))
-    (ash (&max/u64 a) (- (min 64 (&min/0 b))))))
+    (ash (&min/0 a) (- (min 63 (&max/u64 b))))
+    (ash (&max/u64 a) (- (min 63 (&min/0 b))))))
 (define-type-inferrer/param (ursh/immediate param a result)
   (define! result &u64
     (ash (&min/0 a) (- param))
@@ -1392,8 +1392,8 @@ minimum, and maximum."
 (define-type-inferrer (srsh a b result)
   (let-values (((min max) (compute-ash-range (&min/s64 a)
                                              (&max/s64 a)
-                                             (- (&min/0 b))
-                                             (- (&max/u64 b)))))
+                                             (- (min 63 (&min/0 b)))
+                                             (- (min 63 (&max/u64 b))))))
     (if (<= &s64-min min max &s64-max)
         (define! result &s64 min max)
         (define! result &s64 &s64-min &s64-max))))
@@ -1406,8 +1406,7 @@ minimum, and maximum."
         (define! result &s64 &s64-min &s64-max))))
 
 (define-type-inferrer (ulsh a b result)
-  (if (and (< (&max/u64 b) 64)
-           (<= (ash (&max/u64 a) (&max/u64 b)) &u64-max))
+  (if (<= (ash (&max/u64 a) (&max/u64 b)) &u64-max)
       ;; No overflow; we can be precise.
       (define! result &u64
         (ash (&min/0 a) (&min/0 b))
@@ -1415,7 +1414,7 @@ minimum, and maximum."
       ;; Otherwise assume the whole range.
       (define! result &u64 0 &u64-max)))
 (define-type-inferrer/param (ulsh/immediate param a result)
-  (if (and (< param 64) (<= (ash (&max/u64 a) param) &u64-max))
+  (if (<= (ash (&max/u64 a) param) &u64-max)
       ;; No overflow; we can be precise.
       (define! result &u64
         (ash (&min/0 a) param)