Add lsh, rsh instructions

* libguile/vm-engine.c (lsh, rsh, lsh/immediate, rsh/immediate): New
  instructions taking unboxed bit counts.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/effects-analysis.scm:
* module/language/cps/specialize-numbers.scm (specialize-f64-unop):
  (specialize-u64-unop): Add ability to specialize add/immediate, etc,
  and add lsh/immediate as well.
  (specialize-u64-binop, specialize-u64-shift): Move rsh/lsh
  specialization to its own procedure, given that the bit count is
  already unboxed.
  (specialize-operations): Adapt to support more /immediate
  instructions.
* module/language/cps/type-fold.scm (mul): Reify an lsh/immediate
  instead of an ash.
* module/language/cps/types.scm (compute-ash-range): Add type inferrers
  for lsh, rsh, and their immediate variants.
* module/system/vm/assembler.scm: Export emit-lsh and so on.
* module/language/tree-il/compile-cps.scm (convert): Convert "ash" on
  immediates to rsh/immediate or lsh/immediate.

libguile/vm-engine.c

@@ -4024,15 +4024,149 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
   VM_DEFINE_OP (249, unused_249, NULL, NOP)
   VM_DEFINE_OP (250, unused_250, NULL, NOP)
   VM_DEFINE_OP (251, unused_251, NULL, NOP)
-  VM_DEFINE_OP (252, unused_252, NULL, NOP)
-  VM_DEFINE_OP (253, unused_253, NULL, NOP)
-  VM_DEFINE_OP (254, unused_254, NULL, NOP)
-  VM_DEFINE_OP (255, unused_255, NULL, NOP)
     {
       vm_error_bad_instruction (op);
       abort (); /* never reached */
     }
 
