mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
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.
This commit is contained in:
Andy Wingo
parent
a08b3d40f8
commit
c3240d09b2
8 changed files with 193 additions and 116 deletions
|
|
@ -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);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue