[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 34/41: Unbox indexes of vectors, strings, and structs
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 34/41: Unbox indexes of vectors, strings, and structs |
|
Date: |
Wed, 02 Dec 2015 08:06:58 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit c3240d09b2d05d0c33d0dcfed076f944fcfa5de4
Author: Andy Wingo <address@hidden>
Date: Tue Nov 24 10:15:21 2015 +0100
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 | 145 +++++++++++++++-------------
libguile/vm.c | 7 ++
module/language/cps/closure-conversion.scm | 70 +++++++++-----
module/language/cps/constructors.scm | 16 +++-
module/language/cps/effects-analysis.scm | 2 +-
module/language/cps/slot-allocation.scm | 3 +-
module/language/cps/types.scm | 34 ++++----
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 ed39fed..6b2458f 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 3bc59fc..33f12b4 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 c6f941d..2fe4d80 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 f860951..170f0f1 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 304d9f7..be0d1c2 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 c378bd1..0f5a43d 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 a5ea1bf..6daddf0 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 c1f976a..57c52aa 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)
- [Guile-commits] 29/41: Remove add1 and sub1, (continued)
- [Guile-commits] 29/41: Remove add1 and sub1, Andy Wingo, 2015/12/02
- [Guile-commits] 30/41: Add tagged and untagged arithmetic ops with immediate operands, Andy Wingo, 2015/12/02
- [Guile-commits] 32/41: Add support for unboxed s64 values, Andy Wingo, 2015/12/02
- [Guile-commits] 39/41: Specialize u64 bit operations, Andy Wingo, 2015/12/02
- [Guile-commits] 31/41: New instructions load-f64, load-u64, Andy Wingo, 2015/12/02
- [Guile-commits] 36/41: Add logsub op., Andy Wingo, 2015/12/02
- [Guile-commits] 40/41: More efficient assembler instructions, Andy Wingo, 2015/12/02
- [Guile-commits] 33/41: Untag values and indexes for all bytevector instructions, Andy Wingo, 2015/12/02
- [Guile-commits] 41/41: Assembler has a single growable vector, Andy Wingo, 2015/12/02
- [Guile-commits] 38/41: Add untagged bitwise operations, Andy Wingo, 2015/12/02
- [Guile-commits] 34/41: Unbox indexes of vectors, strings, and structs,
Andy Wingo <=