+  /* Temporary instructions down here, while we incrementally proceed
+     with instruction explosion.  */
+
+  /* lsh dst:8 a:8 b:8
+   *
+   * Shift A left by B bits, and place the result in DST.  B is a U64
+   * value.
+   */
+  VM_DEFINE_OP (252, lsh, "lsh", OP1 (X8_S8_S8_S8) | OP_DST)
+    {
+      scm_t_uint8 dst, x, y;
+      SCM a, result;
+      scm_t_uint64 b;
+
+      UNPACK_8_8_8 (op, dst, x, y);
+      a = SP_REF (x);
+      b = SP_REF_U64 (y);
+
+      if (SCM_LIKELY (SCM_I_INUMP (a))
+          && b < (scm_t_uint64) (SCM_I_FIXNUM_BIT - 1)
+          && ((scm_t_bits)
+              (SCM_SRS (SCM_I_INUM (a), (SCM_I_FIXNUM_BIT-1 - b)) + 1)
+              <= 1))
+        {
+          scm_t_signed_bits nn = SCM_I_INUM (a);
+          result = SCM_I_MAKINUM (nn < 0 ? -(-nn << b) : (nn << b));
+        }
+      else
+        {
+          SYNC_IP ();
+          /* B has to be a bignum.  FIXME: use instruction explosion to
+             ensure that.  */
+          result = scm_ash (a, scm_from_uint64 (b));
+          CACHE_SP ();
+        }
+      SP_SET (dst, result);
+      NEXT (1);
+    }
+  /* rsh dst:8 a:8 b:8
+   *
+   * Shift A right by B bits, and place the result in DST.  B is a U64
+   * value.
+   */
+  VM_DEFINE_OP (253, rsh, "rsh", OP1 (X8_S8_S8_S8) | OP_DST)
+    {
+      scm_t_uint8 dst, x, y;
+      SCM a, result;
+      scm_t_uint64 b;
+
+      UNPACK_8_8_8 (op, dst, x, y);
+      a = SP_REF (x);
+      b = SP_REF_U64 (y);
+
+      if (SCM_LIKELY (SCM_I_INUMP (a)))
+        {
+          if (b > (scm_t_uint64) (SCM_I_FIXNUM_BIT - 1))
+            b = SCM_I_FIXNUM_BIT - 1;
+          result = SCM_I_MAKINUM (SCM_SRS (SCM_I_INUM (a), b));
+        }
+      else
+        {
+          SYNC_IP ();
+          /* B has to be a bignum.  FIXME: use instruction explosion to
+             ensure that.  */
+          result = scm_ash (a, scm_difference (SCM_INUM0, scm_from_uint64 (b)));
+          CACHE_SP ();
+        }
+      SP_SET (dst, result);
+      NEXT (1);
+    }
+  /* lsh/immediate dst:8 a:8 b:8
+   *
+   * Shift A left by B bits, and place the result in DST.  B is an
+   * immediate unsigned integer.
+   */
+  VM_DEFINE_OP (254, lsh_immediate, "lsh/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+    {
+      scm_t_uint8 dst, x, y;
+      SCM a, result;
+      unsigned int b;
+
+      UNPACK_8_8_8 (op, dst, x, y);
+      a = SP_REF (x);
+      b = y;
+
+      if (SCM_LIKELY (SCM_I_INUMP (a))
+          && b < (unsigned int) (SCM_I_FIXNUM_BIT - 1)
+          && ((scm_t_bits)
+              (SCM_SRS (SCM_I_INUM (a), (SCM_I_FIXNUM_BIT-1 - b)) + 1)
+              <= 1))
+        {
+          scm_t_signed_bits nn = SCM_I_INUM (a);
+          result = SCM_I_MAKINUM (nn < 0 ? -(-nn << b) : (nn << b));
+        }
+      else
+        {
+          SYNC_IP ();
+          /* B has to be a bignum.  FIXME: use instruction explosion to
+             ensure that.  */
+          result = scm_ash (a, SCM_I_MAKINUM (b));
+          CACHE_SP ();
+        }
+      SP_SET (dst, result);
+      NEXT (1);
+    }
+  /* rsh dst:8 a:8 b:8
+   *
+   * Shift A right by B bits, and place the result in DST.  B is an
+   * immediate unsigned integer.
+   */
+  VM_DEFINE_OP (255, rsh_immediate, "rsh/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+    {
+      scm_t_uint8 dst, x, y;
+      SCM a, result;
+      int b;
+
+      UNPACK_8_8_8 (op, dst, x, y);
+      a = SP_REF (x);
+      b = y;
+
+      if (SCM_LIKELY (SCM_I_INUMP (a)))
+        {
+          if (b > (int) (SCM_I_FIXNUM_BIT - 1))
+            b = SCM_I_FIXNUM_BIT - 1;
+          result = SCM_I_MAKINUM (SCM_SRS (SCM_I_INUM (a), b));
+        }
+      else
+        {
+          SYNC_IP ();
+          /* B has to be a bignum.  FIXME: use instruction explosion to
+             ensure that.  */
+          result = scm_ash (a, SCM_I_MAKINUM (-b));
+          CACHE_SP ();
+        }
+      SP_SET (dst, result);
+      NEXT (1);
+    }
+
   END_DISPATCH_SWITCH;
 }
 

module/language/cps/compile-bytecode.scm

