lsh, rsh etc are intrinsics

* libguile/intrinsics.c (lsh, rsh, lsh_immediate, rsh_immediate): New
  intrinsics.
  (scm_bootstrap_intrinsics): Wire up the intrinsics.
* libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Add new
  intrinsics.
* libguile/vm-engine.c (call-scm<-scm-u64): New intrinsic caller.
  (lsh, rsh, lsh/immediate, rsh/immediate): Disable.
* module/language/cps/reify-primitives.scm (compute-known-primitives):
  Add new intrinsics.
* module/system/vm/assembler.scm: Adapt assemblers for new intrinsics.

libguile/intrinsics.c

@@ -162,6 +162,47 @@ pop_dynamic_state (scm_i_thread *thread)
                                      thread->dynamic_state);
 }
 
+static SCM
+lsh (SCM a, scm_t_uint64 b)
+{
+  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);
+      return SCM_I_MAKINUM (nn < 0 ? -(-nn << b) : (nn << b));
+    }
+  else
+    return scm_ash (a, scm_from_uint64 (b));
+}
+
+static SCM
+rsh (SCM a, scm_t_uint64 b)
+{
+  if (SCM_LIKELY (SCM_I_INUMP (a)))
+    {
+      if (b > (scm_t_uint64) (SCM_I_FIXNUM_BIT - 1))
+        b = SCM_I_FIXNUM_BIT - 1;
+      return SCM_I_MAKINUM (SCM_SRS (SCM_I_INUM (a), b));
+    }
+  else
+    return scm_ash (a, scm_difference (SCM_INUM0, scm_from_uint64 (b)));
+}
+
+static SCM
+lsh_immediate (SCM a, scm_t_uint8 b)
+{
+  return lsh (a, b);
+}
+
+static SCM
+rsh_immediate (SCM a, scm_t_uint8 b)
+{
+  return rsh (a, b);
+}
+
 void
 scm_bootstrap_intrinsics (void)
 {
@@ -197,6 +238,10 @@ scm_bootstrap_intrinsics (void)
   scm_vm_intrinsics.fluid_set_x = fluid_set_x;
   scm_vm_intrinsics.push_dynamic_state = push_dynamic_state;
   scm_vm_intrinsics.pop_dynamic_state = pop_dynamic_state;
+  scm_vm_intrinsics.lsh = lsh;
+  scm_vm_intrinsics.rsh = rsh;
+  scm_vm_intrinsics.lsh_immediate = lsh_immediate;
+  scm_vm_intrinsics.rsh_immediate = rsh_immediate;
 
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_intrinsics",

libguile/intrinsics.h

@@ -36,6 +36,7 @@ typedef void (*scm_t_thread_intrinsic) (scm_i_thread*);
 typedef void (*scm_t_thread_scm_intrinsic) (scm_i_thread*, SCM);
 typedef void (*scm_t_thread_scm_scm_intrinsic) (scm_i_thread*, SCM, SCM);
 typedef SCM (*scm_t_scm_from_thread_scm_intrinsic) (scm_i_thread*, SCM);
+typedef SCM (*scm_t_scm_from_scm_u64_intrinsic) (SCM, scm_t_uint64);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -70,6 +71,10 @@ typedef SCM (*scm_t_scm_from_thread_scm_intrinsic) (scm_i_thread*, SCM);
   M(thread_scm_scm, fluid_set_x, "fluid-set!", FLUID_SET_X) \
   M(thread_scm, push_dynamic_state, "push-dynamic-state", PUSH_DYNAMIC_STATE) \
   M(thread, pop_dynamic_state, "pop-dynamic-state", POP_DYNAMIC_STATE) \
+  M(scm_from_scm_u64, lsh, "lsh", LSH) \
+  M(scm_from_scm_u64, rsh, "rsh", RSH) \
+  M(scm_from_scm_uimm, lsh_immediate, "lsh/immediate", LSH_IMMEDIATE) \
+  M(scm_from_scm_uimm, rsh_immediate, "rsh/immediate", RSH_IMMEDIATE) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic

libguile/vm-engine.c

@@ -2209,7 +2209,24 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (2);
     }
 
