[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-386-g4c906ad
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-386-g4c906ad |
|
Date: |
Sun, 10 Nov 2013 18:27:40 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=4c906ad5a5e0404e8b488b525f6b62f405b4d560
The branch, master has been updated
via 4c906ad5a5e0404e8b488b525f6b62f405b4d560 (commit)
from 863dd873628a971176556a1da1bf2ab3f0ff5e55 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 4c906ad5a5e0404e8b488b525f6b62f405b4d560
Author: Andy Wingo <address@hidden>
Date: Sun Nov 10 19:27:19 2013 +0100
Add specialize-primcalls pass; bump objcode version.
* 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.
-----------------------------------------------------------------------
Summary of changes:
libguile/_scm.h | 2 +-
libguile/objcodes.c | 7 +-
libguile/vm-engine.c | 161 ++++++++++----------------
module/Makefile.am | 1 +
module/language/cps/arities.scm | 30 -----
module/language/cps/compile-rtl.scm | 50 +++------
module/language/cps/dfg.scm | 18 ++-
module/language/cps/specialize-primcalls.scm | 111 ++++++++++++++++++
module/language/tree-il/primitives.scm | 5 +-
module/system/vm/assembler.scm | 7 +-
10 files changed, 220 insertions(+), 172 deletions(-)
create mode 100644 module/language/cps/specialize-primcalls.scm
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 7afb5a1..9175eb7 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 358a1e7..0515a7c 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 d657a08..7e66f43 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 32baacb..3074fd9 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 430d697..387187c 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 a3bef46..e45773f 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 4d38d52..365f455 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 0000000..8e2f38f
--- /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 0904573..84c07a0 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 b2db73e..3ba25b3 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
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-386-g4c906ad,
Andy Wingo <=