Add low-level support for unboxed 64-bit unsigned ints

* libguile/frames.c (enum stack_item_representation)
* libguile/frames.c (scm_to_stack_item_representation):
  (scm_frame_local_ref, scm_frame_local_set_x): Support 'u64 slots.
* libguile/frames.h (union scm_vm_stack_element): Add as_u64 member.

* libguile/vm-engine.c (SP_REF_U64, SP_SET_U64): New helpers.
  (scm->u64, u64->scm): New instructions.

* module/language/cps/cse.scm (compute-equivalent-subexpressions):
  Scalar replacement for u64->scm and scm->u64.

* module/language/cps/effects-analysis.scm (scm->u64, u64->scm): Add
  cases.

* module/language/cps/slot-allocation.scm (compute-var-representations):
  (allocate-slots): Represent the result of scm->u64 as a "u64" slot.

* module/language/cps/types.scm (&u64): New type.
  (scm->u64, u64->scm): Add support for these ops.

* module/system/vm/assembler.scm (write-arities):
* module/system/vm/debug.scm (arity-definitions): Support u64
  representations.

libguile/frames.c

@@ -241,7 +241,8 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
 enum stack_item_representation
   {
     STACK_ITEM_SCM = 0,
-    STACK_ITEM_F64 = 1
+    STACK_ITEM_F64 = 1,
+    STACK_ITEM_U64 = 2
   };
 
 static enum stack_item_representation
@@ -251,6 +252,8 @@ scm_to_stack_item_representation (SCM x, const char *subr, int pos)
     return STACK_ITEM_SCM;
   if (scm_is_eq (x, scm_from_latin1_symbol ("f64")))
     return STACK_ITEM_F64;
+  if (scm_is_eq (x, scm_from_latin1_symbol ("u64")))
+    return STACK_ITEM_U64;
 
   scm_wrong_type_arg (subr, pos, x);
   return 0;  /* Not reached.  */
@@ -281,6 +284,8 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0,
             return item->as_scm;
           case STACK_ITEM_F64:
             return scm_from_double (item->as_f64);
+          case STACK_ITEM_U64:
+            return scm_from_uint64 (item->as_u64);
           default:
             abort();
         }
@@ -318,6 +323,9 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 4, 0, 0,
           case STACK_ITEM_F64:
             item->as_f64 = scm_to_double (val);
             break;
+          case STACK_ITEM_U64:
+            item->as_u64 = scm_to_uint64 (val);
+            break;
           default:
             abort();
         }

libguile/frames.h

@@ -92,6 +92,7 @@ union scm_vm_stack_element
   scm_t_uint32 *as_ip;
   SCM as_scm;
   double as_f64;
+  scm_t_uint64 as_u64;
 
   /* For GC purposes.  */
   void *as_ptr;

libguile/vm-engine.c

@@ -254,6 +254,9 @@
 #define SP_REF_F64(i)		(sp[i].as_f64)
 #define SP_SET_F64(i,o)		(sp[i].as_f64 = o)
 
+#define SP_REF_U64(i)		(sp[i].as_u64)
+#define SP_SET_U64(i,o)		(sp[i].as_u64 = o)
+
 #define VARIABLE_REF(v)		SCM_VARIABLE_REF (v)
 #define VARIABLE_SET(v,o)	SCM_VARIABLE_SET (v, o)
 #define VARIABLE_BOUNDP(v)      (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
@@ -3312,8 +3315,32 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (0);
     }
 