-  VM_DEFINE_OP (91, unused_91, NULL, NOP)
+  VM_DEFINE_OP (91, call_scm_from_scm_u64, "call-scm<-scm-u64", OP2 (X8_S8_S8_S8, C32))
+    {
+      scm_t_uint8 dst, a, b;
+      SCM res;
+      scm_t_scm_from_scm_u64_intrinsic intrinsic;
+
+      UNPACK_8_8_8 (op, dst, a, b);
+      intrinsic = intrinsics[ip[1]];
+
+      SYNC_IP ();
+      res = intrinsic (SP_REF (a), SP_REF_U64 (b));
+      CACHE_SP ();
+
+      SP_SET (dst, res);
+
+      NEXT (2);
+    }
+
   VM_DEFINE_OP (92, unused_92, NULL, NOP)
   VM_DEFINE_OP (93, unused_93, NULL, NOP)
   VM_DEFINE_OP (94, unused_94, NULL, NOP)
@@ -3345,15 +3362,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       abort (); /* never reached */
     }
 
-  /* Temporary instructions down here, while we incrementally proceed
+  VM_DEFINE_OP (252, unused_252, NULL, NOP)
-     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;
@@ -3383,12 +3392,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       SP_SET (dst, result);
       NEXT (1);
     }
-  /* rsh dst:8 a:8 b:8
+
-   *
+  VM_DEFINE_OP (253, unused_253, NULL, NOP)
-   * 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;
@@ -3415,12 +3420,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       SP_SET (dst, result);
       NEXT (1);
     }
-  /* lsh/immediate dst:8 a:8 b:8
+
-   *
+  VM_DEFINE_OP (254, unused_254, NULL, NOP)
-   * 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;
@@ -3450,12 +3451,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       SP_SET (dst, result);
       NEXT (1);
     }
-  /* rsh dst:8 a:8 b:8
+
-   *
+  VM_DEFINE_OP (255, unused_255, NULL, NOP)
-   * 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;

module/language/cps/reify-primitives.scm

@@ -238,7 +238,8 @@
       cached-module-box
       wind unwind
       push-fluid pop-fluid fluid-ref fluid-set!
-      push-dynamic-state pop-dynamic-state))
+      push-dynamic-state pop-dynamic-state
+      lsh rsh lsh/immediate rsh/immediate))
   (let ((table (make-hash-table)))
     (for-each
      (match-lambda ((inst . _) (hashq-set! table inst #t)))

module/system/vm/assembler.scm

@@ -220,6 +220,10 @@
             emit-fluid-set!
             emit-push-dynamic-state
             emit-pop-dynamic-state
+            emit-lsh
+            emit-rsh
+            emit-lsh/immediate
+            emit-rsh/immediate
 
             emit-call
             emit-call-label
@@ -247,10 +251,6 @@
             emit-module-box
             emit-prompt
             emit-current-thread
-            emit-lsh
-            emit-rsh
-            emit-lsh/immediate
-            emit-rsh/immediate
             emit-fadd
             emit-fsub
             emit-fmul
@@ -1333,6 +1333,9 @@ returned instead."
 (define-syntax-rule (define-scm<-thread-scm-intrinsic name)
   (define-macro-assembler (name asm dst src)
     (emit-call-scm<-thread-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scm-u64-intrinsic name)
+  (define-macro-assembler (name asm dst a b)
+    (emit-call-scm<-scm-u64 asm dst a b (intrinsic-name->index 'name))))
 
 (define-scm<-scm-scm-intrinsic add)
 (define-scm<-scm-uimm-intrinsic add/immediate)
@@ -1366,6 +1369,10 @@ returned instead."
 (define-thread-scm-scm-intrinsic fluid-set!)
 (define-thread-scm-intrinsic push-dynamic-state)
 (define-thread-intrinsic pop-dynamic-state)
+(define-scm<-scm-u64-intrinsic lsh)
+(define-scm<-scm-u64-intrinsic rsh)
+(define-scm<-scm-uimm-intrinsic lsh/immediate)
+(define-scm<-scm-uimm-intrinsic rsh/immediate)
 
 (define-macro-assembler (begin-program asm label properties)
   (emit-label asm label)