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

Add specialize-primcalls pass; bump objcode version.

Browse source 
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump.

* libguile/objcodes.c (process_dynamic_segment): Expect the minor
  version to be present and, while we are still banging on the VM,
  exactly equal to SCM_OBJCODE_MINOR_VERSION.

* libguile/vm-engine.c: Renumber ops.  Remove the general make-vector.
  Rename constant-FOO to FOO/immediate.  Remove struct-ref and
  struct-set!, replace with struct-ref/immediate and
  struct-set!/immediate.

* module/Makefile.am:
* module/language/cps/specialize-primcalls.scm: New pass, inlines FOO to
  FOO/immediate -- e.g. vector-ref to vector-ref/immediate.

* module/language/cps/arities.scm: Remove struct-set! case, now that
  there is no struct-set! opcode.

* module/language/cps/compile-rtl.scm (compile-fun): Remove dispatch to
  constant-FOO versus FOO here -- that decision is made by
  specialize-primcalls.
  (optimize): Add specialize-primcalls pass.

* module/language/cps/dfg.scm (constant-needs-allocation?): Adapt to
  name changes.

* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
  (*primitive-constructors*): Add allocate-struct.

* module/system/vm/assembler.scm (*bytecode-major-version*):
  (*bytecode-minor-version*, link-dynamic-section): Write minor version
  into resulting image.
This commit is contained in:
Andy Wingo 2013-11-10 19:27:19 +01:00
parent 863dd87362
commit 4c906ad5a5
10 changed files with 220 additions and 172 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/_scm.h
View file

