Add tag-fixnum instruction

* libguile/vm-engine.c (tag-fixnum): New instruction.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/cse.scm (compute-equivalent-subexpressions):
* module/language/cps/effects-analysis.scm:
* module/language/cps/types.scm (&min/fixnum, &max/fixnum, tag-fixnum):
* module/system/vm/assembler.scm: Add support for the new instruction.

libguile/vm-engine.c

@@ -4057,7 +4057,17 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  VM_DEFINE_OP (215, unused_215, NULL, NOP)
+  VM_DEFINE_OP (215, tag_fixnum, "tag-fixnum", OP1 (X8_S12_S12) | OP_DST)
+    {
+      scm_t_uint16 dst, src;
+
+      UNPACK_12_12 (op, dst, src);
+
+      SP_SET (dst, SCM_I_MAKINUM (SP_REF_S64 (src)));
+
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (216, unused_216, NULL, NOP)
   VM_DEFINE_OP (217, unused_217, NULL, NOP)
   VM_DEFINE_OP (218, unused_218, NULL, NOP)

module/language/cps/compile-bytecode.scm

@@ -271,6 +271,8 @@
           (from-sp (slot expected)) (from-sp (slot desired))))
         (($ $primcall 'untag-fixnum #f (src))
          (emit-untag-fixnum asm (from-sp dst) (from-sp (slot src))))
+        (($ $primcall 'tag-fixnum #f (src))
+         (emit-tag-fixnum asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall name #f args)
          ;; FIXME: Inline all the cases.
          (let ((inst (prim-instruction name)))

module/language/cps/cse.scm

@@ -329,6 +329,11 @@ false.  It could be that both true and false proofs are available."
              (match defs
                ((scm)
                 (add-def! `(primcall scm->s64 #f ,scm) s64))))
+            (('primcall 'untag-fixnum #f scm)
+             (match defs
+               ((s64)
+                (add-def! `(primcall s64->scm #f ,s64) scm)
+                (add-def! `(primcall tag-fixnum #f ,s64) scm))))
             (_ #t))))
 
       (define (visit-label label equiv-labels var-substs)

module/language/cps/effects-analysis.scm

@@ -374,7 +374,8 @@ is or might be a read or a write to the same location as A."
   ((load-s64))
   ((s64->scm _))
   ((s64->scm/unlikely _))
-  ((untag-fixnum _)))
+  ((untag-fixnum _))
+  ((tag-fixnum _)))
 
 ;; Bytevectors.
 (define-primitive-effects

module/language/cps/types.scm

@@ -398,6 +398,8 @@ minimum, and maximum."
 (define-syntax-rule (&max/u64 x) (min (&max x) &u64-max))
 (define-syntax-rule (&min/s64 x) (max (&min x) &s64-min))
 (define-syntax-rule (&max/s64 x) (min (&max x) &s64-max))
+(define-syntax-rule (&min/fixnum x) (max (&min x) most-negative-fixnum))
+(define-syntax-rule (&max/fixnum x) (min (&max x) most-positive-fixnum))
 (define-syntax-rule (&max/size x) (min (&max x) (target-max-size-t)))
 (define-syntax-rule (&max/scm-size x) (min (&max x) (target-max-size-t/scm)))
 
@@ -901,6 +903,10 @@ minimum, and maximum."
 (define-type-inferrer (untag-fixnum scm result)
   (define! result &s64 (&min/s64 scm) (&max/s64 scm)))
 
+(define-simple-type-checker (tag-fixnum (logior &s64 &u64)))
+(define-type-inferrer (tag-fixnum s64 result)
+  (define! result &fixnum (&min/fixnum s64) (&max/fixnum s64)))
+
 
 
 

module/system/vm/assembler.scm

@@ -98,6 +98,7 @@
             emit-eof-object?
 
             emit-untag-fixnum
+            emit-tag-fixnum
 
             emit-throw
             (emit-throw/value* . emit-throw/value)