diff options
-rw-r--r-- | libguile/_scm.h | 2 | ||||
-rw-r--r-- | libguile/objcodes.c | 7 | ||||
-rw-r--r-- | libguile/vm-engine.c | 161 | ||||
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/language/cps/arities.scm | 30 | ||||
-rw-r--r-- | module/language/cps/compile-rtl.scm | 50 | ||||
-rw-r--r-- | module/language/cps/dfg.scm | 18 | ||||
-rw-r--r-- | module/language/cps/specialize-primcalls.scm | 111 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 5 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 7 |
10 files changed, 220 insertions, 172 deletions
diff --git a/libguile/_scm.h b/libguile/_scm.h index 7afb5a11f..9175eb724 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -270,7 +270,7 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int); /* Major and minor versions must be single characters. */ #define SCM_OBJCODE_MAJOR_VERSION 3 -#define SCM_OBJCODE_MINOR_VERSION 1 +#define SCM_OBJCODE_MINOR_VERSION 2 #define SCM_OBJCODE_MAJOR_VERSION_STRING \ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) #define SCM_OBJCODE_MINOR_VERSION_STRING \ diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 358a1e77a..0515a7cb5 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -290,7 +290,12 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr, { case 0x0202: bytecode_kind = BYTECODE_KIND_GUILE_2_2; - if (minor) + /* As we get closer to 2.2, we will allow for backwards + compatibility and we can change this test to ">" + instead of "!=". However until then, to deal with VM + churn it's best to keep these things in + lock-step. */ + if (minor != SCM_OBJCODE_MINOR_VERSION) return "incompatible bytecode version"; break; default: diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index d657a08bd..7e66f4387 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2500,29 +2500,13 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) 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 (92, 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-vector/immediate 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 (93, constant_make_vector, "constant-make-vector", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (92, make_vector_immediate, "make-vector/immediate", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, init; scm_t_int32 length, n; @@ -2542,7 +2526,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Store the length of the vector in SRC in DST. */ - VM_DEFINE_OP (94, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (93, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (vect); if (SCM_LIKELY (SCM_I_IS_VECTOR (vect))) @@ -2559,7 +2543,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 * in DST. */ - VM_DEFINE_OP (95, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (94, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_signed_bits i = 0; ARGS2 (vect, idx); @@ -2575,12 +2559,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) } } - /* constant-vector-ref dst:8 src:8 idx:8 + /* vector-ref/immediate dst:8 src:8 idx:8 * * Fill DST with the item IDX elements into the vector at SRC. Useful * for building data types using vectors. */ - VM_DEFINE_OP (96, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (95, vector_ref_immediate, "vector-ref/immediate", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, src, idx; SCM v; @@ -2599,7 +2583,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Store SRC into the vector DST at index IDX. */ - VM_DEFINE_OP (97, vector_set, "vector-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (96, vector_set, "vector-set!", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx_var, src; SCM vect, idx, val; @@ -2623,12 +2607,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); } - /* constant-vector-set! dst:8 idx:8 src:8 + /* vector-set!/immediate dst:8 idx:8 src:8 * * Store SRC into the vector DST at index IDX. Here IDX is an * immediate value. */ - VM_DEFINE_OP (98, constant_vector_set, "constant-vector-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (97, vector_set_immediate, "vector-set!/immediate", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx, src; SCM vect, val; @@ -2659,20 +2643,20 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Store the vtable of SRC into DST. */ - VM_DEFINE_OP (99, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (98, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (obj); VM_VALIDATE_STRUCT (obj, "struct_vtable"); RETURN (SCM_STRUCT_VTABLE (obj)); } - /* allocate-struct dst:8 vtable:8 nfields:8 + /* allocate-struct/immediate dst:8 vtable:8 nfields:8 * * Allocate a new struct with VTABLE, and place it in DST. The struct * will be constructed with space for NFIELDS fields, which should * correspond to the field count of the VTABLE. */ - VM_DEFINE_OP (100, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (99, allocate_struct_immediate, "allocate-struct/immediate", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, vtable, nfields; SCM ret; @@ -2686,79 +2670,60 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); } - /* struct-ref dst:8 src:8 idx:8 + /* struct-ref/immediate dst:8 src:8 idx:8 * * Fetch the item at slot IDX in the struct in SRC, and store it - * in DST. + * in DST. IDX is an immediate unsigned 8-bit value. */ - VM_DEFINE_OP (101, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (100, struct_ref_immediate, "struct-ref/immediate", OP1 (U8_U8_U8_U8) | OP_DST) { - ARGS2 (obj, pos); + scm_t_uint8 dst, src, idx; + SCM obj; + + SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx); + + obj = LOCAL_REF (src); if (SCM_LIKELY (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, SCM_VTABLE_FLAG_SIMPLE) - && SCM_I_INUMP (pos))) - { - SCM vtable; - scm_t_bits index, len; - - /* True, an inum is a signed value, but cast to unsigned it will - certainly be more than the length, so we will fall through if - index is negative. */ - index = SCM_I_INUM (pos); - vtable = SCM_STRUCT_VTABLE (obj); - len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); - - if (SCM_LIKELY (index < len)) - { - scm_t_bits *data = SCM_STRUCT_DATA (obj); - RETURN (SCM_PACK (data[index])); - } - } + && idx < SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj), + scm_vtable_index_size))) + RETURN (SCM_STRUCT_SLOT_REF (obj, idx)); SYNC_IP (); - RETURN (scm_struct_ref (obj, pos)); + RETURN (scm_struct_ref (obj, SCM_I_MAKINUM (idx))); } - /* struct-set! dst:8 idx:8 src:8 + /* struct-set!/immediate dst:8 idx:8 src:8 * - * Store SRC into the struct DST at slot IDX. + * Store SRC into the struct DST at slot IDX. IDX is an immediate + * unsigned 8-bit value. */ - VM_DEFINE_OP (102, struct_set, "struct-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (101, struct_set_immediate, "struct-set!/immediate", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx, src; - SCM obj, pos, val; - + SCM obj, val; + SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); + obj = LOCAL_REF (dst); - pos = LOCAL_REF (idx); val = LOCAL_REF (src); - + 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 (pos))) + && idx < SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj), + scm_vtable_index_size))) { - SCM vtable; - scm_t_bits index, len; - - /* See above regarding index being >= 0. */ - index = SCM_I_INUM (pos); - vtable = SCM_STRUCT_VTABLE (obj); - len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); - if (SCM_LIKELY (index < len)) - { - scm_t_bits *data = SCM_STRUCT_DATA (obj); - data[index] = SCM_UNPACK (val); - NEXT (1); - } + SCM_STRUCT_SLOT_SET (obj, idx, val); + NEXT (1); } SYNC_IP (); - scm_struct_set_x (obj, pos, val); + scm_struct_set_x (obj, SCM_I_MAKINUM (idx), val); NEXT (1); } @@ -2766,7 +2731,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Store the vtable of SRC into DST. */ - VM_DEFINE_OP (103, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (102, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (obj); if (SCM_INSTANCEP (obj)) @@ -2781,7 +2746,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 * index into the stack. */ - VM_DEFINE_OP (104, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (103, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, src, idx; SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx); @@ -2795,7 +2760,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!, * IDX is an 8-bit immediate value, not an index into the stack. */ - VM_DEFINE_OP (105, slot_set, "slot-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (104, slot_set, "slot-set!", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx, src; SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); @@ -2816,7 +2781,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 * length. OFFSET is signed. */ - VM_DEFINE_OP (106, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST) + VM_DEFINE_OP (105, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST) { scm_t_uint8 dst, type, shape; scm_t_int32 offset; @@ -2836,7 +2801,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. */ - VM_DEFINE_OP (107, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST) + VM_DEFINE_OP (106, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST) { scm_t_uint16 dst, type, fill, bounds; SCM_UNPACK_RTL_12_12 (op, dst, type); @@ -2934,42 +2899,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \ } while (0) - VM_DEFINE_OP (108, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (107, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FIXABLE_INT_REF (u8, u8, uint8, 1); - VM_DEFINE_OP (109, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (108, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FIXABLE_INT_REF (s8, s8, int8, 1); - VM_DEFINE_OP (110, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (109, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2); - VM_DEFINE_OP (111, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (110, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FIXABLE_INT_REF (s16, s16_native, int16, 2); - VM_DEFINE_OP (112, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (111, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4); #else BV_INT_REF (u32, uint32, 4); #endif - VM_DEFINE_OP (113, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (112, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_REF (s32, s32_native, int32, 4); #else BV_INT_REF (s32, int32, 4); #endif - VM_DEFINE_OP (114, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (113, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_INT_REF (u64, uint64, 8); - VM_DEFINE_OP (115, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (114, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_INT_REF (s64, int64, 8); - VM_DEFINE_OP (116, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (115, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FLOAT_REF (f32, ieee_single, float, 4); - VM_DEFINE_OP (117, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (116, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FLOAT_REF (f64, ieee_double, double, 8); /* bv-u8-set! dst:8 idx:8 src:8 @@ -3073,42 +3038,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); \ } while (0) - VM_DEFINE_OP (118, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (117, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8)) BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1); - VM_DEFINE_OP (119, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (118, 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); - VM_DEFINE_OP (120, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (119, 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); - VM_DEFINE_OP (121, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (120, 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); - VM_DEFINE_OP (122, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (121, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8)) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4); #else BV_INT_SET (u32, uint32, 4); #endif - VM_DEFINE_OP (123, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (122, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8)) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4); #else BV_INT_SET (s32, int32, 4); #endif - VM_DEFINE_OP (124, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (123, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8)) BV_INT_SET (u64, uint64, 8); - VM_DEFINE_OP (125, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (124, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8)) BV_INT_SET (s64, int64, 8); - VM_DEFINE_OP (126, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (125, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8)) BV_FLOAT_SET (f32, ieee_single, float, 4); - VM_DEFINE_OP (127, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (126, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8)) BV_FLOAT_SET (f64, ieee_double, double, 8); END_DISPATCH_SWITCH; diff --git a/module/Makefile.am b/module/Makefile.am index 32baacb5d..3074fd9e2 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -124,6 +124,7 @@ CPS_LANG_SOURCES = \ language/cps/reify-primitives.scm \ language/cps/slot-allocation.scm \ language/cps/spec.scm \ + language/cps/specialize-primcalls.scm \ language/cps/verify.scm RTL_LANG_SOURCES = \ diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm index 430d69720..387187ccf 100644 --- a/module/language/cps/arities.scm +++ b/module/language/cps/arities.scm @@ -134,36 +134,6 @@ (and (not (prim-rtl-instruction name)) (not (branching-primitive? name)))))) ($continue k src ,exp)) - (($ $primcall 'struct-set! (obj pos val)) - ;; Unhappily, and undocumentedly, struct-set! returns the value - ;; that was set. There is code that relies on this. Hackety - ;; hack... - ,(rewrite-cps-term (lookup-cont k conts) - (($ $ktail) - ,(let-gensyms (kvoid) - (build-cps-term - ($letk* ((kvoid ($kargs () () - ($continue ktail src - ($primcall 'return (val)))))) - ($continue kvoid src ,exp))))) - (($ $ktrunc arity kargs) - ,(rewrite-cps-term arity - (($ $arity () () #f () #f) - ($continue kargs src ,exp)) - (_ - ,(let-gensyms (kvoid) - (build-cps-term - ($letk* ((kvoid ($kargs () () - ($continue k src - ($primcall 'values (val)))))) - ($continue kvoid src ,exp))))))) - (($ $kargs () () _) - ($continue k src ,exp)) - (_ - ,(let-gensyms (k*) - (build-cps-term - ($letk ((k* ($kargs () () ($continue k src ($var val))))) - ($continue k* src ,exp))))))) (($ $primcall name args) ,(match (prim-arity name) ((out . in) diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm index a3bef4689..e45773f48 100644 --- a/module/language/cps/compile-rtl.scm +++ b/module/language/cps/compile-rtl.scm @@ -36,6 +36,7 @@ #:use-module (language cps primitives) #:use-module (language cps reify-primitives) #:use-module (language cps slot-allocation) + #:use-module (language cps specialize-primcalls) #:use-module (system vm assembler) #:export (compile-rtl)) @@ -55,6 +56,7 @@ ;; Calls to source-to-source optimization passes go here. (let* ((exp (run-pass exp contify #:contify? #t)) (exp (run-pass exp inline-constructors #:inline-constructors? #t)) + (exp (run-pass exp specialize-primcalls #:specialize-primcalls? #t)) (exp (run-pass exp elide-values #:elide-values? #t))) ;; Passes that are needed: ;; @@ -96,15 +98,6 @@ (define (lookup-cont k) (vector-ref contv (cfa-k-idx cfa k))) - (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) (lookup-slot sym allocation)) @@ -275,20 +268,16 @@ (emit-resolve asm dst (constant bound?) (slot name))) (($ $primcall 'free-ref (closure 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)) - (cond - ((maybe-immediate-u8 index) - => (lambda (index) - (emit-constant-vector-ref asm dst (slot vector) index))) - (else - (emit-vector-ref asm dst (slot vector) (slot index))))) + (emit-vector-ref asm dst (slot vector) (slot index))) + (($ $primcall 'make-vector/immediate (length init)) + (emit-make-vector/immediate asm dst (constant length) (slot init))) + (($ $primcall 'vector-ref/immediate (vector index)) + (emit-vector-ref/immediate asm dst (slot vector) (constant index))) + (($ $primcall 'allocate-struct/immediate (vtable nfields)) + (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields))) + (($ $primcall 'struct-ref/immediate (struct n)) + (emit-struct-ref/immediate asm dst (slot struct) (constant n))) (($ $primcall 'builtin-ref (name)) (emit-builtin-ref asm dst (constant name))) (($ $primcall 'bv-u8-ref (bv idx)) @@ -340,18 +329,13 @@ (emit-free-set! asm (slot closure) (slot value) (constant idx))) (($ $primcall 'box-set! (box value)) (emit-box-set! asm (slot box) (slot value))) - (($ $primcall 'struct-set! (struct index value)) - (emit-struct-set! asm (slot struct) (slot index) (slot value))) + (($ $primcall 'struct-set!/immediate (struct index value)) + (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value))) (($ $primcall 'vector-set! (vector index value)) - (call-with-values (lambda () - (lookup-maybe-constant-value index allocation)) - (lambda (has-const? index-val) - (if (and has-const? (integer? index-val) (exact? index-val) - (<= 0 index-val 255)) - (emit-constant-vector-set! asm (slot vector) index-val - (slot value)) - (emit-vector-set! asm (slot vector) (slot index) - (slot value)))))) + (emit-vector-set! asm (slot vector) (slot index) (slot value))) + (($ $primcall 'vector-set!/immediate (vector index value)) + (emit-vector-set!/immediate asm (slot vector) (constant index) + (slot value))) (($ $primcall 'variable-set! (var val)) (emit-box-set! asm (slot var) (slot val))) (($ $primcall 'set-car! (pair value)) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm index 4d38d5200..365f45525 100644 --- a/module/language/cps/dfg.scm +++ b/module/language/cps/dfg.scm @@ -862,12 +862,18 @@ #f) (($ $primcall 'resolve (name bound?)) (eq? sym name)) - (($ $primcall 'make-vector (len init)) - (not (and (eq? sym len) (immediate-u8? val)))) - (($ $primcall 'vector-ref (v i)) - (not (and (eq? sym i) (immediate-u8? val)))) - (($ $primcall 'vector-set! (v i x)) - (not (and (eq? sym i) (immediate-u8? val)))) + (($ $primcall 'make-vector/immediate (len init)) + (not (eq? sym len))) + (($ $primcall 'vector-ref/immediate (v i)) + (not (eq? sym i))) + (($ $primcall 'vector-set!/immediate (v i x)) + (not (eq? sym i))) + (($ $primcall 'allocate-struct/immediate (vtable nfields)) + (not (eq? sym nfields))) + (($ $primcall 'struct-ref/immediate (s n)) + (not (eq? sym n))) + (($ $primcall 'struct-set!/immediate (s n x)) + (not (eq? sym n))) (($ $primcall 'builtin-ref (idx)) #f) (_ #t))) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm new file mode 100644 index 000000000..8e2f38fd0 --- /dev/null +++ b/module/language/cps/specialize-primcalls.scm @@ -0,0 +1,111 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Some RTL operations can encode an immediate as an operand. This +;;; pass tranforms generic primcalls to these specialized primcalls, if +;;; possible. +;;; +;;; Code: + +(define-module (language cps specialize-primcalls) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps dfg) + #:export (specialize-primcalls)) + +(define (specialize-primcalls fun) + (let ((dfg (compute-dfg fun #:global? #t))) + (define (immediate-u8? sym) + (call-with-values (lambda () (find-constant-value sym dfg)) + (lambda (has-const? val) + (and has-const? (integer? val) (exact? val) (<= 0 val 255))))) + (define (visit-cont cont) + (rewrite-cps-cont cont + (($ $cont sym ($ $kargs names syms body)) + (sym ($kargs names syms ,(visit-term body)))) + (($ $cont sym ($ $kentry self tail clauses)) + (sym ($kentry self ,tail ,(map visit-cont clauses)))) + (($ $cont sym ($ $kclause arity body)) + (sym ($kclause ,arity ,(visit-cont body)))) + (($ $cont) + ,cont))) + (define (visit-term term) + (rewrite-cps-term term + (($ $letk conts body) + ($letk ,(map visit-cont conts) + ,(visit-term body))) + (($ $letrec names syms funs body) + ($letrec names syms (map visit-fun funs) + ,(visit-term body))) + (($ $continue k src (and fun ($ $fun))) + ($continue k src ,(visit-fun fun))) + (($ $continue k src ($ $primcall name args)) + ,(visit-primcall k src name args)) + (($ $continue) + ,term))) + (define (visit-primcall k src name args) + ;; If we introduce an RTL op from a primcall without an RTL op, we + ;; will need to ensure that the return arity matches. Rely on the + ;; elide-values pass to clean up. + (define-syntax-rule (adapt-void exp) + (let-gensyms (k* val kvoid) + (build-cps-term + ($letk ((k* ($kargs ('val) (val) + ($continue k src ($primcall 'values (val))))) + (kvoid ($kargs () () + ($continue k* src ($void))))) + ($continue kvoid src exp))))) + (define-syntax-rule (adapt-val exp) + (let-gensyms (k* val) + (build-cps-term + ($letk ((k* ($kargs ('val) (val) + ($continue k src ($primcall 'values (val)))))) + ($continue k* src exp))))) + (match (cons name args) + (('make-vector (? immediate-u8? n) init) + (adapt-val ($primcall 'make-vector/immediate (n init)))) + (('vector-ref v (? immediate-u8? n)) + (build-cps-term + ($continue k src ($primcall 'vector-ref/immediate (v n))))) + (('vector-set! v (? immediate-u8? n) x) + (build-cps-term + ($continue k src ($primcall 'vector-set!/immediate (v n x))))) + (('allocate-struct v (? immediate-u8? n)) + (adapt-val ($primcall 'allocate-struct/immediate (v n)))) + (('struct-ref s (? immediate-u8? n)) + (adapt-val ($primcall 'struct-ref/immediate (s n)))) + (('struct-set! s (? immediate-u8? n) x) + ;; Unhappily, and undocumentedly, struct-set! returns the value + ;; that was set. There is code that relies on this. Hackety + ;; hack... + (let-gensyms (k*) + (build-cps-term + ($letk ((k* ($kargs () () + ($continue k src ($primcall 'values (x)))))) + ($continue k* src ($primcall 'struct-set!/immediate (s n x))))))) + (_ + (build-cps-term ($continue k src ($primcall name args)))))) + + (define (visit-fun fun) + (rewrite-cps-exp fun + (($ $fun src meta free body) + ($fun src meta free ,(visit-cont body))))) + + (visit-fun fun))) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 09045735b..84c07a0ea 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -91,7 +91,7 @@ string-length string-ref string-set! - struct-vtable make-struct struct-ref struct-set! + allocate-struct struct-vtable make-struct struct-ref struct-set! bytevector-u8-ref bytevector-u8-set! bytevector-s8-ref bytevector-s8-set! @@ -133,7 +133,8 @@ (define *primitive-constructors* ;; Primitives that return a fresh object. - '(acons cons cons* list vector make-vector make-struct make-struct/no-tail + '(acons cons cons* list vector make-vector + allocate-struct make-struct make-struct/no-tail make-prompt-tag)) (define *primitive-accessors* diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index b2db73ec3..3ba25b39f 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1200,6 +1200,10 @@ needed." ;;; the symbol table, etc. ;;; +;; FIXME: Define these somewhere central, shared with C. +(define *bytecode-major-version* #x0202) +(define *bytecode-minor-version* 2) + (define (link-dynamic-section asm text rw rw-init) "Link the dynamic section for an ELF image with RTL text, given the writable data section @var{rw} needing fixup from the procedure with @@ -1219,7 +1223,8 @@ it will be added to the GC roots at runtime." relocs)) (%set-uword! bv (* i word-size) 0 endianness)))) (set-uword! 0 DT_GUILE_RTL_VERSION) - (set-uword! 1 #x02020000) + (set-uword! 1 (logior (ash *bytecode-major-version* 16) + *bytecode-minor-version*)) (set-uword! 2 DT_GUILE_ENTRY) (set-label! 3 '.rtl-text) (cond |