diff options
-rw-r--r-- | libguile/vm-engine.c | 145 | ||||
-rw-r--r-- | libguile/vm.c | 7 | ||||
-rw-r--r-- | module/language/cps/closure-conversion.scm | 70 | ||||
-rw-r--r-- | module/language/cps/constructors.scm | 16 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 2 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 3 | ||||
-rw-r--r-- | module/language/cps/types.scm | 34 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 32 |
8 files changed, 193 insertions, 116 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index ed39fed5c..6b2458f0b 100644 --- a/libguile/vm-engine.c +++ b/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))) - RETURN (SCM_I_MAKINUM (scm_i_string_length (str))); - else - { - SYNC_IP (); - RETURN (scm_string_length (str)); - } + VM_ASSERT (scm_is_string (str), + vm_error_not_a_string ("string-length", str)); + SP_SET_U64 (dst, scm_i_string_length (str)); + NEXT (1); } /* 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; - ARGS2 (str, idx); - if (SCM_LIKELY (scm_is_string (str) - && SCM_I_INUMP (idx) - && ((i = SCM_I_INUM (idx)) >= 0) - && i < scm_i_string_length (str))) - RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i))); - else - { - SYNC_IP (); - RETURN (scm_string_ref (str, idx)); - } + scm_t_uint8 dst, src, idx; + SCM str; + scm_t_uint32 c_idx; + + UNPACK_8_8_8 (op, dst, src, idx); + str = SP_REF (src); + c_idx = SP_REF_U64 (idx); + + VM_ASSERT (scm_is_string (str), + vm_error_not_a_string ("string-ref", str)); + 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_UNDEFINED /* radix = 10 */)); + scm_string_to_number (SP_REF (src), + 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; - ARGS2 (vect, idx); + scm_t_uint8 dst, src, 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) - && ((i = SCM_I_INUM (idx)) >= 0) - && i < SCM_I_VECTOR_LENGTH (vect)), - vm_error_out_of_range ("vector-ref", idx)); - RETURN (SCM_I_VECTOR_ELTS (vect)[i]); + VM_ASSERT (c_idx < SCM_I_VECTOR_LENGTH (vect), + vm_error_out_of_range_uint64 ("vector-ref", c_idx)); + RETURN (SCM_I_VECTOR_ELTS (vect)[c_idx]); } /* 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); - VM_ASSERT (SCM_I_IS_VECTOR (v), - vm_error_not_a_vector ("vector-ref", v)); - VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (v), - vm_error_out_of_range ("vector-ref", scm_from_size_t (idx))); - SP_SET (dst, SCM_I_VECTOR_ELTS (SP_REF (src))[idx]); + vect = SP_REF (src); + 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_uint64 ("vector-ref", 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 vect, idx, val; - scm_t_signed_bits i = 0; + scm_t_uint8 dst, idx, src; + SCM vect, val; + 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_ASSERT ((SCM_I_INUMP (idx) - && ((i = SCM_I_INUM (idx)) >= 0) - && i < SCM_I_VECTOR_LENGTH (vect)), - vm_error_out_of_range ("vector-ref", idx)); - SCM_I_VECTOR_WELTS (vect)[i] = val; + vm_error_not_a_vector ("vector-set!", vect)); + VM_ASSERT (c_idx < SCM_I_VECTOR_LENGTH (vect), + vm_error_out_of_range_uint64 ("vector-set!", c_idx)); + SCM_I_VECTOR_WELTS (vect)[c_idx] = 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) - && SCM_I_INUM (index) >= 0 - && SCM_I_INUM (index) < (SCM_STRUCT_DATA_REF - (SCM_STRUCT_VTABLE (obj), - scm_vtable_index_size)))) - RETURN (SCM_STRUCT_SLOT_REF (obj, SCM_I_INUM (index))); + && index < (SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj), + scm_vtable_index_size)))) + RETURN (SCM_STRUCT_SLOT_REF (obj, 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) - && SCM_I_INUM (index) >= 0 - && SCM_I_INUM (index) < (SCM_STRUCT_DATA_REF - (SCM_STRUCT_VTABLE (obj), - scm_vtable_index_size)))) + && 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); } diff --git a/libguile/vm.c b/libguile/vm.c index 3bc59fc15..33f12b454 100644 --- a/libguile/vm.c +++ b/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; @@ -562,6 +563,12 @@ vm_error_not_a_pair (const char *subr, SCM x) } 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) { scm_wrong_type_arg_msg (subr, 1, x, "bytevector"); diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index c6f941db3..2fe4d8030 100644 --- a/module/language/cps/closure-conversion.scm +++ b/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)) - (op (cond - ((not self-known?) 'free-ref) - ((<= idx #xff) 'vector-ref/immediate) - (else 'vector-ref)))) - (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 op (self idx))))))))))) + (let ((idx (intset-find free var))) + (cond + (self-known? + (with-cps cps + (letv var* u64) + (let$ body (k var*)) + (letk k* ($kargs (#f) (var*) ,body)) + (letk kunbox ($kargs ('idx) (u64) + ($continue k* #f + ($primcall 'vector-ref (self u64))))) + ($ (with-cps-constants ((idx 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-constants ((nfree nfree) - (false #f)) - (build-term - ($continue k src ($primcall op (nfree false))))))))))) + (with-cps cps + ($ (with-cps-constants ((nfree nfree) + (false #f)) + (letv u64) + (letk kunbox ($kargs ('nfree) (u64) + ($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 - ((not known?) 'free-set!) - ((<= idx #xff) 'vector-set!/immediate) - (else 'vector-set!)))) + (cond + (known? + (with-cps cps + (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))) diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm index f86095198..170f0f17d 100644 --- a/module/language/cps/constructors.scm +++ b/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 - ($primcall 'vector-set! (vec idx arg)))))))))) + (build-term ($continue kunbox src + ($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 - ($primcall 'make-vector (len init)))))))) + (letv u64) + (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 diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 304d9f711..be0d1c2c5 100644 --- a/module/language/cps/effects-analysis.scm +++ b/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) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index c378bd1f5..0f5a43d43 100644 --- a/module/language/cps/slot-allocation.scm +++ b/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)) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index a5ea1bf72..6daddf0ea 100644 --- a/module/language/cps/types.scm +++ b/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) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index c1f976ae0..57c52aa1d 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/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) |