Unbox indexes of vectors, strings, and structs

* libguile/vm-engine.c (string-length, string-ref)
  (make-vector, vector-ref, vector-set!)
  (allocate-struct, struct-ref, struct-set!): Take indexes and return
  lengths as untagged u64 values.

* libguile/vm.c (vm_error_not_a_string): New helper.

* module/language/tree-il/compile-cps.scm (convert):
* module/language/cps/constructors.scm (inline-vector):
* module/language/cps/closure-conversion.scm (convert-one): Untag
  arguments to {string,vector,struct}-{ref,set!}, make-vector, and
  allocate-struct.  Tag return values from {string,vector}-length.

* module/language/cps/slot-allocation.scm (compute-var-representations):
  vector-length and string-length define u64 slots.

* module/language/cps/effects-analysis.scm: make-vector no longer causes
  a &type-check effect.

* module/language/cps/types.scm: Update to expect &u64 values for
  lengths and indexes.

libguile/vm-engine.c

@@ -2224,13 +2224,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
   VM_DEFINE_OP (76, string_length, "string-length", OP1 (X8_S12_S12) | OP_DST)
     {
       ARGS1 (str);
-      if (SCM_LIKELY (scm_is_string (str)))
+      VM_ASSERT (scm_is_string (str),
-        RETURN (SCM_I_MAKINUM (scm_i_string_length (str)));
+                 vm_error_not_a_string ("string-length", str));
-      else
+      SP_SET_U64 (dst, scm_i_string_length (str));
-        {
+      NEXT (1);
-          SYNC_IP ();
-          RETURN (scm_string_length (str));
-        }
     }
 
   /* string-ref dst:8 src:8 idx:8
@@ -2240,18 +2237,20 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
    */
   VM_DEFINE_OP (77, string_ref, "string-ref", OP1 (X8_S8_S8_S8) | OP_DST)
     {
-      scm_t_signed_bits i = 0;
+      scm_t_uint8 dst, src, idx;
-      ARGS2 (str, idx);
+      SCM str;
-      if (SCM_LIKELY (scm_is_string (str)
+      scm_t_uint32 c_idx;
-                      && SCM_I_INUMP (idx)
+
-                      && ((i = SCM_I_INUM (idx)) >= 0)
+      UNPACK_8_8_8 (op, dst, src, idx);
-                      && i < scm_i_string_length (str)))
+      str = SP_REF (src);
-        RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i)));
+      c_idx = SP_REF_U64 (idx);
-      else
+
-        {
+      VM_ASSERT (scm_is_string (str),
-          SYNC_IP ();
+                 vm_error_not_a_string ("string-ref", str));
-          RETURN (scm_string_ref (str, idx));
+      VM_ASSERT (c_idx < scm_i_string_length (str),
-        }
+                 vm_error_out_of_range_uint64 ("string-ref", c_idx));
+
+      RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, c_idx)));
     }
 
   /* No string-set! instruction, as there is no good fast path there.  */
@@ -2267,8 +2266,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       UNPACK_12_12 (op, dst, src);
       SYNC_IP ();
       SP_SET (dst,
-                 scm_string_to_number (SP_REF (src),
+              scm_string_to_number (SP_REF (src),
-                                       SCM_UNDEFINED /* radix = 10 */));
+                                    SCM_UNDEFINED /* radix = 10 */));
       NEXT (1);
     }
 
@@ -2574,11 +2573,17 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
    */
   VM_DEFINE_OP (99, make_vector, "make-vector", OP1 (X8_S8_S8_S8) | OP_DST)
     {
-      scm_t_uint8 dst, init, length;
+      scm_t_uint8 dst, length, init;
+      scm_t_uint64 length_val;
 
       UNPACK_8_8_8 (op, dst, length, init);
+      length_val = SP_REF_U64 (length);
+      VM_ASSERT (length_val < (size_t) -1,
+                 vm_error_out_of_range_uint64 ("make-vector", length_val));
 
-      SP_SET (dst, scm_make_vector (SP_REF (length), SP_REF (init)));
+      /* TODO: Inline this allocation.  */
+      SYNC_IP ();
+      SP_SET (dst, scm_c_make_vector (length_val, SP_REF (init)));
 
       NEXT (1);
     }