-  VM_DEFINE_OP (143, unused_143, NULL, NOP)
+  /* scm->u64 dst:12 src:12
-  VM_DEFINE_OP (144, unused_144, 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);
+      SYNC_IP ();
+      SP_SET_U64 (dst, scm_to_uint64 (SP_REF (src)));
+      NEXT (1);
+    }
+
+  /* u64->scm dst:12 src:12
+   *
+   * Pack an unsigned 64-bit integer into a SCM value.
+   */
+  VM_DEFINE_OP (144, u64_to_scm, "u64->scm", OP1 (X8_S12_S12) | OP_DST)
+    {
+      scm_t_uint16 dst, src;
+      UNPACK_12_12 (op, dst, src);
+      SYNC_IP ();
+      SP_SET (dst, scm_from_uint64 (SP_REF_U64 (src)));
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (145, unused_145, NULL, NOP)
   VM_DEFINE_OP (146, unused_146, NULL, NOP)
   VM_DEFINE_OP (147, unused_147, NULL, NOP)

module/language/cps/cse.scm

@@ -307,6 +307,14 @@ false.  It could be that both true and false proofs are available."
              (match defs
                ((scm)
                 (add-def! `(primcall scm->f64 ,scm) f64))))
+            (('primcall 'scm->u64 scm)
+             (match defs
+               ((u64)
+                (add-def! `(primcall u64->scm ,u64) scm))))
+            (('primcall 'u64->scm u64)
+             (match defs
+               ((scm)
+                (add-def! `(primcall scm->u64 ,scm) u64))))
             (_ #t))))
 
       (define (visit-label label equiv-labels var-substs)

module/language/cps/effects-analysis.scm

@@ -351,10 +351,12 @@ is or might be a read or a write to the same location as A."
   ((string->number _)              (&read-object &string)      &type-check)
   ((string-length s)                                           &type-check))
 
-;; Unboxed floats.
+;; Unboxed floats and integers.
 (define-primitive-effects
   ((scm->f64 _)                                                &type-check)
-  ((f64->scm _)))
+  ((f64->scm _))
+  ((scm->u64 _)                                                &type-check)
+  ((u64->scm _)))
 
 ;; Bytevectors.
 (define-primitive-effects

module/language/cps/slot-allocation.scm

@@ -53,8 +53,8 @@
   ;;
   (slots allocation-slots)
 
-  ;; A map of VAR to representation.  A representation is either 'scm or
+  ;; A map of VAR to representation.  A representation is 'scm, 'f64, or
-  ;; 'f64.
+  ;; 'u64.
   ;;
   (representations allocation-representations)
 
@@ -793,6 +793,8 @@ are comparable with eqv?.  A tmp slot may be used."
              (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref
                                'fadd 'fsub 'fmul 'fdiv))
               (intmap-add representations var 'f64))
+             (($ $primcall (or 'scm->u64))
+              (intmap-add representations var 'u64))
              (_
               (intmap-add representations var 'scm))))
           (vars
@@ -874,7 +876,7 @@ are comparable with eqv?.  A tmp slot may be used."
            (#f slot-map)
            (slot
             (let ((desc (match (intmap-ref representations var)
-                          ('f64 slot-desc-live-raw)
+                          ((or 'u64 'f64) slot-desc-live-raw)
                           ('scm slot-desc-live-scm))))
               (logior slot-map (ash desc (* 2 slot)))))))
        live-vars 0))

module/language/cps/types.scm

@@ -119,6 +119,7 @@
 
             ;; Untagged types.
             &f64
+            &u64
 
             infer-types
             lookup-pre-type
@@ -169,7 +170,8 @@
   &array
   &hash-table
 
-  &f64)
+  &f64
+  &u64)
 
 (define-syntax &no-type (identifier-syntax 0))
 
@@ -678,7 +680,7 @@ minimum, and maximum."
 
 
 ;;;
-;;; Unboxed double-precision floating-point numbers.
+;;; Unboxed numbers.
 ;;;
 
 (define-type-checker (scm->f64 scm)
@@ -692,6 +694,17 @@ minimum, and maximum."
 (define-type-inferrer (f64->scm f64 result)
   (define! result &flonum (&min f64) (&max f64)))
 
+(define-type-checker (scm->u64 scm)
+  (check-type scm &exact-integer 0 +inf.0))
+(define-type-inferrer (scm->u64 scm result)
+  (restrict! scm &exact-integer 0 +inf.0)
+  (define! result &u64 (&min scm) (&max scm)))
+
+(define-type-checker (u64->scm u64)
+  #t)
+(define-type-inferrer (u64->scm u64 result)
+  (define! result &exact-integer (&min u64) (&max u64)))
+
 
 
 

module/system/vm/assembler.scm

@@ -1895,6 +1895,7 @@ procedure with label @var{rw-init}.  @var{rw-init} may be false.  If
            (let ((tag (case representation
                         ((scm) 0)
                         ((f64) 1)
+                        ((u64) 2)
                         (else (error "what!" representation)))))
              (put-uleb128 names-port (logior (ash slot 2) tag)))
            (lp definitions))))))

module/system/vm/debug.scm

@@ -386,6 +386,7 @@ section of the ELF image.  Returns an ELF symbol, or @code{#f}."
                          (representation (case (logand slot+representation #x3)
                                            ((0) 'scm)
                                            ((1) 'f64)
+                                           ((2) 'u64)
                                            (else 'unknown))))
                      (cons (vector name def-offset slot representation)
                            (lp pos names)))))))))))