Add untag-fixnum instruction

* libguile/vm-engine.c (untag-fixnum): New instruction.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/system/vm/assembler.scm (untag-fixnum):
* module/language/cps/slot-allocation.scm (compute-var-representations):
* module/language/cps/types.scm (untag-fixnum): Add compiler support for
  untag-fixnum.

libguile/vm-engine.c

@@ -4413,7 +4413,17 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  VM_DEFINE_OP (214, unused_214, NULL, NOP)
+  VM_DEFINE_OP (214, untag_fixnum, "untag-fixnum", OP1 (X8_S12_S12) | OP_DST)
+    {
+      scm_t_uint16 dst, src;
+
+      UNPACK_12_12 (op, dst, src);
+
+      SP_SET_S64 (dst, SCM_I_INUM (SP_REF (src)));
+
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (215, unused_215, NULL, NOP)
   VM_DEFINE_OP (216, unused_216, NULL, NOP)
   VM_DEFINE_OP (217, unused_217, NULL, NOP)

module/language/cps/compile-bytecode.scm

@@ -272,6 +272,8 @@
          (emit-atomic-box-compare-and-swap!
           asm (from-sp dst) (from-sp (slot box))
           (from-sp (slot expected)) (from-sp (slot desired))))
+        (($ $primcall 'untag-fixnum (src))
+         (emit-untag-fixnum asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall name args)
          ;; FIXME: Inline all the cases.
          (let ((inst (prim-instruction name)))

module/language/cps/effects-analysis.scm

@@ -383,7 +383,8 @@ is or might be a read or a write to the same location as A."
   ((u64->scm _))
   ((scm->s64 _)                                                &type-check)
   ((load-s64 _))
-  ((s64->scm _)))
+  ((s64->scm _))
+  ((untag-fixnum _)))
 
 ;; Bytevectors.
 (define-primitive-effects

module/language/cps/slot-allocation.scm

@@ -810,7 +810,8 @@ are comparable with eqv?.  A tmp slot may be used."
                                '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
+             (($ $primcall (or 'untag-fixnum
+                               'scm->s64 'load-s64
                                'bv-s8-ref 'bv-s16-ref 'bv-s32-ref 'bv-s64-ref))
               (intmap-add representations var 's64))
              (_

module/language/cps/types.scm

@@ -870,10 +870,9 @@ minimum, and maximum."
   (define! result &s64 (&min/s64 scm) (&max/s64 scm)))
 (define-type-aliases scm->s64 load-s64)
 
-(define-type-checker (s64->scm s64)
-  #t)
-(define-type-inferrer (s64->scm s64 result)
-  (define-exact-integer! result (&min/s64 s64) (&max/s64 s64)))
+(define-simple-type-checker (untag-fixnum &fixnum))
+(define-type-inferrer (untag-fixnum scm result)
+  (define! result &s64 (&min/s64 scm) (&max/s64 scm)))
 
 
 

module/system/vm/assembler.scm

@@ -97,6 +97,8 @@
             emit-undefined?
             emit-eof-object?
 
+            emit-untag-fixnum
+
             emit-pair?
             emit-struct?
             emit-symbol?