@@ -2615,7 +2620,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       ARGS1 (vect);
       VM_ASSERT (SCM_I_IS_VECTOR (vect),
                  vm_error_not_a_vector ("vector-ref", vect));
-      RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect)));
+
+      SP_SET_U64 (dst, SCM_I_VECTOR_LENGTH (vect));
+      NEXT (1);
     }
 
   /* vector-ref dst:8 src:8 idx:8
@@ -2625,15 +2632,19 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
    */
   VM_DEFINE_OP (102, vector_ref, "vector-ref", OP1 (X8_S8_S8_S8) | OP_DST)
     {
-      scm_t_signed_bits i = 0;
+      scm_t_uint8 dst, src, idx;
-      ARGS2 (vect, idx);
+      SCM vect;
+      scm_t_uint64 c_idx;
+
+      UNPACK_8_8_8 (op, dst, src, idx);
+      vect = SP_REF (src);
+      c_idx = SP_REF_U64 (idx);
+
       VM_ASSERT (SCM_I_IS_VECTOR (vect),
                  vm_error_not_a_vector ("vector-ref", vect));
-      VM_ASSERT ((SCM_I_INUMP (idx)
+      VM_ASSERT (c_idx < SCM_I_VECTOR_LENGTH (vect),
-                  && ((i = SCM_I_INUM (idx)) >= 0)
+                 vm_error_out_of_range_uint64 ("vector-ref", c_idx));
-                  && i < SCM_I_VECTOR_LENGTH (vect)),
+      RETURN (SCM_I_VECTOR_ELTS (vect)[c_idx]);
-                 vm_error_out_of_range ("vector-ref", idx));
-      RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
     }
 
   /* vector-ref/immediate dst:8 src:8 idx:8
@@ -2644,15 +2655,15 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
   VM_DEFINE_OP (103, vector_ref_immediate, "vector-ref/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
     {
       scm_t_uint8 dst, src, idx;
-      SCM v;
+      SCM vect;
       
       UNPACK_8_8_8 (op, dst, src, idx);
-      v = SP_REF (src);
+      vect = SP_REF (src);
-      VM_ASSERT (SCM_I_IS_VECTOR (v),
+      VM_ASSERT (SCM_I_IS_VECTOR (vect),
-                 vm_error_not_a_vector ("vector-ref", v));
+                 vm_error_not_a_vector ("vector-ref", vect));
-      VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (v),
+      VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (vect),
-                 vm_error_out_of_range ("vector-ref", scm_from_size_t (idx)));
+                 vm_error_out_of_range_uint64 ("vector-ref", idx));
-      SP_SET (dst, SCM_I_VECTOR_ELTS (SP_REF (src))[idx]);
+      SP_SET (dst, SCM_I_VECTOR_ELTS (vect)[idx]);
       NEXT (1);
     }
 
@@ -2662,22 +2673,20 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
    */
   VM_DEFINE_OP (104, vector_set, "vector-set!", OP1 (X8_S8_S8_S8))
     {
-      scm_t_uint8 dst, idx_var, src;
+      scm_t_uint8 dst, idx, src;
-      SCM vect, idx, val;
+      SCM vect, val;
-      scm_t_signed_bits i = 0;
+      scm_t_uint64 c_idx;
 
-      UNPACK_8_8_8 (op, dst, idx_var, src);
+      UNPACK_8_8_8 (op, dst, idx, src);
       vect = SP_REF (dst);
-      idx = SP_REF (idx_var);
+      c_idx = SP_REF_U64 (idx);
       val = SP_REF (src);
 
       VM_ASSERT (SCM_I_IS_VECTOR (vect),
-                 vm_error_not_a_vector ("vector-ref", vect));
+                 vm_error_not_a_vector ("vector-set!", vect));
-      VM_ASSERT ((SCM_I_INUMP (idx)
+      VM_ASSERT (c_idx < SCM_I_VECTOR_LENGTH (vect),
-                  && ((i = SCM_I_INUM (idx)) >= 0)
+                 vm_error_out_of_range_uint64 ("vector-set!", c_idx));
-                  && i < SCM_I_VECTOR_LENGTH (vect)),
+      SCM_I_VECTOR_WELTS (vect)[c_idx] = val;
-                 vm_error_out_of_range ("vector-ref", idx));
-      SCM_I_VECTOR_WELTS (vect)[i] = val;
       NEXT (1);
     }
 
