scm->u64, scm->s64, scm->u64/truncate intrinsics

* libguile/intrinsics.c (scm_to_uint64_truncate): New intrinsic.
  (scm_bootstrap_intrinsics): Init new intrinsics.
* libguile/intrinsics.h: Add scm->u64, scm->u64/truncate, and scm->s64
  as intrinsics, with their corresponding types.
* libguile/vm-engine.c (call-u64<-scm, call-s64<-scm): New intrinsic
  calling ops.
  (scm->u64, scm->s64, scm->u64/truncate): Disable opcodes.
* module/language/cps/reify-primitives.scm (compute-known-primitives):
  Add intrinsics as new macroinstructions.
* module/system/vm/assembler.scm: Declare new intrinsic assemblers.

libguile/intrinsics.c

@@ -71,6 +71,15 @@ string_to_number (SCM str)
   return scm_string_to_number (str, SCM_UNDEFINED /* radix = 10 */);
 }
 
+static scm_t_uint64
+scm_to_uint64_truncate (SCM x)
+{
+  if (SCM_I_INUMP (x))
+    return (scm_t_uint64) SCM_I_INUM (x);
+  else
+    return scm_to_uint64 (scm_logand (x, scm_from_uint64 ((scm_t_uint64) -1)));
+}
+
 void
 scm_bootstrap_intrinsics (void)
 {
@@ -92,6 +101,9 @@ scm_bootstrap_intrinsics (void)
   scm_vm_intrinsics.symbol_to_keyword = scm_symbol_to_keyword;
   scm_vm_intrinsics.class_of = scm_class_of;
   scm_vm_intrinsics.scm_to_f64 = scm_to_double;
+  scm_vm_intrinsics.scm_to_u64 = scm_to_uint64;
+  scm_vm_intrinsics.scm_to_u64_truncate = scm_to_uint64_truncate;
+  scm_vm_intrinsics.scm_to_s64 = scm_to_int64;
 
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_intrinsics",

libguile/intrinsics.h

@@ -28,6 +28,8 @@ typedef SCM (*scm_t_scm_from_scm_uimm_intrinsic) (SCM, scm_t_uint8);
 typedef void (*scm_t_scm_u64_u64_intrinsic) (SCM, scm_t_uint64, scm_t_uint64);
 typedef SCM (*scm_t_scm_from_scm_intrinsic) (SCM);
 typedef double (*scm_t_f64_from_scm_intrinsic) (SCM);
+typedef scm_t_uint64 (*scm_t_u64_from_scm_intrinsic) (SCM);
+typedef scm_t_int64 (*scm_t_s64_from_scm_intrinsic) (SCM);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -48,6 +50,9 @@ typedef double (*scm_t_f64_from_scm_intrinsic) (SCM);
   M(scm_from_scm, symbol_to_keyword, "symbol->keyword", SYMBOL_TO_KEYWORD) \
   M(scm_from_scm, class_of, "class-of", CLASS_OF) \
   M(f64_from_scm, scm_to_f64, "scm->f64", SCM_TO_F64) \
+  M(u64_from_scm, scm_to_u64, "scm->u64", SCM_TO_U64) \
+  M(u64_from_scm, scm_to_u64_truncate, "scm->u64/truncate", SCM_TO_U64_TRUNCATE) \
+  M(s64_from_scm, scm_to_s64, "scm->s64", SCM_TO_S64) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic

libguile/vm-engine.c

@@ -1580,10 +1580,21 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (2);
     }
 
-  VM_DEFINE_OP (56, unused_56, NULL, NOP)
+  VM_DEFINE_OP (56, call_u64_from_scm, "call-u64<-scm", OP2 (X8_S12_S12, C32) | OP_DST)
     {
-      vm_error_bad_instruction (op);
+      scm_t_uint8 dst, src;
-      abort (); /* never reached */
+      scm_t_uint64 res;
+      scm_t_u64_from_scm_intrinsic intrinsic;
+
+      UNPACK_12_12 (op, dst, src);
+      intrinsic = intrinsics[ip[1]];
+
+      SYNC_IP ();
+      res = intrinsic (SP_REF (src));
+      CACHE_SP ();
+      SP_SET_U64 (dst, res);
+
+      NEXT (2);
     }
 
 
@@ -2148,7 +2159,23 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (2);
     }
 