@ -270,7 +270,7 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int);
/* Major and minor versions must be single characters. */ /* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 3 #define SCM_OBJCODE_MAJOR_VERSION 3
#define SCM_OBJCODE_MINOR_VERSION 1 #define SCM_OBJCODE_MINOR_VERSION 2
#define SCM_OBJCODE_MAJOR_VERSION_STRING \ #define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \ #define SCM_OBJCODE_MINOR_VERSION_STRING \

7
libguile/objcodes.c
View file

@ -290,7 +290,12 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
{ {
case 0x0202: case 0x0202:
bytecode_kind = BYTECODE_KIND_GUILE_2_2; 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"; return "incompatible bytecode version";
break; break;
default: default:

155
libguile/vm-engine.c
View file

@ -2500,29 +2500,13 @@ 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-vector/immediate 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 a short vector of known size and write it to DST. The vector * 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 * will have space for LENGTH slots, an immediate value. They will be
* filled with the value in slot INIT. * 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_uint8 dst, init;
scm_t_int32 length, n; 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. * 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); ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (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 * Fetch the item at position IDX in the vector in SRC, and store it
* in DST. * 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; scm_t_signed_bits i = 0;
ARGS2 (vect, idx); 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 * 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 (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_t_uint8 dst, src, idx;
SCM v; 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. * 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_t_uint8 dst, idx_var, src;
SCM vect, idx, val; SCM vect, idx, val;
@ -2623,12 +2607,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1); 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 * Store SRC into the vector DST at index IDX. Here IDX is an
* immediate value. * 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_t_uint8 dst, idx, src;
SCM vect, val; 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. * 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); ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable"); VM_VALIDATE_STRUCT (obj, "struct_vtable");
RETURN (SCM_STRUCT_VTABLE (obj)); 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 * Allocate a new struct with VTABLE, and place it in DST. The struct
* 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 (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_t_uint8 dst, vtable, nfields;
SCM ret; SCM ret;
@ -2686,53 +2670,44 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1); 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 * 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) if (SCM_LIKELY (SCM_STRUCTP (obj)
&& SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
SCM_VTABLE_FLAG_SIMPLE) SCM_VTABLE_FLAG_SIMPLE)
&& SCM_I_INUMP (pos))) && idx < SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj),
{ scm_vtable_index_size)))
SCM vtable; RETURN (SCM_STRUCT_SLOT_REF (obj, idx));
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]));
}
}
SYNC_IP (); 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_t_uint8 dst, idx, src;
SCM obj, pos, val; SCM obj, val;
SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
obj = LOCAL_REF (dst); obj = LOCAL_REF (dst);
pos = LOCAL_REF (idx);
val = LOCAL_REF (src); val = LOCAL_REF (src);
if (SCM_LIKELY (SCM_STRUCTP (obj) if (SCM_LIKELY (SCM_STRUCTP (obj)
@ -2740,25 +2715,15 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
SCM_VTABLE_FLAG_SIMPLE) SCM_VTABLE_FLAG_SIMPLE)
&& SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
SCM_VTABLE_FLAG_SIMPLE_RW) 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_STRUCT_SLOT_SET (obj, idx, val);
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); NEXT (1);
} }
}
SYNC_IP (); SYNC_IP ();
scm_struct_set_x (obj, pos, val); scm_struct_set_x (obj, SCM_I_MAKINUM (idx), val);
NEXT (1); 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. * 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); ARGS1 (obj);
if (SCM_INSTANCEP (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 * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
* index into the stack. * 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_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);
@ -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!, * 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 (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_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);
@ -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 * from the instruction pointer, and store into DST. LEN is a byte
* length. OFFSET is signed. * 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_uint8 dst, type, shape;
scm_t_int32 offset; 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. * 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_t_uint16 dst, type, fill, bounds;
SCM_UNPACK_RTL_12_12 (op, dst, type); 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)); \ RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
} while (0) } 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); 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); 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); 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); 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 #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 (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 #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 (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); 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); 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); 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_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
@ -3073,42 +3038,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
NEXT (1); \ NEXT (1); \
} while (0) } 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); 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); 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); 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); 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 #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 (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 #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 (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); 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); 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); 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); BV_FLOAT_SET (f64, ieee_double, double, 8);
END_DISPATCH_SWITCH; END_DISPATCH_SWITCH;

1
module/Makefile.am
View file

@ -124,6 +124,7 @@ CPS_LANG_SOURCES = \
language/cps/reify-primitives.scm \ language/cps/reify-primitives.scm \
language/cps/slot-allocation.scm \ language/cps/slot-allocation.scm \
language/cps/spec.scm \ language/cps/spec.scm \
language/cps/specialize-primcalls.scm \
language/cps/verify.scm language/cps/verify.scm
RTL_LANG_SOURCES = \ RTL_LANG_SOURCES = \

30
module/language/cps/arities.scm
View file

@ -134,36 +134,6 @@
(and (not (prim-rtl-instruction name)) (and (not (prim-rtl-instruction name))
(not (branching-primitive? name)))))) (not (branching-primitive? name))))))
($continue k src ,exp)) ($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) (($ $primcall name args)
,(match (prim-arity name) ,(match (prim-arity name)
((out . in) ((out . in)

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

@ -36,6 +36,7 @@
#:use-module (language cps primitives) #:use-module (language cps primitives)
#:use-module (language cps reify-primitives) #:use-module (language cps reify-primitives)
#:use-module (language cps slot-allocation) #:use-module (language cps slot-allocation)
#:use-module (language cps specialize-primcalls)
#:use-module (system vm assembler) #:use-module (system vm assembler)
#:export (compile-rtl)) #:export (compile-rtl))
@ -55,6 +56,7 @@
;; Calls to source-to-source optimization passes go here. ;; Calls to source-to-source optimization passes go here.
(let* ((exp (run-pass exp contify #:contify? #t)) (let* ((exp (run-pass exp contify #:contify? #t))
(exp (run-pass exp inline-constructors #:inline-constructors? #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))) (exp (run-pass exp elide-values #:elide-values? #t)))
;; Passes that are needed: ;; Passes that are needed:
;; ;;
@ -96,15 +98,6 @@
(define (lookup-cont k) (define (lookup-cont k)
(vector-ref contv (cfa-k-idx cfa 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) (define (slot sym)
(lookup-slot sym allocation)) (lookup-slot sym allocation))
@ -275,20 +268,16 @@
(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))
(cond (emit-vector-ref asm dst (slot vector) (slot index)))
((maybe-immediate-u8 index) (($ $primcall 'make-vector/immediate (length init))
=> (lambda (index) (emit-make-vector/immediate asm dst (constant length) (slot init)))
(emit-constant-vector-ref asm dst (slot vector) index))) (($ $primcall 'vector-ref/immediate (vector index))
(else (emit-vector-ref/immediate asm dst (slot vector) (constant index)))
(emit-vector-ref asm dst (slot vector) (slot 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)) (($ $primcall 'builtin-ref (name))
(emit-builtin-ref asm dst (constant name))) (emit-builtin-ref asm dst (constant name)))
(($ $primcall 'bv-u8-ref (bv idx)) (($ $primcall 'bv-u8-ref (bv idx))
@ -340,18 +329,13 @@
(emit-free-set! asm (slot closure) (slot value) (constant idx))) (emit-free-set! asm (slot closure) (slot value) (constant idx)))
(($ $primcall 'box-set! (box value)) (($ $primcall 'box-set! (box value))
(emit-box-set! asm (slot box) (slot value))) (emit-box-set! asm (slot box) (slot value)))
(($ $primcall 'struct-set! (struct index value)) (($ $primcall 'struct-set!/immediate (struct index value))
(emit-struct-set! asm (slot struct) (slot index) (slot value))) (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value)))
(($ $primcall 'vector-set! (vector index value)) (($ $primcall 'vector-set! (vector index value))
(call-with-values (lambda () (emit-vector-set! asm (slot vector) (slot index) (slot value)))
(lookup-maybe-constant-value index allocation)) (($ $primcall 'vector-set!/immediate (vector index value))
(lambda (has-const? index-val) (emit-vector-set!/immediate asm (slot vector) (constant index)
(if (and has-const? (integer? index-val) (exact? index-val) (slot value)))
(<= 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))))))
(($ $primcall 'variable-set! (var val)) (($ $primcall 'variable-set! (var val))
(emit-box-set! asm (slot var) (slot val))) (emit-box-set! asm (slot var) (slot val)))
(($ $primcall 'set-car! (pair value)) (($ $primcall 'set-car! (pair value))

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

@ -862,12 +862,18 @@
#f) #f)
(($ $primcall 'resolve (name bound?)) (($ $primcall 'resolve (name bound?))
(eq? sym name)) (eq? sym name))
(($ $primcall 'make-vector (len init)) (($ $primcall 'make-vector/immediate (len init))
(not (and (eq? sym len) (immediate-u8? val)))) (not (eq? sym len)))
(($ $primcall 'vector-ref (v i)) (($ $primcall 'vector-ref/immediate (v i))
(not (and (eq? sym i) (immediate-u8? val)))) (not (eq? sym i)))
(($ $primcall 'vector-set! (v i x)) (($ $primcall 'vector-set!/immediate (v i x))
(not (and (eq? sym i) (immediate-u8? val)))) (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)) (($ $primcall 'builtin-ref (idx))
#f) #f)
(_ #t))) (_ #t)))

111
module/language/cps/specialize-primcalls.scm Normal file
View file

@ -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)))

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

@ -91,7 +91,7 @@
string-length string-ref string-set! 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-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set! bytevector-s8-ref bytevector-s8-set!
@ -133,7 +133,8 @@
(define *primitive-constructors* (define *primitive-constructors*
;; Primitives that return a fresh object. ;; 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)) make-prompt-tag))
(define *primitive-accessors* (define *primitive-accessors*

7
module/system/vm/assembler.scm
View file

@ -1200,6 +1200,10 @@ needed."
;;; the symbol table, etc. ;;; 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) (define (link-dynamic-section asm text rw rw-init)
"Link the dynamic section for an ELF image with RTL text, given the "Link the dynamic section for an ELF image with RTL text, given the
writable data section @var{rw} needing fixup from the procedure with 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)) relocs))
(%set-uword! bv (* i word-size) 0 endianness)))) (%set-uword! bv (* i word-size) 0 endianness))))
(set-uword! 0 DT_GUILE_RTL_VERSION) (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-uword! 2 DT_GUILE_ENTRY)
(set-label! 3 '.rtl-text) (set-label! 3 '.rtl-text)
(cond (cond