@@ -2698,7 +2707,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       VM_ASSERT (SCM_I_IS_VECTOR (vect),
                  vm_error_not_a_vector ("vector-ref", vect));
       VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (vect),
-                 vm_error_out_of_range ("vector-ref", scm_from_size_t (idx)));
+                 vm_error_out_of_range_uint64 ("vector-ref", idx));
       SCM_I_VECTOR_WELTS (vect)[idx] = val;
       NEXT (1);
     }
@@ -2734,8 +2743,11 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
       UNPACK_8_8_8 (op, dst, vtable, nfields);
 
+      /* TODO: Specify nfields as untagged value when calling
+         allocate-struct.  */
       SYNC_IP ();
-      ret = scm_allocate_struct (SP_REF (vtable), SP_REF (nfields));
+      ret = scm_allocate_struct (SP_REF (vtable),
+                                 scm_from_uint64 (SP_REF_U64 (nfields)));
       SP_SET (dst, ret);
 
       NEXT (1);
@@ -2750,25 +2762,22 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
     {
       scm_t_uint8 dst, src, idx;
       SCM obj;
-      SCM index;
+      scm_t_uint64 index;
 
       UNPACK_8_8_8 (op, dst, src, idx);
 
       obj = SP_REF (src);
-      index = SP_REF (idx);
+      index = SP_REF_U64 (idx);
 
       if (SCM_LIKELY (SCM_STRUCTP (obj)
                       && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
                                                         SCM_VTABLE_FLAG_SIMPLE)
-                      && SCM_I_INUMP (index)
+                      && index < (SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj),
-                      && SCM_I_INUM (index) >= 0
+                                                       scm_vtable_index_size))))
-                      && SCM_I_INUM (index) < (SCM_STRUCT_DATA_REF
+        RETURN (SCM_STRUCT_SLOT_REF (obj, index));
-                                               (SCM_STRUCT_VTABLE (obj),
-                                                scm_vtable_index_size))))
-        RETURN (SCM_STRUCT_SLOT_REF (obj, SCM_I_INUM (index)));
 
       SYNC_IP ();