-  VM_DEFINE_OP (77, unused_77, NULL, NOP)
+  VM_DEFINE_OP (77, call_s64_from_scm, "call-s64<-scm", OP2 (X8_S12_S12, C32) | OP_DST)
+    {
+      scm_t_uint8 dst, src;
+      scm_t_int64 res;
+      scm_t_s64_from_scm_intrinsic intrinsic;
+
+      UNPACK_12_12 (op, dst, src);
+      intrinsic = intrinsics[ip[1]];
+
+      SYNC_IP ();
+      res = intrinsic (SP_REF (src));
+      CACHE_SP ();
+      SP_SET_S64 (dst, res);
+
+      NEXT (2);
+    }
+
   VM_DEFINE_OP (78, unused_78, NULL, NOP)
   VM_DEFINE_OP (79, unused_79, NULL, NOP)
   VM_DEFINE_OP (80, unused_80, NULL, NOP)
@@ -2328,11 +2355,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (0);
     }
 
-  /* scm->u64 dst:12 src:12
+  VM_DEFINE_OP (143, unused_143, NULL, NOP)
-   *
-   * Unpack an unsigned 64-bit integer from SRC and place it in DST.
-   */
-  VM_DEFINE_OP (143, scm_to_u64, "scm->u64", OP1 (X8_S12_S12) | OP_DST)
     {
       scm_t_uint16 dst, src;
       UNPACK_12_12 (op, dst, src);
@@ -2491,11 +2514,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (3);
     }
 
-  /* scm->s64 dst:12 src:12
+  VM_DEFINE_OP (157, unused_157, NULL, NOP)
-   *
-   * Unpack a signed 64-bit integer from SRC and place it in DST.
-   */
-  VM_DEFINE_OP (157, scm_to_s64, "scm->s64", OP1 (X8_S12_S12) | OP_DST)
     {
       scm_t_uint16 dst, src;
       UNPACK_12_12 (op, dst, src);
@@ -2647,13 +2666,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  /* scm->u64/truncate dst:12 src:12
+  VM_DEFINE_OP (167, unused_167, NULL, NOP)
-   *
-   * Unpack an exact integer from SRC and place it in the unsigned
-   * 64-bit register DST, truncating any high bits.  If the number in
-   * SRC is negative, all the high bits will be set.
-   */
-  VM_DEFINE_OP (167, scm_to_u64_truncate, "scm->u64/truncate", OP1 (X8_S12_S12) | OP_DST)
     {
       scm_t_uint16 dst, src;
       SCM x;

module/language/cps/reify-primitives.scm

@@ -230,6 +230,9 @@
       symbol->keyword
       class-of
       scm->f64
+      scm->u64
+      scm->u64/truncate
+      scm->s64
       u64->s64
       s64->u64
       cache-current-module!

module/system/vm/assembler.scm

@@ -201,6 +201,9 @@
             emit-symbol->keyword
             emit-class-of
             emit-scm->f64
+            emit-scm->u64
+            emit-scm->u64/truncate
+            emit-scm->s64
 
             emit-call
             emit-call-label
@@ -263,11 +266,8 @@
             emit-ulsh/immediate
             emit-make-array
             emit-load-f64
-            emit-scm->u64
-            emit-scm->u64/truncate
             emit-load-u64
             emit-u64->scm
-            emit-scm->s64
             emit-load-s64
             emit-s64->scm
             emit-make-atomic-box
@@ -1296,6 +1296,12 @@ returned instead."
 (define-syntax-rule (define-f64<-scm-intrinsic name)
   (define-macro-assembler (name asm dst src)
     (emit-call-f64<-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-u64<-scm-intrinsic name)
+  (define-macro-assembler (name asm dst src)
+    (emit-call-u64<-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-s64<-scm-intrinsic name)
+  (define-macro-assembler (name asm dst src)
+    (emit-call-s64<-scm asm dst src (intrinsic-name->index 'name))))
 
 (define-scm<-scm-scm-intrinsic add)
 (define-scm<-scm-uimm-intrinsic add/immediate)
@@ -1315,6 +1321,9 @@ returned instead."
 (define-scm<-scm-intrinsic symbol->keyword)
 (define-scm<-scm-intrinsic class-of)
 (define-f64<-scm-intrinsic scm->f64)
+(define-u64<-scm-intrinsic scm->u64)
+(define-u64<-scm-intrinsic scm->u64/truncate)
+(define-s64<-scm-intrinsic scm->s64)
 
 (define-macro-assembler (begin-program asm label properties)
   (emit-label asm label)