mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-17 22:42:25 +02:00
Code Activity

Add make-vector, constant-make-vector instructions

Browse source 
* libguile/vm-engine.c (rtl_vm_engine): Add make-vector and
  constant-make-vector instructions and renumber.

* module/language/cps/compile-rtl.scm (emit-rtl-sequence): Emit
  constant-make-vector and make-vector as appropriate.

* module/language/cps/dfg.scm (constant-needs-allocation?): In some
  cases, make-vector doesn't need to allocate its index.

*  module/language/tree-il/primitives.scm
   (*interesting-primitive-names*, *primitive-constructors*): Add
   make-vector.
This commit is contained in:
Andy Wingo 2013-10-26 22:06:01 +02:00
parent 8ba3f20c47
commit 607fe5a604
4 changed files with 103 additions and 47 deletions
Download patch file Download diff file Expand all files Collapse all files

106
libguile/vm-engine.c
View file

@ -2847,11 +2847,49 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
RETURN (scm_logxor (x, y)); RETURN (scm_logxor (x, y));
} }
/* make-vector dst:8 length:8 init:8
*
* Make a vector and write it to DST. The vector will have space for
* LENGTH slots. They will be filled with the value in slot INIT.
*/
VM_DEFINE_OP (89, make_vector, "make-vector", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, length, init;
SCM_UNPACK_RTL_8_8_8 (op, dst, length, init);
LOCAL_SET (dst, scm_make_vector (LOCAL_REF (length), LOCAL_REF (init)));
NEXT (1);
}
/* constant-make-vector dst:8 length:8 init:8
*
* Make a short vector of known size and write it to DST. The vector
* will have space for LENGTH slots, an immediate value. They will be
* filled with the value in slot INIT.
*/
VM_DEFINE_OP (90, constant_make_vector, "constant-make-vector", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, init;
scm_t_int32 length, n;
SCM val, vector;
SCM_UNPACK_RTL_8_8_8 (op, dst, length, init);
val = LOCAL_REF (init);
vector = scm_words (scm_tc7_vector | (length << 8), length + 1);
for (n = 0; n < length; n++)
SCM_SIMPLE_VECTOR_SET (vector, n, val);
LOCAL_SET (dst, vector);
NEXT (1);
}
/* vector-length dst:12 src:12 /* vector-length dst:12 src:12
* *
* Store the length of the vector in SRC in DST. * Store the length of the vector in SRC in DST.
*/ */
VM_DEFINE_OP (89, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST) VM_DEFINE_OP (91, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
{ {
ARGS1 (vect); ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (vect))) if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
@ -2868,7 +2906,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Fetch the item at position IDX in the vector in SRC, and store it * Fetch the item at position IDX in the vector in SRC, and store it
* in DST. * in DST.
*/ */
VM_DEFINE_OP (90, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (92, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{ {
scm_t_signed_bits i = 0; scm_t_signed_bits i = 0;
ARGS2 (vect, idx); ARGS2 (vect, idx);
@ -2889,7 +2927,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Fill DST with the item IDX elements into the vector at SRC. Useful * Fill DST with the item IDX elements into the vector at SRC. Useful
* for building data types using vectors. * for building data types using vectors.
*/ */
VM_DEFINE_OP (91, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (93, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{ {
scm_t_uint8 dst, src, idx; scm_t_uint8 dst, src, idx;
SCM v; SCM v;
@ -2908,7 +2946,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* *
* Store SRC into the vector DST at index IDX. * Store SRC into the vector DST at index IDX.
*/ */
VM_DEFINE_OP (92, vector_set, "vector-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (94, vector_set, "vector-set!", OP1 (U8_U8_U8_U8))
{ {
scm_t_uint8 dst, idx_var, src; scm_t_uint8 dst, idx_var, src;
SCM vect, idx, val; SCM vect, idx, val;
@ -2937,7 +2975,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Store SRC into the vector DST at index IDX. Here IDX is an * Store SRC into the vector DST at index IDX. Here IDX is an
* immediate value. * immediate value.
*/ */
VM_DEFINE_OP (93, constant_vector_set, "constant-vector-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (95, constant_vector_set, "constant-vector-set!", OP1 (U8_U8_U8_U8))
{ {
scm_t_uint8 dst, idx, src; scm_t_uint8 dst, idx, src;
SCM vect, val; SCM vect, val;
@ -2968,7 +3006,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* *
* Store the vtable of SRC into DST. * Store the vtable of SRC into DST.
*/ */
VM_DEFINE_OP (94, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST) VM_DEFINE_OP (96, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
{ {
ARGS1 (obj); ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable"); VM_VALIDATE_STRUCT (obj, "struct_vtable");
@ -2981,7 +3019,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* will be constructed with space for NFIELDS fields, which should * will be constructed with space for NFIELDS fields, which should
* correspond to the field count of the VTABLE. * correspond to the field count of the VTABLE.
*/ */
VM_DEFINE_OP (95, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (97, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST)
{ {
scm_t_uint8 dst, vtable, nfields; scm_t_uint8 dst, vtable, nfields;
SCM ret; SCM ret;
@ -3000,7 +3038,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Fetch the item at slot IDX in the struct in SRC, and store it * Fetch the item at slot IDX in the struct in SRC, and store it
* in DST. * in DST.
*/ */
VM_DEFINE_OP (96, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (98, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{ {
ARGS2 (obj, pos); ARGS2 (obj, pos);
@ -3034,7 +3072,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* *
* Store SRC into the struct DST at slot IDX. * Store SRC into the struct DST at slot IDX.
*/ */
VM_DEFINE_OP (97, struct_set, "struct-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (99, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
{ {
scm_t_uint8 dst, idx, src; scm_t_uint8 dst, idx, src;
SCM obj, pos, val; SCM obj, pos, val;
@ -3075,7 +3113,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* *
* Store the vtable of SRC into DST. * Store the vtable of SRC into DST.
*/ */
VM_DEFINE_OP (98, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST) VM_DEFINE_OP (100, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
{ {
ARGS1 (obj); ARGS1 (obj);
if (SCM_INSTANCEP (obj)) if (SCM_INSTANCEP (obj))
@ -3090,7 +3128,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
* index into the stack. * index into the stack.
*/ */
VM_DEFINE_OP (99, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (101, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{ {
scm_t_uint8 dst, src, idx; scm_t_uint8 dst, src, idx;
SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx); SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
@ -3104,7 +3142,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* Store SRC into slot IDX of the struct in DST. Unlike struct-set!, * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
* IDX is an 8-bit immediate value, not an index into the stack. * IDX is an 8-bit immediate value, not an index into the stack.
*/ */
VM_DEFINE_OP (100, slot_set, "slot-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (102, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
{ {
scm_t_uint8 dst, idx, src; scm_t_uint8 dst, idx, src;
SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
@ -3125,7 +3163,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* from the instruction pointer, and store into DST. LEN is a byte * from the instruction pointer, and store into DST. LEN is a byte
* length. OFFSET is signed. * length. OFFSET is signed.
*/ */
VM_DEFINE_OP (101, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST) VM_DEFINE_OP (103, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST)
{ {
scm_t_uint8 dst, type, shape; scm_t_uint8 dst, type, shape;
scm_t_int32 offset; scm_t_int32 offset;
@ -3145,7 +3183,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
* *
* Make a new array with TYPE, FILL, and BOUNDS, storing it in DST. * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
*/ */
VM_DEFINE_OP (102, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST) VM_DEFINE_OP (104, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST)
{ {
scm_t_uint16 dst, type, fill, bounds; scm_t_uint16 dst, type, fill, bounds;
SCM_UNPACK_RTL_12_12 (op, dst, type); SCM_UNPACK_RTL_12_12 (op, dst, type);
@ -3243,42 +3281,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \ RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
} while (0) } while (0)
VM_DEFINE_OP (103, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (105, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1); BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
VM_DEFINE_OP (104, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (106, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s8, s8, int8, 1); BV_FIXABLE_INT_REF (s8, s8, int8, 1);
VM_DEFINE_OP (105, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (107, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2); BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2);
VM_DEFINE_OP (106, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (108, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2); BV_FIXABLE_INT_REF (s16, s16_native, int16, 2);
VM_DEFINE_OP (107, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (109, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
#if SIZEOF_VOID_P > 4 #if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4); BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4);
#else #else
BV_INT_REF (u32, uint32, 4); BV_INT_REF (u32, uint32, 4);
#endif #endif
VM_DEFINE_OP (108, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (110, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
#if SIZEOF_VOID_P > 4 #if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (s32, s32_native, int32, 4); BV_FIXABLE_INT_REF (s32, s32_native, int32, 4);
#else #else
BV_INT_REF (s32, int32, 4); BV_INT_REF (s32, int32, 4);
#endif #endif
VM_DEFINE_OP (109, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (111, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (u64, uint64, 8); BV_INT_REF (u64, uint64, 8);
VM_DEFINE_OP (110, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (112, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (s64, int64, 8); BV_INT_REF (s64, int64, 8);
VM_DEFINE_OP (111, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (113, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f32, ieee_single, float, 4); BV_FLOAT_REF (f32, ieee_single, float, 4);
VM_DEFINE_OP (112, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST) VM_DEFINE_OP (114, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f64, ieee_double, double, 8); BV_FLOAT_REF (f64, ieee_double, double, 8);
/* bv-u8-set! dst:8 idx:8 src:8 /* bv-u8-set! dst:8 idx:8 src:8
@ -3382,42 +3420,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1); \ NEXT (1); \
} while (0) } while (0)
VM_DEFINE_OP (113, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (115, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1); BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1);
VM_DEFINE_OP (114, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (116, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1); BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1);
VM_DEFINE_OP (115, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (117, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2); BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2);
VM_DEFINE_OP (116, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (118, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2); BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2);
VM_DEFINE_OP (117, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (119, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
#if SIZEOF_VOID_P > 4 #if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4); BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4);
#else #else
BV_INT_SET (u32, uint32, 4); BV_INT_SET (u32, uint32, 4);
#endif #endif
VM_DEFINE_OP (118, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (120, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
#if SIZEOF_VOID_P > 4 #if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4); BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4);
#else #else
BV_INT_SET (s32, int32, 4); BV_INT_SET (s32, int32, 4);
#endif #endif
VM_DEFINE_OP (119, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (121, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (u64, uint64, 8); BV_INT_SET (u64, uint64, 8);
VM_DEFINE_OP (120, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (122, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (s64, int64, 8); BV_INT_SET (s64, int64, 8);
VM_DEFINE_OP (121, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (123, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f32, ieee_single, float, 4); BV_FLOAT_SET (f32, ieee_single, float, 4);
VM_DEFINE_OP (122, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8)) VM_DEFINE_OP (124, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f64, ieee_double, double, 8); BV_FLOAT_SET (f64, ieee_double, double, 8);
END_DISPATCH_SWITCH; END_DISPATCH_SWITCH;

29
module/language/cps/compile-rtl.scm
View file

@ -99,6 +99,15 @@
(_ (values)))) (_ (values))))
(define (emit-rtl-sequence asm exp allocation nlocals cont-table) (define (emit-rtl-sequence asm exp allocation nlocals cont-table)
(define (immediate-u8? val)
(and (integer? val) (exact? val) (<= 0 val 255)))
(define (maybe-immediate-u8 sym)
(call-with-values (lambda ()
(lookup-maybe-constant-value sym allocation))
(lambda (has-const? val)
(and has-const? (immediate-u8? val) val))))
(define (slot sym) (define (slot sym)
(lookup-slot sym allocation)) (lookup-slot sym allocation))
@ -186,14 +195,20 @@
(emit-resolve asm dst (constant bound?) (slot name))) (emit-resolve asm dst (constant bound?) (slot name)))
(($ $primcall 'free-ref (closure idx)) (($ $primcall 'free-ref (closure idx))
(emit-free-ref asm dst (slot closure) (constant idx))) (emit-free-ref asm dst (slot closure) (constant idx)))
(($ $primcall 'make-vector (length init))
(cond
((maybe-immediate-u8 length)
=> (lambda (length)
(emit-constant-make-vector asm dst length (slot init))))
(else
(emit-make-vector asm dst (slot length) (slot init)))))
(($ $primcall 'vector-ref (vector index)) (($ $primcall 'vector-ref (vector index))
(call-with-values (lambda () (cond
(lookup-maybe-constant-value index allocation)) ((maybe-immediate-u8 index)
(lambda (has-const? index-val) => (lambda (index)
(if (and has-const? (integer? index-val) (exact? index-val) (emit-constant-vector-ref asm dst (slot vector) index)))
(<= 0 index-val 255)) (else
(emit-constant-vector-ref asm dst (slot vector) index-val) (emit-vector-ref asm dst (slot vector) (slot index)))))
(emit-vector-ref asm dst (slot vector) (slot index))))))
(($ $primcall name args) (($ $primcall name args)
;; FIXME: Inline all the cases. ;; FIXME: Inline all the cases.
(let ((inst (prim-rtl-instruction name))) (let ((inst (prim-rtl-instruction name)))

11
module/language/cps/dfg.scm
View file

@ -775,6 +775,9 @@
(values #f #f)))) (values #f #f))))
(define (constant-needs-allocation? sym val dfg) (define (constant-needs-allocation? sym val dfg)
(define (immediate-u8? val)
(and (integer? val) (exact? val) (<= 0 val 255)))
(define (find-exp term) (define (find-exp term)
(match term (match term
(($ $kargs names syms body) (find-exp body)) (($ $kargs names syms body) (find-exp body))
@ -801,12 +804,12 @@
#f) #f)
(($ $primcall 'resolve (name bound?)) (($ $primcall 'resolve (name bound?))
(eq? sym name)) (eq? sym name))
(($ $primcall 'make-vector (len init))
(not (and (eq? sym len) (immediate-u8? val))))
(($ $primcall 'vector-ref (v i)) (($ $primcall 'vector-ref (v i))
(not (and (eq? sym i) (not (and (eq? sym i) (immediate-u8? val))))
(integer? val) (exact? val) (<= 0 val 255))))
(($ $primcall 'vector-set! (v i x)) (($ $primcall 'vector-set! (v i x))
(not (and (eq? sym i) (not (and (eq? sym i) (immediate-u8? val))))
(integer? val) (exact? val) (<= 0 val 255))))
(_ #t))) (_ #t)))
uses)))))) uses))))))

4
module/language/tree-il/primitives.scm
View file

@ -73,7 +73,7 @@
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
vector-length vector-ref vector-set! make-vector vector-length vector-ref vector-set!
variable? variable-ref variable-set! variable? variable-ref variable-set!
variable-bound? variable-bound?
@ -129,7 +129,7 @@
(define *primitive-constructors* (define *primitive-constructors*
;; Primitives that return a fresh object. ;; Primitives that return a fresh object.
'(acons cons cons* list vector make-struct make-struct/no-tail '(acons cons cons* list vector make-vector make-struct make-struct/no-tail
make-prompt-tag)) make-prompt-tag))
(define *primitive-accessors* (define *primitive-accessors*