-      RETURN (scm_struct_ref (obj, index));
+      RETURN (scm_struct_ref (obj, scm_from_uint64 (index)));
     }
 
   /* struct-set! dst:8 idx:8 src:8
@@ -2778,31 +2787,29 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
   VM_DEFINE_OP (109, struct_set, "struct-set!", OP1 (X8_S8_S8_S8))
     {
       scm_t_uint8 dst, idx, src;
-      SCM obj, val, index;
+      SCM obj, val;
+      scm_t_uint64 index;
 
       UNPACK_8_8_8 (op, dst, idx, src);
 
       obj = SP_REF (dst);
       val = SP_REF (src);
-      index = SP_REF (idx);
+      index = SP_REF_U64 (idx);
 
       if (SCM_LIKELY (SCM_STRUCTP (obj)
                       && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
                                                         SCM_VTABLE_FLAG_SIMPLE)
                       && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
                                                         SCM_VTABLE_FLAG_SIMPLE_RW)
-                      && SCM_I_INUMP (index)
+                      && index < (SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj),
-                      && SCM_I_INUM (index) >= 0
+                                                       scm_vtable_index_size))))
-                      && SCM_I_INUM (index) < (SCM_STRUCT_DATA_REF
-                                               (SCM_STRUCT_VTABLE (obj),
-                                                scm_vtable_index_size))))
         {
-          SCM_STRUCT_SLOT_SET (obj, SCM_I_INUM (index), val);
+          SCM_STRUCT_SLOT_SET (obj, index, val);
           NEXT (1);
         }
 
       SYNC_IP ();
-      scm_struct_set_x (obj, index, val);
+      scm_struct_set_x (obj, scm_from_uint64 (index), val);
       NEXT (1);
     }
 

libguile/vm.c

@@ -443,6 +443,7 @@ static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_not_a_string (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE;
@@ -561,6 +562,12 @@ vm_error_not_a_pair (const char *subr, SCM x)
   scm_wrong_type_arg_msg (subr, 1, x, "pair");
 }
 
+static void
+vm_error_not_a_string (const char *subr, SCM x)
+{
+  scm_wrong_type_arg_msg (subr, 1, x, "string");
+}
+
 static void
 vm_error_not_a_bytevector (const char *subr, SCM x)
 {

module/language/cps/closure-conversion.scm

@@ -490,18 +490,29 @@ Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
                (letk k* ($kargs (#f) (var*) ,body))
                (build-term ($continue k* #f ($primcall op (self)))))))
           (_
-           (let* ((idx (intset-find free var))
+           (let ((idx (intset-find free var)))
-                  (op (cond
+             (cond
-                       ((not self-known?) 'free-ref)
+              (self-known?
-                       ((<= idx #xff) 'vector-ref/immediate)
+               (with-cps cps
-                       (else 'vector-ref))))
+                 (letv var* u64)
-             (with-cps cps
+                 (let$ body (k var*))
-               (letv var*)
+                 (letk k* ($kargs (#f) (var*) ,body))
-               (let$ body (k var*))
+                 (letk kunbox ($kargs ('idx) (u64)
-               (letk k* ($kargs (#f) (var*) ,body))
+                                ($continue k* #f
-               ($ (with-cps-constants ((idx idx))
+                                  ($primcall 'vector-ref (self u64)))))
-                    (build-term
+                 ($ (with-cps-constants ((idx idx))
-                      ($continue k* #f ($primcall op (self idx)))))))))))
+                      (build-term
+                        ($continue kunbox #f
+                          ($primcall 'scm->u64 (idx))))))))
+              (else
+               (with-cps cps
+                 (letv var*)
+                 (let$ body (k var*))
+                 (letk k* ($kargs (#f) (var*) ,body))
+                 ($ (with-cps-constants ((idx idx))
+                      (build-term
+                        ($continue k* #f
+                          ($primcall 'free-ref (self idx)))))))))))))
        (else
         (with-cps cps
           ($ (k var))))))
@@ -541,12 +552,15 @@ term."
         (#(#t nfree)
          (unless (> nfree 2)
            (error "unexpected well-known nullary, unary, or binary closure"))
-         (let ((op (if (<= nfree #xff) 'make-vector/immediate 'make-vector)))
+         (with-cps cps
-           (with-cps cps
+           ($ (with-cps-constants ((nfree nfree)
-             ($ (with-cps-constants ((nfree nfree)
+                                   (false #f))
-                                     (false #f))
+                (letv u64)
-                  (build-term
+                (letk kunbox ($kargs ('nfree) (u64)
-                    ($continue k src ($primcall op (nfree false)))))))))))
+                               ($continue k src
+                                 ($primcall 'make-vector (u64 false)))))
+                (build-term
+                  ($continue kunbox src ($primcall 'scm->u64 (nfree))))))))))
 
     (define (init-closure cps k src var known? free)
       "Initialize the free variables @var{closure-free} in a closure
@@ -587,15 +601,25 @@ bound to @var{var}, and continue to @var{k}."
                   (letk k ($kargs () () ,body))
                   ($ (convert-arg v
                        (lambda (cps v)
-                         (let ((op (cond
+                         (cond
-                                    ((not known?) 'free-set!)
+                          (known?
-                                    ((<= idx #xff) 'vector-set!/immediate)
+                           (with-cps cps
-                                    (else 'vector-set!))))
+                             (letv u64)
+                             (letk kunbox
+                                   ($kargs ('idx) (u64)
+                                     ($continue k src
+                                       ($primcall 'vector-set! (var u64 v)))))
+                             ($ (with-cps-constants ((idx idx))
+                                  (build-term
+                                    ($continue kunbox src
+                                      ($primcall 'scm->u64 (idx))))))))
+                          (else
                            (with-cps cps
                              ($ (with-cps-constants ((idx idx))
                                   (build-term
                                     ($continue k src
-                                      ($primcall op (var idx v))))))))))))))))))
+                                      ($primcall 'free-set!
+                                                 (var idx v)))))))))))))))))))
 
     (define (make-single-closure cps k src kfun)
       (let ((free (intmap-ref free-vars kfun)))

module/language/cps/constructors.scm

@@ -61,17 +61,25 @@
        (with-cps out
          (let$ next (initialize vec args (1+ n)))
          (letk knext ($kargs () () ,next))
+         (letv u64)
+         (letk kunbox ($kargs ('idx) (u64)
+                        ($continue knext src
+                          ($primcall 'vector-set! (vec u64 arg)))))
          ($ (with-cps-constants ((idx n))
-              (build-term ($continue knext src
+              (build-term ($continue kunbox src
-                            ($primcall 'vector-set! (vec idx arg))))))))))
+                            ($primcall 'scm->u64 (idx))))))))))
   (with-cps out
     (letv vec)
     (let$ body (initialize vec args 0))
     (letk kalloc ($kargs ('vec) (vec) ,body))
     ($ (with-cps-constants ((len (length args))
                             (init #f))
-         (build-term ($continue kalloc src
+         (letv u64)
-                       ($primcall 'make-vector (len init))))))))
+         (letk kunbox ($kargs ('len) (u64)
+                        ($continue kalloc src
+                          ($primcall 'make-vector (u64 init)))))
+         (build-term ($continue kunbox src
+                       ($primcall 'scm->u64 (len))))))))
 
 (define (find-constructor-inliner name)
   (match name

module/language/cps/effects-analysis.scm

@@ -317,7 +317,7 @@ is or might be a read or a write to the same location as A."
   (logior &write (vector-field n constants)))
 (define-primitive-effects* constants
   ((vector . _)                    (&allocate &vector))
-  ((make-vector n init)            (&allocate &vector)         &type-check)
+  ((make-vector n init)            (&allocate &vector))
   ((make-vector/immediate n init)  (&allocate &vector))
   ((vector-ref v n)                (read-vector-field n constants) &type-check)
   ((vector-ref/immediate v n)      (read-vector-field n constants) &type-check)

module/language/cps/slot-allocation.scm

@@ -800,7 +800,8 @@ are comparable with eqv?.  A tmp slot may be used."
                                'bv-f32-ref 'bv-f64-ref
                                'fadd 'fsub 'fmul 'fdiv))
               (intmap-add representations var 'f64))
-             (($ $primcall (or 'scm->u64 'load-u64 'bv-length
+             (($ $primcall (or 'scm->u64 'load-u64
+                               'bv-length 'vector-length 'string-length
                                'uadd 'usub 'umul
                                'uadd/immediate 'usub/immediate 'umul/immediate
                                'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref))

module/language/cps/types.scm

@@ -592,26 +592,26 @@ minimum, and maximum."
 ;; This max-vector-len computation is a hack.
 (define *max-vector-len* (ash most-positive-fixnum -5))
 
-(define-simple-type-checker (make-vector (&exact-integer 0 *max-vector-len*)
+(define-simple-type-checker (make-vector (&u64 0 *max-vector-len*)
                                          &all-types))
 (define-type-inferrer (make-vector size init result)
-  (restrict! size &exact-integer 0 *max-vector-len*)
+  (restrict! size &u64 0 *max-vector-len*)
   (define! result &vector (max (&min size) 0) (&max size)))
 
 (define-type-checker (vector-ref v idx)
   (and (check-type v &vector 0 *max-vector-len*)
-       (check-type idx &exact-integer 0 (1- (&min v)))))
+       (check-type idx &u64 0 (1- (&min v)))))
 (define-type-inferrer (vector-ref v idx result)
   (restrict! v &vector (1+ (&min idx)) *max-vector-len*)
-  (restrict! idx &exact-integer 0 (1- (min (&max v) *max-vector-len*)))
+  (restrict! idx &u64 0 (1- (min (&max v) *max-vector-len*)))
   (define! result &all-types -inf.0 +inf.0))
 
 (define-type-checker (vector-set! v idx val)
   (and (check-type v &vector 0 *max-vector-len*)
-       (check-type idx &exact-integer 0 (1- (&min v)))))
+       (check-type idx &u64 0 (1- (&min v)))))
 (define-type-inferrer (vector-set! v idx val)
   (restrict! v &vector (1+ (&min idx)) *max-vector-len*)
-  (restrict! idx &exact-integer 0 (1- (min (&max v) *max-vector-len*))))
+  (restrict! idx &u64 0 (1- (min (&max v) *max-vector-len*))))
 
 (define-type-aliases make-vector make-vector/immediate)
 (define-type-aliases vector-ref vector-ref/immediate)
@@ -620,7 +620,7 @@ minimum, and maximum."
 (define-simple-type-checker (vector-length &vector))
 (define-type-inferrer (vector-length v result)
   (restrict! v &vector 0 *max-vector-len*)
-  (define! result &exact-integer (max (&min v) 0)
+  (define! result &u64 (max (&min v) 0)
     (min (&max v) *max-vector-len*)))
 
 
@@ -634,27 +634,27 @@ minimum, and maximum."
 ;; vt is actually a vtable.
 (define-type-inferrer (allocate-struct vt size result)
   (restrict! vt &struct vtable-offset-user *max-size-t*)
-  (restrict! size &exact-integer 0 *max-size-t*)
+  (restrict! size &u64 0 *max-size-t*)
   (define! result &struct (max (&min size) 0) (min (&max size) *max-size-t*)))
 
 (define-type-checker (struct-ref s idx)
   (and (check-type s &struct 0 *max-size-t*)
-       (check-type idx &exact-integer 0 *max-size-t*)
+       (check-type idx &u64 0 *max-size-t*)
        ;; FIXME: is the field readable?
        (< (&max idx) (&min s))))
 (define-type-inferrer (struct-ref s idx result)
   (restrict! s &struct (1+ (&min idx)) *max-size-t*)
-  (restrict! idx &exact-integer 0 (1- (min (&max s) *max-size-t*)))
+  (restrict! idx &u64 0 (1- (min (&max s) *max-size-t*)))
   (define! result &all-types -inf.0 +inf.0))
 
 (define-type-checker (struct-set! s idx val)
   (and (check-type s &struct 0 *max-size-t*)
-       (check-type idx &exact-integer 0 *max-size-t*)
+       (check-type idx &u64 0 *max-size-t*)
        ;; FIXME: is the field writable?
        (< (&max idx) (&min s))))
 (define-type-inferrer (struct-set! s idx val)
   (restrict! s &struct (1+ (&min idx)) *max-size-t*)
-  (restrict! idx &exact-integer 0 (1- (min (&max s) *max-size-t*))))
+  (restrict! idx &u64 0 (1- (min (&max s) *max-size-t*))))
 
 (define-type-aliases allocate-struct allocate-struct/immediate)
 (define-type-aliases struct-ref struct-ref/immediate)
@@ -674,11 +674,11 @@ minimum, and maximum."
 
 (define-type-checker (string-ref s idx)
   (and (check-type s &string 0 *max-size-t*)
-       (check-type idx &exact-integer 0 *max-size-t*)
+       (check-type idx &u64 0 *max-size-t*)
        (< (&max idx) (&min s))))
 (define-type-inferrer (string-ref s idx result)
   (restrict! s &string (1+ (&min idx)) *max-size-t*)
-  (restrict! idx &exact-integer 0 (1- (min (&max s) *max-size-t*)))
+  (restrict! idx &u64 0 (1- (min (&max s) *max-size-t*)))
   (define! result &char 0 *max-char*))
 
 (define-type-checker (string-set! s idx val)
@@ -694,7 +694,7 @@ minimum, and maximum."
 (define-simple-type-checker (string-length &string))
 (define-type-inferrer (string-length s result)
   (restrict! s &string 0 *max-size-t*)
-  (define! result &exact-integer (max (&min s) 0) (min (&max s) *max-size-t*)))
+  (define! result &u64 (max (&min s) 0) (min (&max s) *max-size-t*)))
 
 (define-simple-type (number->string &number) (&string 0 *max-size-t*))
 (define-simple-type (string->number (&string 0 *max-size-t*))
@@ -753,7 +753,7 @@ minimum, and maximum."
 (define-simple-type-checker (bv-length &bytevector))
 (define-type-inferrer (bv-length bv result)
   (restrict! bv &bytevector 0 *max-size-t*)
-  (define! result &exact-integer
+  (define! result &u64
     (max (&min bv) 0) (min (&max bv) *max-size-t*)))
 
 (define-syntax-rule (define-bytevector-accessors ref set type size lo hi)
@@ -773,7 +773,7 @@ minimum, and maximum."
            (< (&max idx) (- (&min bv) size))))
     (define-type-inferrer (set! bv idx val)
       (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*)
-      (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size))
+      (restrict! idx &u64 0 (- (min (&max bv) *max-size-t*) size))
       (restrict! val type lo hi))))
 
 (define-bytevector-accessors bv-u8-ref bv-u8-set! &u64 1 0 #xff)

module/language/tree-il/compile-cps.scm

@@ -576,7 +576,9 @@
                    (letk kbox ($kargs ('f64) (f64)
                                 ($continue k src ($primcall 'f64->scm (f64)))))
                    kbox))
-                ((bv-length bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref)
+                ((string-length
+                  vector-length
+                  bv-length bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref)
                  (with-cps cps
                    (letv u64)
                    (let$ k (adapt-arity k src out))
@@ -640,6 +642,34 @@
                         cps val 'scm->u64
                         (lambda (cps val)
                           (have-args cps (list bv idx val)))))))))
+                ((vector-ref struct-ref string-ref)
+                 (match args
+                   ((obj idx)
+                    (unbox-arg
+                     cps idx 'scm->u64
+                     (lambda (cps idx)
+                       (have-args cps (list obj idx)))))))
+                ((vector-set! struct-set!)
+                 (match args
+                   ((obj idx val)
+                    (unbox-arg
+                     cps idx 'scm->u64
+                     (lambda (cps idx)
+                       (have-args cps (list obj idx val)))))))
+                ((make-vector)
+                 (match args
+                   ((length init)
+                    (unbox-arg
+                     cps length 'scm->u64
+                     (lambda (cps length)
+                       (have-args cps (list length init)))))))
+                ((allocate-struct)
+                 (match args
+                   ((vtable nfields)
+                    (unbox-arg
+                     cps nfields 'scm->u64
+                     (lambda (cps nfields)
+                       (have-args cps (list vtable nfields)))))))
                 (else (have-args cps args))))
             (convert-args cps args
               (lambda (cps args)