[Guile-commits] 09/12: Convert "ash" to "lsh"/"rsh" when lowering to CPS

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit b331ea319355e3a5eb626abc736b6fa540a516ed
Author: Andy Wingo <address@hidden>
Date:   Sat Nov 11 21:10:28 2017 +0100

    Convert "ash" to "lsh"/"rsh" when lowering to CPS
    
    * module/language/cps/effects-analysis.scm: Remove case for "ash".
    * module/language/cps/types.scm (ash): Remove.
    * module/language/tree-il/compile-cps.scm (convert, canonicalize):
      Convert "ash" to "lsh"/"rsh" early on.
    * module/system/base/target.scm (target-fixnum?): New procedure.
---
 module/language/cps/effects-analysis.scm |  1 -
 module/language/cps/types.scm            |  9 ------
 module/language/tree-il/compile-cps.scm  | 48 +++++++++++++++++++++++++++++---
 module/system/base/target.scm            |  9 +++++-
 4 files changed, 52 insertions(+), 15 deletions(-)

diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 3131366..144f15c 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -458,7 +458,6 @@ is or might be a read or a write to the same location as A."
   ((inexact? _)                    &type-check)
   ((even? _)                       &type-check)
   ((odd? _)                        &type-check)
-  ((ash n m)                       &type-check)
   ((rsh n m)                       &type-check)
   ((lsh n m)                       &type-check)
   ((rsh/immediate n)               &type-check)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index f853c97..a185eaa 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1300,7 +1300,6 @@ minimum, and maximum."
 (define-type-aliases even? odd?)
 
 ;; Bit operations.
-(define-simple-type-checker (ash &exact-integer &exact-integer))
 (define-simple-type-checker (lsh &exact-integer &u64))
 (define-simple-type-checker (rsh &exact-integer &u64))
 (define (compute-ash-range min-val max-val min-shift max-shift)
@@ -1318,14 +1317,6 @@ minimum, and maximum."
         (++ (ash* max-val max-shift))
         (+- (ash* max-val min-shift)))
     (values (min -- -+ ++ +-) (max -- -+ ++ +-))))
-(define-type-inferrer (ash val count result)
-  (restrict! val &exact-integer -inf.0 +inf.0)
-  (restrict! count &exact-integer -inf.0 +inf.0)
-  (let-values (((min max) (compute-ash-range (&min val)
-                                             (&max val)
-                                             (&min count)
-                                             (&max count))))
-    (define-exact-integer! result min max)))
 (define-type-inferrer (lsh val count result)
   (restrict! val &exact-integer -inf.0 +inf.0)
   (let-values (((min max) (compute-ash-range (&min val)
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index c2b000e..11eed5a 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -54,6 +54,7 @@
   #:use-module ((srfi srfi-1) #:select (fold filter-map))
   #:use-module (srfi srfi-26)
   #:use-module ((system foreign) #:select (make-pointer pointer->scm))
+  #:use-module (system base target)
   #:use-module (language cps)
   #:use-module (language cps utils)
   #:use-module (language cps with-cps)
@@ -659,6 +660,13 @@
                      cps idx 'scm->u64
                      (lambda (cps idx)
                        (have-args cps (list obj idx val)))))))
+                ((rsh lsh)
+                 (match args
+                   ((a b)
+                    (unbox-arg
+                     cps b 'untag-fixnum
+                     (lambda (cps b)
+                       (have-args cps (list a b)))))))
                 ((make-vector)
                  (match args
                    ((length init)
@@ -725,11 +733,12 @@
                  (add/immediate y (x)))
                 (('sub x ($ <const> _ (? number? y)))
                  (sub/immediate y (x)))
-                (('ash x ($ <const> _ (? uint? y)))
+                (('lsh x ($ <const> _ (? uint? y)))
                  (lsh/immediate y (x)))
-                (('ash x ($ <const> _ (? negint? y)))
-                 (rsh/immediate (- y) (x)))
-                (_ (default))))
+                (('rsh x ($ <const> _ (? uint? y)))
+                 (rsh/immediate y (x)))
+                (_
+                 (default))))
             (when (branching-primitive? name)
               (error "branching primcall in bad context" name))
             ;; Tree-IL primcalls are sloppy, in that it could be that
@@ -1192,6 +1201,37 @@ integer."
               ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
         exp)
 
+       (($ <primcall> src 'ash (a b))
+        (match b
+          (($ <const> src2 (? target-fixnum? n))
+           (if (< n 0)
+               (make-primcall src 'rsh (list a (make-const src2 (- n))))
+               (make-primcall src 'lsh (list a b))))
+          (_
+           (let* ((a-sym (gensym "a "))
+                  (b-sym (gensym "b "))
+                  (a-ref (make-lexical-ref src 'a a-sym))
+                  (b-ref (make-lexical-ref src 'b b-sym)))
+             (make-let
+              src (list 'a 'b) (list a-sym b-sym) (list a b)
+              (make-conditional
+               src
+               (make-primcall src 'fixnum? (list b-ref))
+               (make-conditional
+                src
+                (make-primcall src '< (list b-ref (make-const src 0)))
+                (let ((n (make-primcall src '- (list (make-const src 0) 
b-ref))))
+                  (make-primcall src 'rsh (list a-ref n)))
+                (make-primcall src 'lsh (list a-ref b-ref)))
+               (make-primcall
+                src 'throw
+                (list
+                 (make-const #f 'wrong-type-arg)
+                 (make-const #f "ash")
+                 (make-const #f "Wrong type (expecting fixnum): ~S")
+                 (make-primcall #f 'list (list b-ref))
+                 (make-primcall #f 'list (list b-ref))))))))))
+
        ;; Eta-convert prompts without inline handlers.
        (($ <prompt> src escape-only? tag body handler)
         (let ((h (gensym "h "))
diff --git a/module/system/base/target.scm b/module/system/base/target.scm
index 7c6e0ac..95ab8d8 100644
--- a/module/system/base/target.scm
+++ b/module/system/base/target.scm
@@ -33,7 +33,8 @@
             target-max-vector-length
 
             target-most-negative-fixnum
-            target-most-positive-fixnum))
+            target-most-positive-fixnum
+            target-fixnum?))
 
 
 
@@ -179,3 +180,9 @@ target platform."
   "Return the most positive integer representable as a fixnum on the
 target platform."
   (1- (ash 1 (- (* (target-word-size) 8) 3))))
+
+(define (target-fixnum? n)
+  (and (exact-integer? n)
+       (<= (target-most-negative-fixnum)
+           n
+           (target-most-positive-fixnum))))