Add ursh/immediate and ulsh/immediate ops

* libguile/vm-engine.c (ursh/immediate, ulsh/immediate): New ops.
* module/language/cps/effects-analysis.scm:
* module/language/cps/slot-allocation.scm (compute-var-representations)
  (compute-needs-slot):
* module/language/cps/specialize-primcalls.scm (specialize-primcalls):
* module/language/cps/compile-bytecode.scm (compile-function):
* module/system/vm/assembler.scm:
* module/language/cps/types.scm: Add support for new ops, and specialize
  ursh and ulsh.

libguile/vm-engine.c

@@ -3609,8 +3609,38 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  VM_DEFINE_OP (168, unused_168, NULL, NOP)
-  VM_DEFINE_OP (169, unused_169, NULL, NOP)
+  /* ursh/immediate dst:8 a:8 b:8
+   *
+   * Shift the u64 value in A right by the immediate B bits, and place
+   * the result in DST.  Only the lower 6 bits of B are used.
+   */
+  VM_DEFINE_OP (168, ursh_immediate, "ursh/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+    {
+      scm_t_uint8 dst, a, b;
+
+      UNPACK_8_8_8 (op, dst, a, b);
+
+      SP_SET_U64 (dst, SP_REF_U64 (a) >> (b & 63));
+
+      NEXT (1);
+    }
+
+  /* ulsh/immediate dst:8 a:8 b:8
+   *
+   * Shift the u64 value in A left by the immediate B bits, and place
+   * the result in DST.  Only the lower 6 bits of B are used.
+   */
+  VM_DEFINE_OP (169, ulsh_immediate, "ulsh/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+    {
+      scm_t_uint8 dst, a, b;
+
+      UNPACK_8_8_8 (op, dst, a, b);
+
+      SP_SET_U64 (dst, SP_REF_U64 (a) << (b & 63));
+
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (170, unused_170, NULL, NOP)
   VM_DEFINE_OP (171, unused_171, NULL, NOP)
   VM_DEFINE_OP (172, unused_172, NULL, NOP)

module/language/cps/compile-bytecode.scm

@@ -194,6 +194,12 @@
         (($ $primcall 'umul/immediate (x y))
          (emit-umul/immediate asm (from-sp dst) (from-sp (slot x))
                               (constant y)))
+        (($ $primcall 'ursh/immediate (x y))
+         (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x))
+                              (constant y)))
+        (($ $primcall 'ulsh/immediate (x y))
+         (emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x))
+                              (constant y)))
         (($ $primcall 'builtin-ref (name))
          (emit-builtin-ref asm (from-sp dst) (constant name)))
         (($ $primcall 'scm->f64 (src))

module/language/cps/effects-analysis.scm

@@ -473,6 +473,8 @@ is or might be a read or a write to the same location as A."
   ((ulogsub . _))
   ((ursh . _))
   ((ulsh . _))
+  ((ursh/immediate . _))
+  ((ulsh/immediate . _))
   ((logtest a b)                   &type-check)
   ((logbit? a b)                   &type-check)
   ((sqrt _)                        &type-check)

module/language/cps/slot-allocation.scm

@@ -350,7 +350,8 @@ the definitions that are live before and after LABEL, as intsets."
              (($ $primcall 'struct-set!/immediate (s n x))
               (defs+* (intset s x)))
              (($ $primcall (or 'add/immediate 'sub/immediate
-                               'uadd/immediate 'usub/immediate 'umul/immediate)
+                               'uadd/immediate 'usub/immediate 'umul/immediate
+                               'ursh/immediate 'ulsh/immediate)
                  (x y))
               (defs+ x))
              (($ $primcall 'builtin-ref (idx))
@@ -805,6 +806,7 @@ are comparable with eqv?.  A tmp slot may be used."
                                'uadd 'usub 'umul
                                'ulogand 'ulogior 'ulogsub 'ursh 'ulsh
                                'uadd/immediate 'usub/immediate 'umul/immediate
+                               'ursh/immediate 'ulsh/immediate
                                'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref))
               (intmap-add representations var 'u64))
              (($ $primcall (or 'scm->s64 'load-s64

module/language/cps/specialize-primcalls.scm

@@ -33,6 +33,9 @@
 
 (define (specialize-primcalls conts)
   (let ((constants (compute-constant-values conts)))
+    (define (u6? var)
+      (let ((val (intmap-ref constants var (lambda (_) #f))))
+        (and (exact-integer? val) (<= 0 val 63))))
     (define (u8? var)
       (let ((val (intmap-ref constants var (lambda (_) #f))))
         (and (exact-integer? val) (<= 0 val 255))))
@@ -64,6 +67,8 @@
         (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate (x y))))
         (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate (x y))))
         (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x))))
+        (('ursh x (? u6? y)) (build-exp ($primcall 'ursh/immediate (x y))))
+        (('ulsh x (? u6? y)) (build-exp ($primcall 'ulsh/immediate (x y))))
         (('scm->f64 (? f64?)) (rename 'load-f64))
         (('scm->u64 (? u64?)) (rename 'load-u64))
         (('scm->u64/truncate (? u64?)) (rename 'load-u64))

module/language/cps/types.scm

@@ -1203,6 +1203,7 @@ minimum, and maximum."
   (define! result &u64
     (ash (&min a) (- (&max b)))
     (ash (&max a) (- (&min b)))))
+(define-type-aliases ursh ursh/immediate)
 
 (define-simple-type-checker (ulsh &u64 &u64))
 (define-type-inferrer (ulsh a b result)
@@ -1214,6 +1215,7 @@ minimum, and maximum."
       (define! result &u64 (ash (&min a) (&min b)) (ash (&max a) (&max b)))
       ;; Otherwise assume the whole range.
       (define! result &u64 0 &u64-max)))
+(define-type-aliases ulsh ulsh/immediate)
 
 (define (next-power-of-two n)
   (let lp ((out 1))

module/system/vm/assembler.scm

@@ -158,6 +158,8 @@
             (emit-ulogsub* . emit-ulogsub)
             (emit-ursh* . emit-ursh)
             (emit-ulsh* . emit-ulsh)
+            (emit-ursh/immediate* . emit-ursh/immediate)
+            (emit-ulsh/immediate* . emit-ulsh/immediate)
             (emit-make-vector* . emit-make-vector)
             (emit-make-vector/immediate* . emit-make-vector/immediate)
             (emit-vector-length* . emit-vector-length)