@@ -192,6 +192,14 @@
          (emit-usub/immediate asm (from-sp dst) (from-sp (slot x)) y))
         (($ $primcall 'umul/immediate y (x))
          (emit-umul/immediate asm (from-sp dst) (from-sp (slot x)) y))
+        (($ $primcall 'rsh (x y))
+         (emit-rsh asm (from-sp dst) (from-sp (slot x)) (from-sp (slot y))))
+        (($ $primcall 'lsh (x y))
+         (emit-lsh asm (from-sp dst) (from-sp (slot x)) (from-sp (slot y))))
+        (($ $primcall 'rsh/immediate y (x))
+         (emit-rsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
+        (($ $primcall 'lsh/immediate y (x))
+         (emit-lsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
         (($ $primcall 'ursh/immediate y (x))
          (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x)) y))
         (($ $primcall 'ulsh/immediate y (x))

module/language/cps/effects-analysis.scm

@@ -470,6 +470,10 @@ is or might be a read or a write to the same location as A."
   ((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)
+  ((lsh/immediate n)               &type-check)
   ((logand . _)                    &type-check)
   ((logior . _)                    &type-check)
   ((logxor . _)                    &type-check)

module/language/cps/specialize-numbers.scm

@@ -61,6 +61,46 @@
   #:use-module (language cps with-cps)
   #:export (specialize-numbers))
 
+(define (specialize-f64-unop cps k src op a b)
+  (cond
+   ((eq? op 'sub/immediate)
+    (specialize-f64-unop cps k src 'add/immediate a (- b)))
+   (else
+    (let ((fop (match op
+                 ('add/immediate 'fadd/immediate)
+                 ('mul/immediate 'fmul/immediate))))
+      (with-cps cps
+        (letv f64-a result)
+        (letk kbox ($kargs ('result) (result)
+                     ($continue k src
+                       ($primcall 'f64->scm #f (result)))))
+        (letk kop ($kargs ('f64-a) (f64-a)
+                    ($continue kbox src
+                      ($primcall fop b (f64-a)))))
+        (build-term
+          ($continue kop src
+            ($primcall 'scm->f64 #f (a)))))))))
+
+(define* (specialize-u64-unop cps k src op a b #:key
+                               (unbox-a 'scm->u64))
+  (let ((uop (match op
+               ('add/immediate 'uadd/immediate)
+               ('sub/immediate 'usub/immediate)
+               ('mul/immediate 'umul/immediate)
+               ('rsh/immediate 'ursh/immediate)
+               ('lsh/immediate 'ulsh/immediate))))
+    (with-cps cps
+      (letv u64-a result)
+      (letk kbox ($kargs ('result) (result)
+                   ($continue k src
+                     ($primcall 'u64->scm #f (result)))))
+      (letk kop ($kargs ('u64-a) (u64-a)
+                  ($continue kbox src
+                    ($primcall uop b (u64-a)))))
+      (build-term
+        ($continue kop src
+          ($primcall unbox-a #f (a)))))))
+
 (define (specialize-f64-binop cps k src op a b)
   (let ((fop (match op
                ('add 'fadd)
@@ -92,9 +132,7 @@
                ('logand 'ulogand)
                ('logior 'ulogior)
                ('logxor 'ulogxor)
-               ('logsub 'ulogsub)
+               ('logsub 'ulogsub))))
-               ('rsh 'ursh)
-               ('lsh 'ulsh))))
     (with-cps cps
       (letv u64-a u64-b result)
       (letk kbox ($kargs ('result) (result)
@@ -110,6 +148,23 @@
         ($continue kunbox-b src
           ($primcall unbox-a #f (a)))))))
 
+(define* (specialize-u64-shift cps k src op a b #:key
+                               (unbox-a 'scm->u64))
+  (let ((uop (match op
+               ('rsh 'ursh)
+               ('lsh 'ulsh))))
+    (with-cps cps
+      (letv u64-a result)
+      (letk kbox ($kargs ('result) (result)
+                   ($continue k src
+                     ($primcall 'u64->scm #f (result)))))
+      (letk kop ($kargs ('u64-a) (u64-a)
+                       ($continue kbox src
+                         ($primcall uop #f (u64-a b)))))
+      (build-term
+        ($continue kop src
+          ($primcall unbox-a #f (a)))))))
+
 (define (truncate-u64 cps k src scm)
   (with-cps cps
     (letv u64)
@@ -357,6 +412,35 @@ BITS indicating the significant bits needed for a variable.  BITS may be
                  cps))
                types
                sigbits))))))
+      (($ $kargs names vars
+          ($ $continue k src
+             ($ $primcall (and op
+                               (or 'add/immediate 'sub/immediate
+                                   'mul/immediate
+                                   'rsh/immediate 'lsh/immediate))
+                b (a))))
+       (match (intmap-ref cps k)
+         (($ $kargs (_) (result))
+          (call-with-values (lambda ()
+                              (lookup-post-type types label result 0))
+            (lambda (type min max)
+              (values
+               (cond
+                ((eqv? type &flonum)
+                 (with-cps cps
+                   (let$ body (specialize-f64-unop k src op a b))
+                   (setk label ($kargs names vars ,body))))
+                ((and (type<=? type &exact-integer)
+                      (or (<= 0 min max #xffffffffffffffff)
+                          (only-u64-bits-used? result))
+                      (u64-operand? a) (<= 0 b #xffffFFFFffffFFFF))
+                 (with-cps cps
+                   (let$ body (specialize-u64-unop k src op a b))
+                   (setk label ($kargs names vars ,body))))
+                (else
+                 cps))
+               types
+               sigbits))))))
       (($ $kargs names vars
           ($ $continue k src ($ $primcall 'ash #f (a b))))
        (match (intmap-ref cps k)
@@ -373,28 +457,40 @@ BITS indicating the significant bits needed for a variable.  BITS may be
                      (<= b-min -64)
                      (<= 64 b-max))
                  cps)
-                ((and (< b-min 0) (= b-min b-max))
+                ((= b-min b-max)
-                 (with-cps cps
+                 (if (< b-min 0)
-                   (let$ body
+                     (with-cps cps
-                         (with-cps-constants ((bits (- b-min)))
+                       (let$ body
-                           ($ (specialize-u64-binop k src 'rsh a bits))))
+                             (specialize-u64-unop k src
-                   (setk label ($kargs names vars ,body))))
+                                                  'rsh/immediate a (- b-min)))
+                       (setk label ($kargs names vars ,body)))
+                     (with-cps cps
+                       (let$ body
+                             (specialize-u64-unop k src
+                                                  'lsh/immediate a b-min))
+                       (setk label ($kargs names vars ,body)))))
                 ((< b-min 0)
                  (with-cps cps
                    (let$ body
                          (with-cps-constants ((zero 0))
-                           (letv bits)
+                           (letv count ucount)
                            (let$ body
-                                 (specialize-u64-binop k src 'rsh a bits))
+                                 (specialize-u64-shift k src 'rsh a ucount))
-                           (letk kneg ($kargs ('bits) (bits) ,body))
+                           (letk kucount ($kargs ('ucount) (ucount) ,body))
-                           (build-term
+                           (letk kcount ($kargs ('count) (count)
-                             ($continue kneg src
+                                          ($continue kucount src
-                               ($primcall 'sub #f (zero b))))))
+                                            ($primcall 'scm->u64 #f (count)))))
+                           (build-term ($continue kcount src
+                                         ($primcall 'sub #f (zero b))))))
                    (setk label ($kargs names vars ,body))))
                 (else
                  (with-cps cps
-                   (let$ body (specialize-u64-binop k src 'lsh a b))
+                   (letv ucount)
-                   (setk label ($kargs names vars ,body)))))
+                   (let$ body (specialize-u64-shift k src 'lsh a ucount))
+                   (letk kunbox ($kargs ('ucount) (ucount) ,body))
+                   (setk label ($kargs names vars
+                                 ($continue kunbox src
+                                   ($primcall 'scm->u64 #f (b))))))))
                types
                sigbits))))))
       (($ $kargs names vars

module/language/cps/type-fold.scm

@@ -231,8 +231,7 @@
     (let ((n (let lp ((bits 0) (constant constant))
                (if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
       (with-cps cps
-        ($ (with-cps-constants ((bits n))
+        (build-term ($continue k src ($primcall 'lsh/immediate n (arg)))))))
-             (build-term ($continue k src ($primcall 'ash #f (arg bits)))))))))
   (define (mul/constant constant constant-type arg arg-type)
     (cond
      ((not (or (type<=? constant-type &exact-integer)
@@ -255,7 +254,7 @@
      ((and (type<=? (logior constant-type arg-type) &exact-integer)
            (positive? constant)
            (zero? (logand constant (1- constant))))
-      ;; (* arg power-of-2) -> (ash arg (log2 power-of-2
+      ;; (* arg power-of-2) -> (ash arg (log2 power-of-2))
       (power-of-two constant arg))
      (else
       (fail))))

module/language/cps/types.scm

@@ -1372,25 +1372,45 @@ minimum, and maximum."
 
 ;; Bit operations.
 (define-simple-type-checker (ash &exact-integer &exact-integer))
-(define-type-inferrer (ash val count result)
+(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)
   (define (ash* val count)
     ;; As we only precisely represent a 64-bit range, don't bother inferring
     ;; shifts that might exceed that range.
     (cond
      ((inf? val) val) ; Preserves sign.
-     ((< -64 count 64) (ash val count))
+     ((< count 64) (ash val (max count 0)))
      ((zero? val) 0)
      ((positive? val) +inf.0)
      (else -inf.0)))
+  (let ((-- (ash* min-val min-shift))
+        (-+ (ash* min-val max-shift))
+        (++ (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 ((-- (ash* (&min val) (&min count)))
+  (let-values (((min max) (compute-ash-range (&min val)
-        (-+ (ash* (&min val) (&max count)))
+                                             (&max val)
-        (++ (ash* (&max val) (&max count)))
+                                             (&min count)
-        (+- (ash* (&max val) (&min count))))
+                                             (&max count))))
-    (define-exact-integer! result
+    (define-exact-integer! result min max)))
-      (min -- -+ ++ +-)
+(define-type-inferrer (lsh val count result)
-      (max -- -+ ++ +-))))
+  (restrict! val &exact-integer -inf.0 +inf.0)
+  (let-values (((min max) (compute-ash-range (&min val)
+                                             (&max val)
+                                             (&min/0 count)
+                                             (&max/u64 count))))
+    (define-exact-integer! result min max)))
+(define-type-inferrer (rsh val count result)
+  (restrict! val &exact-integer -inf.0 +inf.0)
+  (let-values (((min max) (compute-ash-range (&min val)
+                                             (&max val)
+                                             (- (&min/0 count))
+                                             (- (&max/u64 count)))))
+    (define-exact-integer! result min max)))
 
 (define-simple-type-checker (ursh &u64 &u64))
 (define-type-inferrer (ursh a b result)
@@ -1404,8 +1424,6 @@ minimum, and maximum."
 
 (define-simple-type-checker (ulsh &u64 &u64))
 (define-type-inferrer (ulsh a b result)
-  (restrict! a &u64 0 &u64-max)
-  (restrict! b &u64 0 &u64-max)
   (if (and (< (&max/u64 b) 64)
            (<= (ash (&max/u64 a) (&max/u64 b)) &u64-max))
       ;; No overflow; we can be precise.

module/language/tree-il/compile-cps.scm

@@ -669,7 +669,8 @@
                   ...
                   (_ def)))
               (define (uint? val) (and (exact-integer? val) (<= 0 val)))
-              ;; FIXME: Add cases for mul, rsh, lsh
+              (define (negint? val) (and (exact-integer? val) (< val 0)))
+              ;; FIXME: Add case for mul
               (specialize-case
                 (('make-vector ($ <const> _ (? uint? n)) init)
                  (make-vector/immediate n (init)))
@@ -689,6 +690,10 @@
                  (add/immediate y (x)))
                 (('sub x ($ <const> _ (? number? y)))
                  (sub/immediate y (x)))
+                (('ash x ($ <const> _ (? uint? y)))
+                 (lsh/immediate y (x)))
+                (('ash x ($ <const> _ (? negint? y)))
+                 (rsh/immediate (- y) (x)))
                 (_ (default))))
             (when (branching-primitive? name)
               (error "branching primcall in bad context" name))

module/system/vm/assembler.scm

@@ -189,6 +189,10 @@
             emit-rem
             emit-mod
             emit-ash
+            emit-lsh
+            emit-rsh
+            emit-lsh/immediate
+            emit-rsh/immediate
             emit-fadd
             emit-fsub
             emit-fmul