[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-958-gd38ca16
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-958-gd38ca16 |
|
Date: |
Mon, 21 Apr 2014 21:08:48 +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=d38ca16e2cd444418b284dc15fc4be8402004acc
The branch, master has been updated
via d38ca16e2cd444418b284dc15fc4be8402004acc (commit)
via d4b3a36d4202d7e891a3642b9de12a8800f57b38 (commit)
via 28e12ea0c401ea2c1aad203d7b45b2209d5e9be2 (commit)
via dece041203724bcf4bf74dbec459f5dbae4aa7ed (commit)
via c09708f985a7b39c1f07890e75ec2ec18c3565b6 (commit)
from d6651f690315df2ad14c2c043ffb6c949c28884e (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 d38ca16e2cd444418b284dc15fc4be8402004acc
Author: Andy Wingo <address@hidden>
Date: Mon Apr 21 21:48:39 2014 +0200
Add make-vector opcode
* libguile/vm-engine.c (make-vector): New opcode.
* module/language/cps/compile-bytecode.scm (compile-fun):
* module/system/vm/assembler.scm (system): Support the new opcode.
(*bytecode-minor-version*): Bump.
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump.
* test-suite/tests/compiler.test ("limits"): Add vector test.
commit d4b3a36d4202d7e891a3642b9de12a8800f57b38
Author: Andy Wingo <address@hidden>
Date: Mon Apr 21 19:28:06 2014 +0200
Operations on 8-bit and 12-bit operands shuffle args into range
* module/language/cps/slot-allocation.scm (allocate-slots): Avoid
allocating locals in the range [253,255].
* module/system/vm/assembler.scm: List exports explicitly. For
operations with limited-range operands, export wrapper assemblers that
handle shuffling their operands into and out of their range.
(define-assembler): Get rid of enclosing begin.
(shuffling-assembler, define-shuffling-assembler): New helpers to
define shuffling wrapper assemblers.
(emit-mov*, emit-receive*): New functions.
(shuffle-up-args): New helper.
(standard-prelude, opt-prelude, kw-prelude): Call shuffle-up-args
after finishing.
* test-suite/tests/compiler.test ("limits"): Add test cases.
commit 28e12ea0c401ea2c1aad203d7b45b2209d5e9be2
Author: Andy Wingo <address@hidden>
Date: Mon Apr 21 12:13:54 2014 +0200
More expansion-time-only definitions in assembler.scm
* module/system/vm/assembler.scm (define-inline): Change so that the
defined macro is only defined at expansion-time.
(u32-ref, u32-set!, s32-ref, s32-set!, pack-arity-flags): Use
define-inline.
(pack-flags, assert-match, *block-size*, id-append, assembler)
(define-assembler, visit-opcodes, define-macro-assembler): Wrap in
eval-when expand.
commit dece041203724bcf4bf74dbec459f5dbae4aa7ed
Author: Andy Wingo <address@hidden>
Date: Mon Apr 21 12:01:46 2014 +0200
define-inline in assembler.scm
* module/system/vm/assembler.scm (define-inline): New local helper.
Update local users of define-inlinable to use it.
commit c09708f985a7b39c1f07890e75ec2ec18c3565b6
Author: Andy Wingo <address@hidden>
Date: Sun Apr 20 11:52:14 2014 +0200
VM opcodes only have <24-bit slot operands in the first word
* libguile/vm-engine.c (make-array): Change to only have
restricted-width operands in the first word. This instruction is
currently unused, however.
* module/system/vm/assembler.scm (assembler):
* module/system/vm/disassembler.scm (disassembler): Disallow
restricted-width operands in tail words.
-----------------------------------------------------------------------
Summary of changes:
libguile/_scm.h | 2 +-
libguile/vm-engine.c | 91 +++--
module/language/cps/compile-bytecode.scm | 2 +
module/language/cps/slot-allocation.scm | 16 +-
module/system/vm/assembler.scm | 637 ++++++++++++++++++++++--------
module/system/vm/disassembler.scm | 16 -
test-suite/tests/compiler.test | 40 ++-
7 files changed, 576 insertions(+), 228 deletions(-)
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 87f9763..97ddaf2 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -268,7 +268,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 5
+#define SCM_OBJCODE_MINOR_VERSION 6
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index e574eac..86803fd 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -2527,13 +2527,29 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
RETURN_EXP (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 (94, make_vector, "make-vector", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ scm_t_uint8 dst, init, length;
+
+ UNPACK_8_8_8 (op, dst, length, init);
+
+ LOCAL_SET (dst, scm_make_vector (LOCAL_REF (length), LOCAL_REF (init)));
+
+ NEXT (1);
+ }
+
/* 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 (94, make_vector_immediate, "make-vector/immediate", OP1
(U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (95, make_vector_immediate, "make-vector/immediate", OP1
(U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, init;
scm_t_int32 length, n;
@@ -2554,7 +2570,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
*
* Store the length of the vector in SRC in DST.
*/
- VM_DEFINE_OP (95, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (96, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (vect);
VM_ASSERT (SCM_I_IS_VECTOR (vect),
@@ -2567,7 +2583,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* Fetch the item at position IDX in the vector in SRC, and store it
* in DST.
*/
- VM_DEFINE_OP (96, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (97, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
@@ -2585,7 +2601,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* Fill DST with the item IDX elements into the vector at SRC. Useful
* for building data types using vectors.
*/
- VM_DEFINE_OP (97, vector_ref_immediate, "vector-ref/immediate", OP1
(U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (98, vector_ref_immediate, "vector-ref/immediate", OP1
(U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM v;
@@ -2604,7 +2620,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
*
* Store SRC into the vector DST at index IDX.
*/
- VM_DEFINE_OP (98, vector_set, "vector-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (99, vector_set, "vector-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx_var, src;
SCM vect, idx, val;
@@ -2630,7 +2646,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* Store SRC into the vector DST at index IDX. Here IDX is an
* immediate value.
*/
- VM_DEFINE_OP (99, vector_set_immediate, "vector-set!/immediate", OP1
(U8_U8_U8_U8))
+ VM_DEFINE_OP (100, vector_set_immediate, "vector-set!/immediate", OP1
(U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM vect, val;
@@ -2658,7 +2674,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (100, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (101, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable");
@@ -2671,7 +2687,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* will be constructed with space for NFIELDS fields, which should
* correspond to the field count of the VTABLE.
*/
- VM_DEFINE_OP (101, allocate_struct_immediate, "allocate-struct/immediate",
OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (102, allocate_struct_immediate, "allocate-struct/immediate",
OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, vtable, nfields;
SCM ret;
@@ -2690,7 +2706,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* Fetch the item at slot IDX in the struct in SRC, and store it
* in DST. IDX is an immediate unsigned 8-bit value.
*/
- VM_DEFINE_OP (102, struct_ref_immediate, "struct-ref/immediate", OP1
(U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (103, struct_ref_immediate, "struct-ref/immediate", OP1
(U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM obj;
@@ -2715,7 +2731,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* Store SRC into the struct DST at slot IDX. IDX is an immediate
* unsigned 8-bit value.
*/
- VM_DEFINE_OP (103, struct_set_immediate, "struct-set!/immediate", OP1
(U8_U8_U8_U8))
+ VM_DEFINE_OP (104, struct_set_immediate, "struct-set!/immediate", OP1
(U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM obj, val;
@@ -2746,7 +2762,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (104, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (105, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
@@ -2767,7 +2783,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* from the instruction pointer, and store into DST. LEN is a byte
* length. OFFSET is signed.
*/
- VM_DEFINE_OP (105, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8,
N32, U32) | OP_DST)
+ VM_DEFINE_OP (106, 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;
@@ -2783,15 +2799,15 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (3);
}
- /* make-array dst:12 type:12 _:8 fill:12 bounds:12
+ /* make-array dst:8 type:8 fill:8 _:8 bounds:24
*
* Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
*/
- VM_DEFINE_OP (106, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (107, make_array, "make-array", OP2 (U8_U8_U8_U8, X8_U24) |
OP_DST)
{
- scm_t_uint16 dst, type, fill, bounds;
- UNPACK_12_12 (op, dst, type);
- UNPACK_12_12 (ip[1], fill, bounds);
+ scm_t_uint8 dst, type, fill, bounds;
+ UNPACK_8_8_8 (op, dst, type, fill);
+ UNPACK_24 (ip[1], bounds);
SYNC_IP ();
LOCAL_SET (dst, scm_make_typed_array (LOCAL_REF (type), LOCAL_REF (fill),
LOCAL_REF (bounds)));
@@ -2885,42 +2901,42 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
} while (0)
- VM_DEFINE_OP (107, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (108, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
- VM_DEFINE_OP (108, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (109, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s8, s8, int8, 1);
- VM_DEFINE_OP (109, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (110, 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 (110, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (111, 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 (111, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (112, 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 (112, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (113, 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 (113, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (114, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (u64, uint64, 8);
- VM_DEFINE_OP (114, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (115, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (s64, int64, 8);
- VM_DEFINE_OP (115, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (116, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f32, ieee_single, float, 4);
- VM_DEFINE_OP (116, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (117, 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
@@ -3024,45 +3040,44 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (1); \
} while (0)
- VM_DEFINE_OP (117, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (118, 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 (118, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (119, 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 (119, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (120, 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 (120, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (121, 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 (121, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (122, 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 (122, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (123, 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 (123, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (124, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (u64, uint64, 8);
- VM_DEFINE_OP (124, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (125, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (s64, int64, 8);
- VM_DEFINE_OP (125, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (126, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f32, ieee_single, float, 4);
- VM_DEFINE_OP (126, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (127, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f64, ieee_double, double, 8);
- VM_DEFINE_OP (127, unused_127, NULL, NOP)
VM_DEFINE_OP (128, unused_128, NULL, NOP)
VM_DEFINE_OP (129, unused_129, NULL, NOP)
VM_DEFINE_OP (130, unused_130, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index fc4b21a..e958b4c 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -268,6 +268,8 @@
(emit-free-ref asm dst (slot closure) (constant idx)))
(($ $primcall 'vector-ref (vector index))
(emit-vector-ref asm dst (slot vector) (slot index)))
+ (($ $primcall 'make-vector (length init))
+ (emit-make-vector asm dst (slot length) (slot init)))
(($ $primcall 'make-vector/immediate (length init))
(emit-make-vector/immediate asm dst (constant length) (slot init)))
(($ $primcall 'vector-ref/immediate (vector index))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 1cb0fa7..53d6cee 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -262,9 +262,15 @@ are comparable with eqv?. A tmp slot may be used."
(logand live-slots (lognot (ash 1 slot))))
(define (compute-slot live-slots hint)
- (if (and hint (not (logbit? hint live-slots)))
+ ;; Slots 253-255 are reserved for shuffling; see comments in
+ ;; assembler.scm.
+ (if (and hint (not (logbit? hint live-slots))
+ (or (< hint 253) (> hint 255)))
hint
- (find-first-zero live-slots)))
+ (let ((slot (find-first-zero live-slots)))
+ (if (or (< slot 253) (> slot 255))
+ slot
+ (+ 256 (find-first-zero (ash live-slots -256)))))))
(define (compute-call-proc-slot live-slots)
(+ 2 (find-first-trailing-zero live-slots)))
@@ -307,6 +313,12 @@ are comparable with eqv?. A tmp slot may be used."
;; or to function return values -- it could be that they are out of
;; the computed live set. In that case they need to be adjoined to
;; the live set, used when choosing a temporary slot.
+ ;;
+ ;; Note that although we reserve slots 253-255 for shuffling
+ ;; operands that address less than the full 24-bit range of locals,
+ ;; that reservation doesn't apply here, because this temporary
+ ;; itself is used while doing parallel assignment via "mov", and
+ ;; "mov" does not need shuffling.
(define (compute-tmp-slot live stack-slots)
(find-first-zero (fold add-live-slot live stack-slots)))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 8bbe1d9..787273e 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -57,21 +57,148 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:export (make-assembler
+
+ emit-call
+ emit-call-label
+ emit-tail-call
+ emit-tail-call-label
+ (emit-receive* . emit-receive)
+ emit-receive-values
+ emit-return
+ emit-return-values
+ emit-call/cc
+ emit-abort
+ (emit-builtin-ref* . emit-builtin-ref)
+ emit-br-if-nargs-ne
+ emit-br-if-nargs-lt
+ emit-br-if-nargs-gt
+ emit-assert-nargs-ee
+ emit-assert-nargs-ge
+ emit-assert-nargs-le
+ emit-alloc-frame
+ emit-reset-frame
+ emit-assert-nargs-ee/locals
+ emit-br-if-npos-gt
+ emit-bind-kwargs
+ emit-bind-rest
+ emit-br
+ emit-br-if-true
+ emit-br-if-null
+ emit-br-if-nil
+ emit-br-if-pair
+ emit-br-if-struct
+ emit-br-if-char
+ emit-br-if-tc7
+ (emit-br-if-eq* . emit-br-if-eq)
+ (emit-br-if-eqv* . emit-br-if-eqv)
+ (emit-br-if-equal* . emit-br-if-equal)
+ (emit-br-if-=* . emit-br-if-=)
+ (emit-br-if-<* . emit-br-if-<)
+ (emit-br-if-<=* . emit-br-if-<=)
+ (emit-mov* . emit-mov)
+ (emit-box* . emit-box)
+ (emit-box-ref* . emit-box-ref)
+ (emit-box-set!* . emit-box-set!)
+ emit-make-closure
+ (emit-free-ref* . emit-free-ref)
+ (emit-free-set!* . emit-free-set!)
+ emit-current-module
+ emit-resolve
+ (emit-define!* . emit-define!)
+ emit-toplevel-box
+ emit-module-box
+ emit-prompt
+ (emit-wind* . emit-wind)
+ emit-unwind
+ (emit-push-fluid* . emit-push-fluid)
+ emit-pop-fluid
+ (emit-fluid-ref* . emit-fluid-ref)
+ (emit-fluid-set* . emit-fluid-set)
+ (emit-string-length* . emit-string-length)
+ (emit-string-ref* . emit-string-ref)
+ (emit-string->number* . emit-string->number)
+ (emit-string->symbol* . emit-string->symbol)
+ (emit-symbol->keyword* . emit-symbol->keyword)
+ (emit-cons* . emit-cons)
+ (emit-car* . emit-car)
+ (emit-cdr* . emit-cdr)
+ (emit-set-car!* . emit-set-car!)
+ (emit-set-cdr!* . emit-set-cdr!)
+ (emit-add* . emit-add)
+ (emit-add1* . emit-add1)
+ (emit-sub* . emit-sub)
+ (emit-sub1* . emit-sub1)
+ (emit-mul* . emit-mul)
+ (emit-div* . emit-div)
+ (emit-quo* . emit-quo)
+ (emit-rem* . emit-rem)
+ (emit-mod* . emit-mod)
+ (emit-ash* . emit-ash)
+ (emit-logand* . emit-logand)
+ (emit-logior* . emit-logior)
+ (emit-logxor* . emit-logxor)
+ (emit-make-vector* . emit-make-vector)
+ (emit-make-vector/immediate* . emit-make-vector/immediate)
+ (emit-vector-length* . emit-vector-length)
+ (emit-vector-ref* . emit-vector-ref)
+ (emit-vector-ref/immediate* . emit-vector-ref/immediate)
+ (emit-vector-set!* . emit-vector-set!)
+ (emit-vector-set!/immediate* . emit-vector-set!/immediate)
+ (emit-struct-vtable* . emit-struct-vtable)
+ (emit-allocate-struct/immediate* . emit-allocate-struct/immediate)
+ (emit-struct-ref/immediate* . emit-struct-ref/immediate)
+ (emit-struct-set!/immediate* . emit-struct-set!/immediate)
+ (emit-class-of* . emit-class-of)
+ (emit-make-array* . emit-make-array)
+ (emit-bv-u8-ref* . emit-bv-u8-ref)
+ (emit-bv-s8-ref* . emit-bv-s8-ref)
+ (emit-bv-u16-ref* . emit-bv-u16-ref)
+ (emit-bv-s16-ref* . emit-bv-s16-ref)
+ (emit-bv-u32-ref* . emit-bv-u32-ref)
+ (emit-bv-s32-ref* . emit-bv-s32-ref)
+ (emit-bv-u64-ref* . emit-bv-u64-ref)
+ (emit-bv-s64-ref* . emit-bv-s64-ref)
+ (emit-bv-f32-ref* . emit-bv-f32-ref)
+ (emit-bv-f64-ref* . emit-bv-f64-ref)
+ (emit-bv-u8-set!* . emit-bv-u8-set!)
+ (emit-bv-s8-set!* . emit-bv-s8-set!)
+ (emit-bv-u16-set!* . emit-bv-u16-set!)
+ (emit-bv-s16-set!* . emit-bv-s16-set!)
+ (emit-bv-u32-set!* . emit-bv-u32-set!)
+ (emit-bv-s32-set!* . emit-bv-s32-set!)
+ (emit-bv-u64-set!* . emit-bv-u64-set!)
+ (emit-bv-s64-set!* . emit-bv-s64-set!)
+ (emit-bv-f32-set!* . emit-bv-f32-set!)
+ (emit-bv-f64-set!* . emit-bv-f64-set!)
+
emit-text
link-assembly))
+;; Like define-inlinable, but only for first-order uses of the defined
+;; routine. Should residualize less code.
+(eval-when (expand)
+ (define-syntax define-inline
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (name arg ...) body ...)
+ (with-syntax (((temp ...) (generate-temporaries #'(arg ...))))
+ #`(eval-when (expand)
+ (define-syntax-rule (name temp ...)
+ (let ((arg temp) ...)
+ body ...)))))))))
+
;;; Bytecode consists of 32-bit units, often subdivided in some way.
;;; These helpers create one 32-bit unit from multiple components.
-(define-inlinable (pack-u8-u24 x y)
+(define-inline (pack-u8-u24 x y)
(unless (<= 0 x 255)
(error "out of range" x))
(logior x (ash y 8)))
-(define-inlinable (pack-u8-s24 x y)
+(define-inline (pack-u8-s24 x y)
(unless (<= 0 x 255)
(error "out of range" x))
(logior x (ash (cond
@@ -82,28 +209,28 @@
(else (error "out of range" y)))
8)))
-(define-inlinable (pack-u1-u7-u24 x y z)
+(define-inline (pack-u1-u7-u24 x y z)
(unless (<= 0 x 1)
(error "out of range" x))
(unless (<= 0 y 127)
(error "out of range" y))
(logior x (ash y 1) (ash z 8)))
-(define-inlinable (pack-u8-u12-u12 x y z)
+(define-inline (pack-u8-u12-u12 x y z)
(unless (<= 0 x 255)
(error "out of range" x))
(unless (<= 0 y 4095)
(error "out of range" y))
(logior x (ash y 8) (ash z 20)))
-(define-inlinable (pack-u8-u8-u16 x y z)
+(define-inline (pack-u8-u8-u16 x y z)
(unless (<= 0 x 255)
(error "out of range" x))
(unless (<= 0 y 255)
(error "out of range" y))
(logior x (ash y 8) (ash z 16)))
-(define-inlinable (pack-u8-u8-u8-u8 x y z w)
+(define-inline (pack-u8-u8-u8-u8 x y z w)
(unless (<= 0 x 255)
(error "out of range" x))
(unless (<= 0 y 255)
@@ -112,24 +239,25 @@
(error "out of range" z))
(logior x (ash y 8) (ash z 16) (ash w 24)))
-(define-syntax pack-flags
- (syntax-rules ()
- ;; Add clauses as needed.
- ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
- (if f2 (ash 2 0) 0)))))
+(eval-when (expand)
+ (define-syntax pack-flags
+ (syntax-rules ()
+ ;; Add clauses as needed.
+ ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
+ (if f2 (ash 2 0) 0))))))
;;; Helpers to read and write 32-bit units in a buffer.
-(define-syntax-rule (u32-ref buf n)
+(define-inline (u32-ref buf n)
(bytevector-u32-native-ref buf (* n 4)))
-(define-syntax-rule (u32-set! buf n val)
+(define-inline (u32-set! buf n val)
(bytevector-u32-native-set! buf (* n 4) val))
-(define-syntax-rule (s32-ref buf n)
+(define-inline (s32-ref buf n)
(bytevector-s32-native-ref buf (* n 4)))
-(define-syntax-rule (s32-set! buf n val)
+(define-inline (s32-set! buf n val)
(bytevector-s32-native-set! buf (* n 4) val))
@@ -138,10 +266,11 @@
;;; A <meta> entry collects metadata for one procedure. Procedures are
;;; written as contiguous ranges of bytecode.
;;;
-(define-syntax-rule (assert-match arg pattern kind)
- (let ((x arg))
- (unless (match x (pattern #t) (_ #f))
- (error (string-append "expected " kind) x))))
+(eval-when (expand)
+ (define-syntax-rule (assert-match arg pattern kind)
+ (let ((x arg))
+ (unless (match x (pattern #t) (_ #f))
+ (error (string-append "expected " kind) x)))))
(define-record-type <meta>
(%make-meta label properties low-pc high-pc arities)
@@ -174,7 +303,8 @@
(high-pc arity-high-pc set-arity-high-pc!)
(definitions arity-definitions set-arity-definitions!))
-(define-syntax *block-size* (identifier-syntax 32))
+(eval-when (expand)
+ (define-syntax *block-size* (identifier-syntax 32)))
;;; An assembler collects all of the words emitted during assembly, and
;;; also maintains ancillary information such as the constant table, a
@@ -276,7 +406,7 @@
;;
(dead-slot-maps asm-dead-slot-maps set-asm-dead-slot-maps!))
-(define-inlinable (fresh-block)
+(define-inline (fresh-block)
(make-u32vector *block-size*))
(define* (make-assembler #:key (word-size (target-word-size))
@@ -295,7 +425,7 @@ target."
"Add a string to the section name table (shstrtab)."
(string-table-intern! (asm-shstrtab asm) string))
-(define-inlinable (asm-pos asm)
+(define-inline (asm-pos asm)
"The offset of the next word to be written into the code buffer, in
32-bit units."
(+ (asm-idx asm) (asm-written asm)))
@@ -309,7 +439,7 @@ written to a fresh block."
(set-asm-cur! asm new)
(set-asm-idx! asm 0)))
-(define-inlinable (emit asm u32)
+(define-inline (emit asm u32)
"Emit one 32-bit word into the instruction stream. Assumes that there
is space for the word, and ensures that there is space for the next
word."
@@ -318,7 +448,7 @@ word."
(if (= (asm-idx asm) *block-size*)
(allocate-new-block asm)))
-(define-inlinable (make-reloc type label base word)
+(define-inline (make-reloc type label base word)
"Make an internal relocation of type @var{type} referencing symbol
@var{label}, @var{word} words after position @var{start}. @var{type}
may be x8-s24, indicating a 24-bit relative label reference that can be
@@ -326,7 +456,7 @@ fixed up by the assembler, or s32, indicating a 32-bit
relative
reference that needs to be fixed up by the linker."
(list type label base word))
-(define-inlinable (reset-asm-start! asm)
+(define-inline (reset-asm-start! asm)
"Reset the asm-start after writing the words for one instruction."
(set-asm-start! asm (asm-pos asm)))
@@ -354,144 +484,294 @@ later by the linker."
;;; opcode in `(instruction-list)'.
;;;
-(eval-when (expand compile load eval)
+(eval-when (expand)
(define (id-append ctx a b)
- (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
-
-(define-syntax assembler
- (lambda (x)
- (define-syntax op-case
- (lambda (x)
- (syntax-case x ()
- ((_ asm name ((type arg ...) code ...) clause ...)
- #`(if (eq? name 'type)
- (with-syntax (((arg ...) (generate-temporaries #'(arg ...))))
- #'((arg ...)
- code ...))
- (op-case asm name clause ...)))
- ((_ asm name)
- #'(error "unmatched name" name)))))
-
- (define (pack-first-word asm opcode type)
- (with-syntax ((opcode opcode))
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
+
+ (define-syntax assembler
+ (lambda (x)
+ (define-syntax op-case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ asm name ((type arg ...) code ...) clause ...)
+ #`(if (eq? name 'type)
+ (with-syntax (((arg ...) (generate-temporaries #'(arg
...))))
+ #'((arg ...)
+ code ...))
+ (op-case asm name clause ...)))
+ ((_ asm name)
+ #'(error "unmatched name" name)))))
+
+ (define (pack-first-word asm opcode type)
+ (with-syntax ((opcode opcode))
+ (op-case
+ asm type
+ ((U8_X24)
+ (emit asm opcode))
+ ((U8_U24 arg)
+ (emit asm (pack-u8-u24 opcode arg)))
+ ((U8_L24 label)
+ (record-label-reference asm label)
+ (emit asm opcode))
+ ((U8_U8_I16 a imm)
+ (emit asm (pack-u8-u8-u16 opcode a (object-address imm))))
+ ((U8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 opcode a b)))
+ ((U8_U8_U8_U8 a b c)
+ (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
+
+ (define (pack-tail-word asm type)
(op-case
asm type
- ((U8_X24)
- (emit asm opcode))
- ((U8_U24 arg)
- (emit asm (pack-u8-u24 opcode arg)))
- ((U8_L24 label)
+ ((U8_U24 a b)
+ (emit asm (pack-u8-u24 a b)))
+ ((U8_L24 a label)
(record-label-reference asm label)
- (emit asm opcode))
- ((U8_U8_I16 a imm)
- (emit asm (pack-u8-u8-u16 opcode a (object-address imm))))
- ((U8_U12_U12 a b)
- (emit asm (pack-u8-u12-u12 opcode a b)))
- ((U8_U8_U8_U8 a b c)
- (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
-
- (define (pack-tail-word asm type)
- (op-case
- asm type
- ((U8_U24 a b)
- (emit asm (pack-u8-u24 a b)))
- ((U8_L24 a label)
- (record-label-reference asm label)
- (emit asm a))
- ((U8_U8_I16 a b imm)
- (emit asm (pack-u8-u8-u16 a b (object-address imm))))
- ((U8_U12_U12 a b)
- (emit asm (pack-u8-u12-u12 a b c)))
- ((U8_U8_U8_U8 a b c d)
- (emit asm (pack-u8-u8-u8-u8 a b c d)))
- ((U32 a)
- (emit asm a))
- ((I32 imm)
- (let ((val (object-address imm)))
- (unless (zero? (ash val -32))
- (error "FIXME: enable truncation of negative fixnums when
cross-compiling"))
- (emit asm val)))
- ((A32 imm)
- (unless (= (asm-word-size asm) 8)
- (error "make-long-immediate unavailable for this target"))
- (emit asm (ash (object-address imm) -32))
- (emit asm (logand (object-address imm) (1- (ash 1 32)))))
- ((B32))
- ((N32 label)
- (record-far-label-reference asm label)
- (emit asm 0))
- ((S32 label)
- (record-far-label-reference asm label)
- (emit asm 0))
- ((L32 label)
- (record-far-label-reference asm label)
- (emit asm 0))
- ((LO32 label offset)
- (record-far-label-reference asm label
- (* offset (/ (asm-word-size asm) 4)))
- (emit asm 0))
- ((X8_U24 a)
- (emit asm (pack-u8-u24 0 a)))
- ((X8_U12_U12 a b)
- (emit asm (pack-u8-u12-u12 0 a b)))
- ((X8_L24 label)
- (record-label-reference asm label)
- (emit asm 0))
- ((B1_X7_L24 a label)
- (record-label-reference asm label)
- (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
- ((B1_U7_L24 a b label)
- (record-label-reference asm label)
- (emit asm (pack-u1-u7-u24 (if a 1 0) b 0)))
- ((B1_X31 a)
- (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
- ((B1_X7_U24 a b)
- (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))))
-
- (syntax-case x ()
- ((_ name opcode word0 word* ...)
- (with-syntax ((((formal0 ...)
- code0 ...)
- (pack-first-word #'asm
- (syntax->datum #'opcode)
- (syntax->datum #'word0)))
- ((((formal* ...)
- code* ...) ...)
- (map (lambda (word) (pack-tail-word #'asm word))
- (syntax->datum #'(word* ...)))))
- #'(lambda (asm formal0 ... formal* ... ...)
- (unless (asm? asm) (error "not an asm"))
- code0 ...
- code* ... ...
- (reset-asm-start! asm)))))))
+ (emit asm a))
+ ((U32 a)
+ (emit asm a))
+ ((I32 imm)
+ (let ((val (object-address imm)))
+ (unless (zero? (ash val -32))
+ (error "FIXME: enable truncation of negative fixnums when
cross-compiling"))
+ (emit asm val)))
+ ((A32 imm)
+ (unless (= (asm-word-size asm) 8)
+ (error "make-long-immediate unavailable for this target"))
+ (emit asm (ash (object-address imm) -32))
+ (emit asm (logand (object-address imm) (1- (ash 1 32)))))
+ ((B32))
+ ((N32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((S32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((L32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((LO32 label offset)
+ (record-far-label-reference asm label
+ (* offset (/ (asm-word-size asm) 4)))
+ (emit asm 0))
+ ((X8_U24 a)
+ (emit asm (pack-u8-u24 0 a)))
+ ((X8_L24 label)
+ (record-label-reference asm label)
+ (emit asm 0))
+ ((B1_X7_L24 a label)
+ (record-label-reference asm label)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
+ ((B1_U7_L24 a b label)
+ (record-label-reference asm label)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) b 0)))
+ ((B1_X31 a)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
+ ((B1_X7_U24 a b)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))))
+
+ (syntax-case x ()
+ ((_ name opcode word0 word* ...)
+ (with-syntax ((((formal0 ...)
+ code0 ...)
+ (pack-first-word #'asm
+ (syntax->datum #'opcode)
+ (syntax->datum #'word0)))
+ ((((formal* ...)
+ code* ...) ...)
+ (map (lambda (word) (pack-tail-word #'asm word))
+ (syntax->datum #'(word* ...)))))
+ #'(lambda (asm formal0 ... formal* ... ...)
+ (unless (asm? asm) (error "not an asm"))
+ code0 ...
+ code* ... ...
+ (reset-asm-start! asm))))))))
(define assemblers (make-hash-table))
-(define-syntax define-assembler
- (lambda (x)
- (syntax-case x ()
- ((_ name opcode kind arg ...)
- (with-syntax ((emit (id-append #'name #'emit- #'name)))
- #'(begin
- (define emit
+(eval-when (expand)
+ (define-syntax define-assembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode kind arg ...)
+ (with-syntax ((emit (id-append #'name #'emit- #'name)))
+ #'(define emit
(let ((emit (assembler name opcode arg ...)))
(hashq-set! assemblers 'name emit)
- emit))
- (export emit)))))))
-
-(define-syntax visit-opcodes
- (lambda (x)
- (syntax-case x ()
- ((visit-opcodes macro arg ...)
- (with-syntax (((inst ...)
- (map (lambda (x) (datum->syntax #'macro x))
- (instruction-list))))
- #'(begin
- (macro arg ... . inst)
- ...))))))
+ emit)))))))
+
+ (define-syntax visit-opcodes
+ (lambda (x)
+ (syntax-case x ()
+ ((visit-opcodes macro arg ...)
+ (with-syntax (((inst ...)
+ (map (lambda (x) (datum->syntax #'macro x))
+ (instruction-list))))
+ #'(begin
+ (macro arg ... . inst)
+ ...)))))))
(visit-opcodes define-assembler)
+(eval-when (expand)
+
+ ;; Some operands are encoded using a restricted subset of the full
+ ;; 24-bit local address space, in order to make the bytecode more
+ ;; dense in the usual case that there are few live locals. Here we
+ ;; define wrapper emitters that shuffle out-of-range operands into and
+ ;; out of the reserved range of locals [233,255]. This range is
+ ;; sufficient because these restricted operands are only present in
+ ;; the first word of an instruction. Since 8 bits is the smallest
+ ;; slot-addressing operand size, that means we can fit 3 operands in
+ ;; the 24 bits of payload of the first word (the lower 8 bits being
+ ;; taken by the opcode).
+ ;;
+ ;; The result are wrapper emitters with the same arity,
+ ;; e.g. emit-cons* that wraps emit-cons. We expose these wrappers as
+ ;; the public interface for emitting `cons' instructions. That way we
+ ;; solve the problem fully and in just one place. The only manual
+ ;; care that need be taken is in the exports list at the top of the
+ ;; file -- to be sure that we export the wrapper and not the wrapped
+ ;; emitter.
+
+ (define (shuffling-assembler name kind word0 word*)
+ (define (analyze-first-word)
+ (define-syntax op-case
+ (syntax-rules ()
+ ((_ type ((%type %kind arg ...) values) clause ...)
+ (if (and (eq? type '%type) (eq? kind '%kind))
+ (with-syntax (((arg ...) (generate-temporaries #'(arg ...))))
+ #'((arg ...) values))
+ (op-case type clause ...)))
+ ((_ type)
+ #f)))
+ (op-case
+ word0
+ ((U8_U8_I16 ! a imm)
+ (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253))
+ imm))
+ ((U8_U8_I16 <- a imm)
+ (values (if (< a (ash 1 8)) a 253)
+ imm))
+ ((U8_U12_U12 ! a b)
+ (values (if (< a (ash 1 12)) a (begin (emit-mov* asm 253 a) 253))
+ (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254))))
+ ((U8_U12_U12 <- a b)
+ (values (if (< a (ash 1 12)) a 253)
+ (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254))))
+ ((U8_U8_U8_U8 ! a b c)
+ (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253))
+ (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254))
+ (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255))))
+ ((U8_U8_U8_U8 <- a b c)
+ (values (if (< a (ash 1 8)) a 253)
+ (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254))
+ (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255))))))
+
+ (define (tail-formals type)
+ (define-syntax op-case
+ (syntax-rules ()
+ ((op-case type (%type arg ...) clause ...)
+ (if (eq? type '%type)
+ (generate-temporaries #'(arg ...))
+ (op-case type clause ...)))
+ ((op-case type)
+ (error "unmatched type" type))))
+ (op-case type
+ (U8_U24 a b)
+ (U8_L24 a label)
+ (U32 a)
+ (I32 imm)
+ (A32 imm)
+ (B32)
+ (N32 label)
+ (S32 label)
+ (L32 label)
+ (LO32 label offset)
+ (X8_U24 a)
+ (X8_L24 label)
+ (B1_X7_L24 a label)
+ (B1_U7_L24 a b label)
+ (B1_X31 a)
+ (B1_X7_U24 a b)))
+
+ (define (shuffle-up dst)
+ (define-syntax op-case
+ (syntax-rules ()
+ ((_ type ((%type ...) exp) clause ...)
+ (if (memq type '(%type ...))
+ #'exp
+ (op-case type clause ...)))
+ ((_ type)
+ (error "unexpected type" type))))
+ (with-syntax ((dst dst))
+ (op-case
+ word0
+ ((U8_U8_I16 U8_U8_U8_U8)
+ (unless (< dst (ash 1 8))
+ (emit-mov* asm dst 253)))
+ ((U8_U12_U12)
+ (unless (< dst (ash 1 12))
+ (emit-mov* asm dst 253))))))
+
+ (and=>
+ (analyze-first-word)
+ (lambda (formals+shuffle)
+ (with-syntax ((emit-name (id-append name #'emit- name))
+ (((formal0 ...) shuffle) formals+shuffle)
+ (((formal* ...) ...) (map tail-formals word*)))
+ (with-syntax (((shuffle-up-dst ...)
+ (if (eq? kind '<-)
+ (syntax-case #'(formal0 ...) ()
+ ((dst . _)
+ (list (shuffle-up #'dst))))
+ '())))
+ #'(lambda (asm formal0 ... formal* ... ...)
+ (call-with-values (lambda () shuffle)
+ (lambda (formal0 ...)
+ (emit-name asm formal0 ... formal* ... ...)))
+ shuffle-up-dst ...))))))
+
+ (define-syntax define-shuffling-assembler
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ #:except (except ...) name opcode kind word0 word* ...)
+ (cond
+ ((or-map (lambda (op) (eq? (syntax->datum #'name) op))
+ (map syntax->datum #'(except ...)))
+ #'(begin))
+ ((shuffling-assembler #'name (syntax->datum #'kind)
+ (syntax->datum #'word0)
+ (map syntax->datum #'(word* ...)))
+ => (lambda (proc)
+ (with-syntax ((emit (id-append #'name
+ (id-append #'name #'emit-
#'name)
+ #'*))
+ (proc proc))
+ #'(define emit
+ (let ((emit proc))
+ (hashq-set! assemblers 'name emit)
+ emit)))))
+ (else #'(begin))))))))
+
+(visit-opcodes define-shuffling-assembler #:except (receive mov))
+
+;; Mov and receive are two special cases that can work without wrappers.
+;; Indeed it is important that they do so.
+
+(define (emit-mov* asm dst src)
+ (if (and (< dst (ash 1 12)) (< src (ash 1 12)))
+ (emit-mov asm dst src)
+ (emit-long-mov asm dst src)))
+
+(define (emit-receive* asm dst proc nlocals)
+ (if (and (< dst (ash 1 12)) (< proc (ash 1 12)))
+ (emit-receive asm dst proc nlocals)
+ (begin
+ (emit-receive-values asm proc #t 1)
+ (emit-mov* asm dst (1+ proc))
+ (emit-reset-frame asm nlocals))))
+
(define (emit-text asm instructions)
"Assemble @var{instructions} using the assembler @var{asm}.
@var{instructions} is a sequence of instructions, expressed as a list of
@@ -518,7 +798,7 @@ lists. This procedure can be called many times before
calling
;;; to the table.
;;;
-(define-inlinable (immediate? x)
+(define-inline (immediate? x)
"Return @code{#t} if @var{x} is immediate, and @code{#f} otherwise."
(not (zero? (logand (object-address x) 6))))
@@ -659,17 +939,18 @@ returned instead."
;;; some higher-level operations.
;;;
-(define-syntax define-macro-assembler
- (lambda (x)
- (syntax-case x ()
- ((_ (name arg ...) body body* ...)
- (with-syntax ((emit (id-append #'name #'emit- #'name)))
- #'(begin
- (define emit
- (let ((emit (lambda (arg ...) body body* ...)))
- (hashq-set! assemblers 'name emit)
- emit))
- (export emit)))))))
+(eval-when (expand)
+ (define-syntax define-macro-assembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (name arg ...) body body* ...)
+ (with-syntax ((emit (id-append #'name #'emit- #'name)))
+ #'(begin
+ (define emit
+ (let ((emit (lambda (arg ...) body body* ...)))
+ (hashq-set! assemblers 'name emit)
+ emit))
+ (export emit))))))))
(define-macro-assembler (load-constant asm dst obj)
(cond
@@ -776,6 +1057,19 @@ returned instead."
(set-arity-definitions! arity (reverse (arity-definitions arity)))
(set-arity-high-pc! arity (asm-start asm))))
+;; As noted above, we reserve locals 253 through 255 for shuffling large
+;; operands. However the calling convention has all arguments passed in
+;; a contiguous block. This helper, called after the clause has been
+;; chosen and the keyword/optional/rest arguments have been processed,
+;; shuffles up arguments from slot 253 and higher into their final
+;; allocations.
+;;
+(define (shuffle-up-args asm nargs)
+ (when (> nargs 253)
+ (let ((slot (1- nargs)))
+ (emit-mov asm (+ slot 3) slot)
+ (shuffle-up-args asm (1- nargs)))))
+
(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
(cond
(alternate
@@ -785,7 +1079,8 @@ returned instead."
(emit-assert-nargs-ee/locals asm nreq (- nlocals nreq)))
(else
(emit-assert-nargs-ee asm nreq)
- (emit-alloc-frame asm nlocals))))
+ (emit-alloc-frame asm nlocals)))
+ (shuffle-up-args asm nreq))
(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
(if alternate
@@ -798,7 +1093,8 @@ returned instead."
(emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
(else
(emit-assert-nargs-le asm (+ nreq nopt))))
- (emit-alloc-frame asm nlocals))
+ (emit-alloc-frame asm nlocals)
+ (shuffle-up-args asm (+ nreq nopt (if rest? 1 0))))
(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
allow-other-keys? nlocals alternate)
@@ -819,7 +1115,8 @@ returned instead."
(+ nreq nopt)
ntotal
(intern-constant asm kw-indices))
- (emit-alloc-frame asm nlocals)))
+ (emit-alloc-frame asm nlocals)
+ (shuffle-up-args asm ntotal)))
(define-macro-assembler (label asm sym)
(hashq-set! (asm-labels asm) sym (asm-start asm)))
@@ -1290,7 +1587,7 @@ needed."
;; FIXME: Define these somewhere central, shared with C.
(define *bytecode-major-version* #x0202)
-(define *bytecode-minor-version* 5)
+(define *bytecode-minor-version* 6)
(define (link-dynamic-section asm text rw rw-init frame-maps)
"Link the dynamic section for an ELF image with bytecode @var{text},
@@ -1470,9 +1767,9 @@ procedure with label @var{rw-init}. @var{rw-init} may be
false. If
(define (port-position port)
(seek port 0 SEEK_CUR))
-(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys?
- has-keyword-args? is-case-lambda?
- is-in-case-lambda?)
+(define-inline (pack-arity-flags has-rest? allow-other-keys?
+ has-keyword-args? is-case-lambda?
+ is-in-case-lambda?)
(logior (if has-rest? (ash 1 0) 0)
(if allow-other-keys? (ash 1 1) 0)
(if has-keyword-args? (ash 1 2) 0)
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 248b44e..3d8de82 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -110,19 +110,6 @@
((U8_L24)
#'((logand word #xff)
(unpack-s24 (ash word -8))))
- ((U8_U8_I16)
- #'((logand word #xff)
- (logand (ash word -8) #xff)
- (ash word -16)))
- ((U8_U12_U12)
- #'((logand word #xff)
- (logand (ash word -8) #xfff)
- (ash word -20)))
- ((U8_U8_U8_U8)
- #'((logand word #xff)
- (logand (ash word -8) #xff)
- (logand (ash word -16) #xff)
- (ash word -24)))
((U32)
#'(word))
((I32)
@@ -141,9 +128,6 @@
#'((unpack-s32 word)))
((X8_U24)
#'((ash word -8)))
- ((X8_U12_U12)
- #'((logand (ash word -8) #xfff)
- (ash word -20)))
((X8_L24)
#'((unpack-s24 (ash word -8))))
((B1_X7_L24)
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 70213ca..02f2a54 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013 Free Software
Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014 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
@@ -164,3 +164,41 @@
(list x y))))
(display (t 'x)))))
"(x y)(x y)")))
+
+(with-test-prefix "limits"
+ (define (arg n)
+ (string->symbol (format #f "arg~a" n)))
+
+ ;; Cons and vector-set! take uint8 arguments, so this triggers the
+ ;; shuffling case. Also there is the case where more than 252
+ ;; arguments causes shuffling.
+
+ (pass-if "300 arguments"
+ (equal? (apply (compile `(lambda ,(map arg (iota 300))
+ 'foo))
+ (iota 300))
+ 'foo))
+
+ (pass-if "300 arguments with list"
+ (equal? (apply (compile `(lambda ,(map arg (iota 300))
+ (list ,@(reverse (map arg (iota 300))))))
+ (iota 300))
+ (reverse (iota 300))))
+
+ (pass-if "300 arguments with vector"
+ (equal? (apply (compile `(lambda ,(map arg (iota 300))
+ (vector ,@(reverse (map arg (iota 300))))))
+ (iota 300))
+ (list->vector (reverse (iota 300)))))
+
+ (pass-if "0 arguments with list of 300 elements"
+ (equal? ((compile `(lambda ()
+ (list ,@(map (lambda (n) `(identity ,n))
+ (iota 300))))))
+ (iota 300)))
+
+ (pass-if "0 arguments with vector of 300 elements"
+ (equal? ((compile `(lambda ()
+ (vector ,@(map (lambda (n) `(identity ,n))
+ (iota 300))))))
+ (list->vector (iota 300)))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-958-gd38ca16,
Andy Wingo <=