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

@@ -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)

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)

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 x ($ <const> _ (? uint? y)))
-                 (rsh/immediate (- y) (x)))
+                 (rsh/immediate y (x)))
-                (_ (default))))
+                (_
+                 (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 "))

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))))