[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-107-g78ff784
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-107-g78ff784 |
|
Date: |
Sun, 21 Jul 2013 15:26:39 +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=78ff784784a001c775b790dffe948b56c50bd153
The branch, master has been updated
via 78ff784784a001c775b790dffe948b56c50bd153 (commit)
via 746065c92e423290e34884d057bbabf14134f664 (commit)
via 14d102920fea11039cdae7fe05a2dc56f7e1264a (commit)
via b21713128e84480c9665b288deff41b883ef4905 (commit)
via 286a0fb3ae121af799e8e4301f1137fa92b56bc6 (commit)
via 7396d21670f4e5182051e24a7b459712d404c276 (commit)
via 2a294c7cd3c27dd3159da840df3d004da4fc4094 (commit)
via ee0a2b5135d78203a65ddf3247a74e0014f9d48f (commit)
via 081cf91029c7e7527e64fab5c9069262a345b10a (commit)
from f82f62944a4e605d385f40b5a4a01e19677bc0b3 (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 78ff784784a001c775b790dffe948b56c50bd153
Author: Andy Wingo <address@hidden>
Date: Sun Jul 21 17:11:18 2013 +0200
RTL instructions have no rest args
* libguile/instructions.c (FOR_EACH_INSTRUCTION_WORD_TYPE):
* module/system/vm/assembler.scm (assembler):
* module/system/vm/disassembler.scm (disassembler): Remove support for
RTL instructions with rest args.
commit 746065c92e423290e34884d057bbabf14134f664
Author: Andy Wingo <address@hidden>
Date: Sun Jul 21 17:06:41 2013 +0200
Use allocate-struct in define-record-type implementations
* module/ice-9/boot-9.scm (iota): Move up.
(make-record-type, define-record-type): Use allocate-struct and
struct-set!.
* module/srfi/srfi-9.scm (%%set-fields, %define-record-type): Use
allocate-struct and struct-set!.
Note that this makes the stack VM slower, but it will make RTL
compilation faster.
commit 14d102920fea11039cdae7fe05a2dc56f7e1264a
Author: Andy Wingo <address@hidden>
Date: Sun Jul 21 16:17:59 2013 +0200
add allocate-struct primitive and rtl opcode
* libguile/struct.h:
* libguile/struct.c (scm_allocate_struct): New interface: allocates a
struct.
* libguile/vm-engine.c (allocate_struct): Instead of make-struct with a
rest arg, separate allocation from initialization.
commit b21713128e84480c9665b288deff41b883ef4905
Author: Andy Wingo <address@hidden>
Date: Sun Jul 21 12:54:36 2013 +0200
abort is no longer an op with rest args
* libguile/vm-engine.c (abort): No longer an op with rest args.
commit 286a0fb3ae121af799e8e4301f1137fa92b56bc6
Author: Andy Wingo <address@hidden>
Date: Sat Jul 20 23:10:36 2013 +0200
call is no longer a vararg instruction
* libguile/vm-engine.c (push_frame, call): Separate out push_frame from
call, and expect the caller to arrange the proc and arguments.
* test-suite/tests/rtl.test ("call"): Update tests.
commit 7396d21670f4e5182051e24a7b459712d404c276
Author: Andy Wingo <address@hidden>
Date: Sat Jul 20 20:05:13 2013 +0200
RTL: Local 0 is the procedure
* libguile/vm-engine.c: Change the RTL VM to number the procedure as
local 0, and other locals from 1. In the future we will want the FP
to point to local 0 instead of local 1. In the future also we can
elide the procedure for well-known closures (closures in which all
references are known call sites).
(make_closure, free_set): Instead of taking rest arguments, we add a
new free-set! op that initializes closures.
(free_ref): Take the closure as an argument.
* libguile/vm.c (rtl_boot_continuation_code): Remove comments, which
were out of date.
(rtl_apply_code, rtl_values_code): Update comments.
* module/system/vm/assembler.scm (intern-constant, emit-init-constants):
Adapt to locals numbering change.
(begin-kw-arity): For assert-nargs-ee purposes, nreq includes the
procedure.
* module/system/vm/disassembler.scm (code-annotation): Adapt annotation
for assert-nargs-ee/locals.
* test-suite/tests/rtl.test: Adapt tests.
commit 2a294c7cd3c27dd3159da840df3d004da4fc4094
Author: Andy Wingo <address@hidden>
Date: Fri Jul 19 09:55:20 2013 +0200
rtl: propagate OP_DST to scheme
* libguile/instructions.c (scm_rtl_instruction_list): Add an element to
the list to indicate that an instruction outputs to its first
argument.
* module/system/vm/assembler.scm:
* module/system/vm/disassembler.scm: Adapt.
commit ee0a2b5135d78203a65ddf3247a74e0014f9d48f
Author: Andy Wingo <address@hidden>
Date: Fri Jul 19 16:21:18 2013 +0200
free variable debugging access procedures for rtl
* libguile/programs.c (scm_program_num_free_variables)
(scm_program_free_variable_ref, scm_program_free_variable_set_x): Add
support for RTL programs.
commit 081cf91029c7e7527e64fab5c9069262a345b10a
Author: Andy Wingo <address@hidden>
Date: Fri Jul 19 16:19:34 2013 +0200
fix rtl program arity functions
* libguile/programs.c (parse_arity): Lookup rtl-program-minimum-arity
from (system vm debug).
* module/system/vm/debug.scm (find-first-arity): Fix the linear search.
Whoops!
-----------------------------------------------------------------------
Summary of changes:
libguile/instructions.c | 7 +-
libguile/programs.c | 23 ++-
libguile/struct.c | 36 +++
libguile/struct.h | 1 +
libguile/vm-engine.c | 496 ++++++++++++++++++-------------------
libguile/vm.c | 8 +-
module/ice-9/boot-9.scm | 39 ++-
module/srfi/srfi-9.scm | 62 +++--
module/system/vm/assembler.scm | 54 ++---
module/system/vm/debug.scm | 6 +-
module/system/vm/disassembler.scm | 32 +--
test-suite/tests/rtl.test | 203 ++++++++--------
12 files changed, 508 insertions(+), 459 deletions(-)
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 9e8ccb4..9e7e519 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -41,6 +41,10 @@ struct scm_instruction {
};
+SCM_SYMBOL (sym_left_arrow, "<-");
+SCM_SYMBOL (sym_bang, "!");
+
+
#define OP_HAS_ARITY (1U << 0)
#define FOR_EACH_INSTRUCTION_WORD_TYPE(M) \
@@ -48,7 +52,6 @@ struct scm_instruction {
M(U8_X24) \
M(U8_U24) \
M(U8_L24) \
- M(U8_R24) \
M(U8_U8_I16) \
M(U8_U8_U8_U8) \
M(U8_U12_U12) \
@@ -62,7 +65,6 @@ struct scm_instruction {
M(LO32) /* Label with offset. */ \
M(X8_U24) \
M(X8_U12_U12) \
- M(X8_R24) \
M(X8_L24) \
M(B1_X7_L24) \
M(B1_U7_L24)
@@ -274,6 +276,7 @@ SCM_DEFINE (scm_rtl_instruction_list,
"rtl-instruction-list", 0, 0, 0,
case 1:
tail = scm_cons (word_type_symbols[WORD_TYPE (0, meta)], tail);
default:
+ tail = scm_cons ((meta & OP_DST) ? sym_left_arrow : sym_bang,
tail);
tail = scm_cons (scm_from_int (ip[i].opcode), tail);
tail = scm_cons (ip[i].symname, tail);
break;
diff --git a/libguile/programs.c b/libguile/programs.c
index d8dd378..9b3e748 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -403,6 +403,10 @@ SCM_DEFINE (scm_program_num_free_variables,
"program-num-free-variables", 1, 0,
"")
#define FUNC_NAME s_scm_program_num_free_variables
{
+ if (SCM_RTL_PROGRAM_P (program)) {
+ return scm_from_ulong (SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program));
+ }
+
SCM_VALIDATE_PROGRAM (1, program);
return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
}
@@ -414,6 +418,14 @@ SCM_DEFINE (scm_program_free_variable_ref,
"program-free-variable-ref", 2, 0, 0,
#define FUNC_NAME s_scm_program_free_variable_ref
{
unsigned long idx;
+
+ if (SCM_RTL_PROGRAM_P (program)) {
+ SCM_VALIDATE_ULONG_COPY (2, i, idx);
+ if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program))
+ SCM_OUT_OF_RANGE (2, i);
+ return SCM_RTL_PROGRAM_FREE_VARIABLE_REF (program, idx);
+ }
+
SCM_VALIDATE_PROGRAM (1, program);
SCM_VALIDATE_ULONG_COPY (2, i, idx);
if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
@@ -428,6 +440,15 @@ SCM_DEFINE (scm_program_free_variable_set_x,
"program-free-variable-set!", 3, 0,
#define FUNC_NAME s_scm_program_free_variable_set_x
{
unsigned long idx;
+
+ if (SCM_RTL_PROGRAM_P (program)) {
+ SCM_VALIDATE_ULONG_COPY (2, i, idx);
+ if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program))
+ SCM_OUT_OF_RANGE (2, i);
+ SCM_RTL_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
+ return SCM_UNSPECIFIED;
+ }
+
SCM_VALIDATE_PROGRAM (1, program);
SCM_VALIDATE_ULONG_COPY (2, i, idx);
if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
@@ -482,7 +503,7 @@ scm_i_rtl_program_minimum_arity (SCM program, int *req, int
*opt, int *rest)
if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
rtl_program_minimum_arity =
- scm_c_private_variable ("system vm debug",
+ scm_c_private_variable ("system vm program",
"rtl-program-minimum-arity");
l = scm_call_1 (scm_variable_ref (rtl_program_minimum_arity), program);
diff --git a/libguile/struct.c b/libguile/struct.c
index c7f410b..1b61aa4 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -517,6 +517,42 @@ scm_c_make_struct (SCM vtable, size_t n_tail, size_t
n_init, scm_t_bits init, ..
return scm_c_make_structv (vtable, n_tail, n_init, v);
}
+SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0,
+ (SCM vtable, SCM nfields),
+ "Allocate a new structure with space for @var{nfields} fields.\n\n"
+ "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
+ "@var{nfields} must be a non-negative integer. Strictly speaking\n"
+ "@var{nfields} is redundant, as the vtable carries the size\n"
+ "for its instances. However passing it is useful as a sanity\n"
+ "check, given that one module can inline a constructor in\n"
+ "another.\n\n"
+ "Fields will be initialized with their default values.")
+#define FUNC_NAME s_scm_allocate_struct
+{
+ SCM ret;
+ size_t c_nfields;
+
+ SCM_VALIDATE_VTABLE (1, vtable);
+ c_nfields = scm_to_size_t (nfields);
+
+ SCM_ASSERT (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) == c_nfields,
+ nfields, 2, FUNC_NAME);
+
+ ret = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), c_nfields);
+
+ if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)))
+ {
+ size_t n;
+ for (n = 0; n < c_nfields; n++)
+ SCM_STRUCT_DATA_SET (ret, n, SCM_UNPACK (SCM_BOOL_F));
+ }
+ else
+ scm_struct_init (ret, SCM_VTABLE_LAYOUT (vtable), 0, 0, NULL);
+
+ return ret;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
(SCM vtable, SCM tail_array_size, SCM init),
"Create a new structure.\n\n"
diff --git a/libguile/struct.h b/libguile/struct.h
index 0aecfb9..f1f6c47 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -174,6 +174,7 @@ SCM_API SCM scm_applicable_struct_with_setter_vtable_vtable;
SCM_API SCM scm_make_struct_layout (SCM fields);
SCM_API SCM scm_struct_p (SCM x);
SCM_API SCM scm_struct_vtable_p (SCM x);
+SCM_INTERNAL SCM scm_allocate_struct (SCM vtable, SCM n_words);
SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
SCM_API SCM scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_inits,
scm_t_bits init, ...);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 9b12d3e..1300a1e 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -486,7 +486,6 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
#undef ALIGNED_P
#undef CACHE_REGISTER
#undef CHECK_OVERFLOW
-#undef FREE_VARIABLE_REF
#undef FUNC2
#undef INIT
#undef INUM_MAX
@@ -519,6 +518,9 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
relative to the current virtual machine. At some point it will
become "the" virtual machine, and we'll delete this paragraph. As
such, the rest of the comments speak as if there's only one VM.
+ In difference from the old VM, local 0 is the procedure, and the
+ first argument is local 1. At some point in the future we should
+ change the fp to point to the procedure and not to local 1.
<more overview here>
*/
@@ -554,12 +556,12 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
} while (0)
/* Reserve stack space for a frame. Will check that there is sufficient
- stack space for N locals, not including the procedure, in addition to
- 4 words to set up the next frame. Invoke after preparing the new
+ stack space for N locals, including the procedure, in addition to
+ 3 words to set up the next frame. Invoke after preparing the new
frame and setting the fp and ip. */
#define ALLOC_FRAME(n) \
do { \
- SCM *new_sp = vp->sp = fp - 1 + n; \
+ SCM *new_sp = vp->sp = fp - 1 + n - 1; \
CHECK_OVERFLOW (new_sp + 4); \
} while (0)
@@ -567,13 +569,14 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
stack expansion is needed. */
#define RESET_FRAME(n) \
do { \
- vp->sp = fp - 1 + n; \
+ vp->sp = fp - 2 + n; \
} while (0)
/* Compute the number of locals in the frame. This is equal to the
- number of actual arguments when a function is first called. */
+ number of actual arguments when a function is first called, plus
+ one for the function. */
#define FRAME_LOCALS_COUNT() \
- (vp->sp + 1 - fp)
+ (vp->sp + 1 - (fp - 1))
/* Restore registers after returning from a frame. */
#define RESTORE_FRAME() \
@@ -624,13 +627,12 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
case opcode:
#endif
-#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i)
-#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o
+#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, (i) - 1)
+#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, (i) - 1) = o
#define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
#define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
-#define FREE_VARIABLE_REF(i) SCM_RTL_PROGRAM_FREE_VARIABLE_REF
(SCM_FRAME_PROGRAM (fp), i)
#define RETURN_ONE_VALUE(ret) \
do { \
@@ -654,7 +656,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
fp[-1] = rtl_apply; \
fp[0] = rtl_values; \
fp[1] = vals; \
- RESET_FRAME (2); \
+ RESET_FRAME (3); \
ip = (scm_t_uint32 *) rtl_apply_code; \
goto op_apply; \
} while (0)
@@ -879,7 +881,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
base[6] = SCM_PACK (ip); /* ra */
base[7] = program;
fp = vp->fp = &base[8];
- RESET_FRAME (nargs_);
+ RESET_FRAME (nargs_ + 1);
}
apply:
@@ -902,7 +904,6 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
vp->sp++;
while (n--)
LOCAL_SET (n + 1, LOCAL_REF (n));
- LOCAL_SET (0, proc);
fp[-1] = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
continue;
@@ -914,7 +915,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
SCM ret;
SYNC_ALL ();
- ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT ());
+ ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT () - 1);
if (SCM_UNLIKELY (SCM_VALUESP (ret)))
RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
@@ -938,11 +939,11 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
/* halt _:24
*
- * Bring the VM to a halt, returning the single value from r0.
+ * Bring the VM to a halt, returning the single value from slot 1.
*/
VM_DEFINE_OP (0, halt, "halt", OP1 (U8_X24))
{
- SCM ret = LOCAL_REF (0);
+ SCM ret = LOCAL_REF (1);
vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
@@ -953,20 +954,18 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
/* halt/values _:24
*
- * Bring the VM to a halt, returning all the values on the stack.
+ * Bring the VM to a halt, returning all the values from the MV stack.
*/
VM_DEFINE_OP (1, halt_values, "halt/values", OP1 (U8_X24))
{
scm_t_ptrdiff n;
- SCM *base;
SCM ret = SCM_EOL;
SYNC_BEFORE_GC();
- base = fp + 4;
- n = FRAME_LOCALS_COUNT ();
- while (n--)
- ret = scm_cons (base[n], ret);
+ /* Boot closure in r0, empty stack from r1 to r4, values from r5. */
+ for (n = FRAME_LOCALS_COUNT () - 1; n >= 5; n--)
+ ret = scm_cons (LOCAL_REF (n), ret);
vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
@@ -975,38 +974,51 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
return scm_values (ret);
}
- /* call from:24 _:8 proc:24 _:8 nargs:24 arg0:24 0:8 ...
+ /* push-frame from:24 _:8 nargs:24
+ *
+ * Push a frame for a new procedure call starting at FROM.
+ * Reserve stack space for NARGS values in the new frame, including
+ * the procedure.
+ */
+ VM_DEFINE_OP (2, push_frame, "push-frame", OP2 (U8_U24, X8_U24))
+ {
+ scm_t_uint32 from, nargs, new_size, n;
+
+ SCM_UNPACK_RTL_24 (op, from);
+ SCM_UNPACK_RTL_24 (ip[1], nargs);
+
+ new_size = from + 3 + nargs;
+ ALLOC_FRAME (new_size);
+
+ /* FIXME: Elide this initialization? */
+ for (n = from; n < new_size; n++)
+ LOCAL_SET (n, SCM_UNDEFINED);
+
+ NEXT (2);
+ }
+
+ /* call from:24
*
- * Call a procedure. Push a call frame on at FROM, saving the return
- * address and the fp. Parse out NARGS, and push the procedure and
- * arguments. All arguments except for RETURN-LOC are 24-bit values.
- * FROM, PROC, and NARGS are in the upper 24 bits of the words. The
- * ARGN... are in the lower 24 bits, with the upper 8 bits being 0.
+ * Call a procedure. Links a call frame at FROM, saving the return
+ * address and the fp.
*
* The MVRA of the new frame is set to point to the next instruction
* after the end of the `call' instruction. The word following that
* is the RA.
*/
- VM_DEFINE_OP (2, call, "call", OP3 (U8_U24, X8_U24, X8_R24))
+ VM_DEFINE_OP (3, call, "call", OP1 (U8_U24))
{
- scm_t_uint32 from, proc, nargs, n;
+ scm_t_uint32 from;
SCM *old_fp = fp;
SCM_UNPACK_RTL_24 (op, from);
- SCM_UNPACK_RTL_24 (ip[1], proc);
- SCM_UNPACK_RTL_24 (ip[2], nargs);
VM_HANDLE_INTERRUPTS;
- fp = vp->fp = old_fp + from + 4;
+ fp = vp->fp = old_fp + from + 3;
SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 3 + nargs);
- SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 4 + nargs);
- fp[-1] = old_fp[proc];
- ALLOC_FRAME (nargs);
-
- for (n = 0; n < nargs; n++)
- LOCAL_SET (n, old_fp[ip[3 + n]]);
+ SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 1);
+ SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 2);
PUSH_CONTINUATION_HOOK ();
APPLY_HOOK ();
@@ -1027,7 +1039,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* As with `call', the next instruction after the call/values will be
* the MVRA, and the word after that instruction is the RA.
*/
- VM_DEFINE_OP (3, call_values, "call/values", OP2 (U8_U24, X8_U24))
+ VM_DEFINE_OP (4, call_values, "call/values", OP2 (U8_U24, X8_U24))
{
scm_t_uint32 from, proc;
SCM *old_fp = fp;
@@ -1041,7 +1053,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2);
SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 3);
- fp[-1] = old_fp[proc];
+ fp[-1] = old_fp[proc - 1];
PUSH_CONTINUATION_HOOK ();
APPLY_HOOK ();
@@ -1058,7 +1070,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Tail-call a procedure. Requires that all of the arguments have
* already been shuffled into position.
*/
- VM_DEFINE_OP (4, tail_call, "tail-call", OP2 (U8_U24, X8_U24))
+ VM_DEFINE_OP (5, tail_call, "tail-call", OP2 (U8_U24, X8_U24))
{
scm_t_uint32 nargs, proc;
@@ -1070,7 +1082,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
fp[-1] = LOCAL_REF (proc);
/* No need to check for overflow, as the compiler has already
ensured that this frame has enough space. */
- RESET_FRAME (nargs);
+ RESET_FRAME (nargs + 1);
APPLY_HOOK ();
@@ -1085,7 +1097,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Return a value.
*/
- VM_DEFINE_OP (5, return, "return", OP1 (U8_U24))
+ VM_DEFINE_OP (6, return, "return", OP1 (U8_U24))
{
scm_t_uint32 src;
SCM_UNPACK_RTL_24 (op, src);
@@ -1099,11 +1111,11 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* with tail calls, we expect that the NVALUES values have already
* been shuffled down to a contiguous array starting at slot 0.
*/
- VM_DEFINE_OP (6, return_values, "return/values", OP1 (U8_U24))
+ VM_DEFINE_OP (7, return_values, "return/values", OP1 (U8_U24))
{
scm_t_uint32 nargs;
SCM_UNPACK_RTL_24 (op, nargs);
- RESET_FRAME (nargs);
+ RESET_FRAME (nargs + 1);
fp[-1] = rtl_values;
goto op_values;
}
@@ -1122,7 +1134,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* calling frame. This instruction is part of the trampolines
* created in gsubr.c, and is not generated by the compiler.
*/
- VM_DEFINE_OP (7, subr_call, "subr-call", OP1 (U8_U24))
+ VM_DEFINE_OP (8, subr_call, "subr-call", OP1 (U8_U24))
{
scm_t_uint32 ptr_idx;
SCM pointer, ret;
@@ -1130,7 +1142,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
SCM_UNPACK_RTL_24 (op, ptr_idx);
- pointer = FREE_VARIABLE_REF (ptr_idx);
+ pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx);
subr = SCM_POINTER_VALUE (pointer);
VM_HANDLE_INTERRUPTS;
@@ -1192,15 +1204,16 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* part of the trampolines created by the FFI, and is not generated by
* the compiler.
*/
- VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (9, foreign_call, "foreign-call", OP1 (U8_U12_U12))
{
scm_t_uint16 cif_idx, ptr_idx;
- SCM cif, pointer, ret;
+ SCM closure, cif, pointer, ret;
SCM_UNPACK_RTL_12_12 (op, cif_idx, ptr_idx);
- cif = FREE_VARIABLE_REF (cif_idx);
- pointer = FREE_VARIABLE_REF (ptr_idx);
+ closure = LOCAL_REF (0);
+ cif = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, cif_idx);
+ pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx);
SYNC_IP ();
VM_HANDLE_INTERRUPTS;
@@ -1225,14 +1238,15 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* the implementation of undelimited continuations, and is not
* generated by the compiler.
*/
- VM_DEFINE_OP (9, continuation_call, "continuation-call", OP1 (U8_U24))
+ VM_DEFINE_OP (10, continuation_call, "continuation-call", OP1 (U8_U24))
{
SCM contregs;
scm_t_uint32 contregs_idx;
SCM_UNPACK_RTL_24 (op, contregs_idx);
- contregs = FREE_VARIABLE_REF (contregs_idx);
+ contregs =
+ SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx);
SYNC_IP ();
scm_i_check_continuation (contregs);
@@ -1253,7 +1267,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* instruction is part of the implementation of partial continuations,
* and is not generated by the compiler.
*/
- VM_DEFINE_OP (10, compose_continuation, "compose-continuation", OP1 (U8_U24))
+ VM_DEFINE_OP (11, compose_continuation, "compose-continuation", OP1 (U8_U24))
{
SCM vmcont;
scm_t_uint32 cont_idx;
@@ -1277,7 +1291,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* arguments. This instruction is part of the implementation of
* `apply', and is not generated by the compiler.
*/
- VM_DEFINE_OP (11, apply, "apply", OP1 (U8_X24))
+ VM_DEFINE_OP (12, apply, "apply", OP1 (U8_X24))
{
int i, list_idx, list_len, nargs;
SCM list;
@@ -1296,15 +1310,15 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
ALLOC_FRAME (nargs);
for (i = 0; i < list_idx; i++)
- fp[i - 1] = fp[i];
+ LOCAL_SET(i - 1, LOCAL_REF (i));
/* Null out these slots, just in case there are less than 2 elements
in the list. */
- fp[list_idx - 1] = SCM_UNDEFINED;
- fp[list_idx] = SCM_UNDEFINED;
+ LOCAL_SET (list_idx - 1, SCM_UNDEFINED);
+ LOCAL_SET (list_idx, SCM_UNDEFINED);
for (i = 0; i < list_len; i++, list = SCM_CDR (list))
- fp[list_idx - 1 + i] = SCM_CAR (list);
+ LOCAL_SET (list_idx - 1 + i, SCM_CAR (list));
APPLY_HOOK ();
@@ -1321,7 +1335,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* local slot 0 to it. This instruction is part of the implementation
* of `call/cc', and is not generated by the compiler.
*/
- VM_DEFINE_OP (12, call_cc, "call/cc", OP1 (U8_X24))
+ VM_DEFINE_OP (13, call_cc, "call/cc", OP1 (U8_X24))
#if 0
{
SCM vm_cont, cont;
@@ -1342,7 +1356,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
fp[-1] = fp[0];
fp[0] = cont;
- RESET_FRAME (1);
+ RESET_FRAME (2);
APPLY_HOOK ();
@@ -1362,11 +1376,11 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* This instruction is part of the implementation of
* `values', and is not generated by the compiler.
*/
- VM_DEFINE_OP (13, values, "values", OP1 (U8_X24))
+ VM_DEFINE_OP (14, values, "values", OP1 (U8_X24))
{
SCM *base = fp;
#if VM_USE_HOOKS
- int nargs = FRAME_LOCALS_COUNT ();
+ int nargs = FRAME_LOCALS_COUNT () - 1;
#endif
/* We don't do much; it's the caller that's responsible for
@@ -1402,15 +1416,15 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
* the current instruction pointer.
*/
- VM_DEFINE_OP (14, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
+ VM_DEFINE_OP (15, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
{
BR_NARGS (!=);
}
- VM_DEFINE_OP (15, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
+ VM_DEFINE_OP (16, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
{
BR_NARGS (<);
}
- VM_DEFINE_OP (16, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
+ VM_DEFINE_OP (17, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
{
BR_NARGS (>);
}
@@ -1422,7 +1436,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the number of actual arguments is not ==, >=, or <= EXPECTED,
* respectively, signal an error.
*/
- VM_DEFINE_OP (17, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
+ VM_DEFINE_OP (18, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
@@ -1430,7 +1444,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
NEXT (1);
}
- VM_DEFINE_OP (18, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
+ VM_DEFINE_OP (19, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
@@ -1438,7 +1452,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
NEXT (1);
}
- VM_DEFINE_OP (19, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
+ VM_DEFINE_OP (20, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
@@ -1451,9 +1465,9 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Ensure that there is space on the stack for NLOCALS local variables,
* setting them all to SCM_UNDEFINED, except those nargs values that
- * were passed as arguments.
+ * were passed as arguments and procedure.
*/
- VM_DEFINE_OP (20, reserve_locals, "reserve-locals", OP1 (U8_U24))
+ VM_DEFINE_OP (21, reserve_locals, "reserve-locals", OP1 (U8_U24))
{
scm_t_uint32 nlocals, nargs;
SCM_UNPACK_RTL_24 (op, nlocals);
@@ -1471,7 +1485,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
* number of locals reserved is EXPECTED + NLOCALS.
*/
- VM_DEFINE_OP (21, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1
(U8_U12_U12))
+ VM_DEFINE_OP (22, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1
(U8_U12_U12))
{
scm_t_uint16 expected, nlocals;
SCM_UNPACK_RTL_12_12 (op, expected, nlocals);
@@ -1496,7 +1510,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* A macro-mega-instruction.
*/
- VM_DEFINE_OP (22, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24,
N32))
+ VM_DEFINE_OP (23, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24,
N32))
{
scm_t_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n, nargs;
scm_t_int32 kw_offset;
@@ -1582,7 +1596,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Collect any arguments at or above DST into a list, and store that
* list at DST.
*/
- VM_DEFINE_OP (23, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (24, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst, nargs;
SCM rest = SCM_EOL;
@@ -1608,7 +1622,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Reset the stack pointer to only have space for NLOCALS values.
* Used after extracting values from an MV return.
*/
- VM_DEFINE_OP (24, drop_values, "drop-values", OP1 (U8_U24))
+ VM_DEFINE_OP (25, drop_values, "drop-values", OP1 (U8_U24))
{
scm_t_bits nlocals;
@@ -1631,7 +1645,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Add OFFSET, a signed 24-bit number, to the current instruction
* pointer.
*/
- VM_DEFINE_OP (25, br, "br", OP1 (U8_L24))
+ VM_DEFINE_OP (26, br, "br", OP1 (U8_L24))
{
scm_t_int32 offset = op;
offset >>= 8; /* Sign-extending shift. */
@@ -1643,7 +1657,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is true for the purposes of Scheme, add
* OFFSET, a signed 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (26, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (27, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_true (x));
}
@@ -1653,7 +1667,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
* signed 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (27, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (28, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_null (x));
}
@@ -1663,7 +1677,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
* number, to the current instruction pointer.
*/
- VM_DEFINE_OP (28, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (29, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_lisp_false (x));
}
@@ -1673,7 +1687,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
* to the current instruction pointer.
*/
- VM_DEFINE_OP (29, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (30, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_pair (x));
}
@@ -1683,7 +1697,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is a struct, add OFFSET, a signed 24-bit
* number, to the current instruction pointer.
*/
- VM_DEFINE_OP (30, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (31, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_STRUCTP (x));
}
@@ -1693,7 +1707,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is a char, add OFFSET, a signed 24-bit number,
* to the current instruction pointer.
*/
- VM_DEFINE_OP (31, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (32, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_CHARP (x));
}
@@ -1703,7 +1717,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST has the TC7 given in the second word, add
* OFFSET, a signed 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (32, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
+ VM_DEFINE_OP (33, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
{
BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f));
}
@@ -1713,7 +1727,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is eq? to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (33, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (34, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y, scm_is_eq (x, y));
}
@@ -1723,7 +1737,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is eqv? to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (34, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (35, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
@@ -1737,7 +1751,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* 24-bit number, to the current instruction pointer.
*/
// FIXME: should sync_ip before calling out?
- VM_DEFINE_OP (35, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (36, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
@@ -1750,7 +1764,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is = to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (36, br_if_ee, "br-if-=", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (37, br_if_ee, "br-if-=", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (==, scm_num_eq_p);
}
@@ -1760,7 +1774,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is < to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (37, br_if_lt, "br-if-<", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (38, br_if_lt, "br-if-<", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (<, scm_less_p);
}
@@ -1770,7 +1784,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is <= to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (38, br_if_le, "br-if-<=", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (39, br_if_le, "br-if-<=", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (<=, scm_leq_p);
}
@@ -1780,7 +1794,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is > to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (39, br_if_gt, "br-if->", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (40, br_if_gt, "br-if->", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (>, scm_gr_p);
}
@@ -1790,7 +1804,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is >= to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (40, br_if_ge, "br-if->=", OP2 (U8_U12_U12, X8_L24))
+ VM_DEFINE_OP (41, br_if_ge, "br-if->=", OP2 (U8_U12_U12, X8_L24))
{
BR_ARITHMETIC (>=, scm_geq_p);
}
@@ -1806,7 +1820,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Copy a value from one local slot to another.
*/
- VM_DEFINE_OP (41, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (42, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst;
scm_t_uint16 src;
@@ -1821,7 +1835,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Copy a value from one local slot to another.
*/
- VM_DEFINE_OP (42, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
+ VM_DEFINE_OP (43, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
{
scm_t_uint32 dst;
scm_t_uint32 src;
@@ -1837,7 +1851,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Create a new variable holding SRC, and place it in DST.
*/
- VM_DEFINE_OP (43, box, "box", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (44, box, "box", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -1851,7 +1865,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* general implementation of `letrec', in those cases that fix-letrec
* fails to fix.
*/
- VM_DEFINE_OP (44, empty_box, "empty-box", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (45, empty_box, "empty-box", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst;
SCM_UNPACK_RTL_24 (op, dst);
@@ -1864,7 +1878,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Unpack the variable at SRC into DST, asserting that the variable is
* actually bound.
*/
- VM_DEFINE_OP (45, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (46, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM var;
@@ -1887,7 +1901,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the contents of the variable at DST to SET.
*/
- VM_DEFINE_OP (46, box_set, "box-set!", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (47, box_set, "box-set!", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM var;
@@ -1898,27 +1912,14 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (1);
}
- /* free-ref dst:12 src:12
- *
- * Load free variable SRC into local slot DST.
- */
- VM_DEFINE_OP (47, free_ref, "free-ref", OP1 (U8_U12_U12) | OP_DST)
- {
- scm_t_uint16 dst, src;
- SCM_UNPACK_RTL_12_12 (op, dst, src);
- CHECK_FREE_VARIABLE (src);
- LOCAL_SET (dst, FREE_VARIABLE_REF (src));
- NEXT (1);
- }
-
- /* make-closure dst:24 offset:32 _:8 nfree:24 free0:24 0:8 ...
+ /* make-closure dst:24 offset:32 _:8 nfree:24
*
* Make a new closure, and write it to DST. The code for the closure
* will be found at OFFSET words from the current IP. OFFSET is a
- * signed 32-bit integer. The registers for the NFREE free variables
- * follow.
+ * signed 32-bit integer. Space for NFREE free variables will be
+ * allocated.
*/
- VM_DEFINE_OP (48, make_closure, "make-closure", OP3 (U8_U24, L32, X8_R24) |
OP_DST)
+ VM_DEFINE_OP (48, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) |
OP_DST)
{
scm_t_uint32 dst, nfree, n;
scm_t_int32 offset;
@@ -1931,31 +1932,41 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
// FIXME: Assert range of nfree?
closure = scm_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2);
SCM_SET_CELL_WORD_1 (closure, ip + offset);
+ // FIXME: Elide these initializations?
for (n = 0; n < nfree; n++)
- SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, LOCAL_REF (ip[n + 3]));
+ SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, SCM_BOOL_F);
LOCAL_SET (dst, closure);
- NEXT (nfree + 3);
+ NEXT (3);
}
- /* fix-closure dst:24 _:8 nfree:24 free0:24 0:8 ...
+ /* free-ref dst:12 src:12 _:8 idx:24
*
- * "Fix" a closure. This is used for lambda expressions bound in a
- * <fix>, but which are not always called in tail position. In that
- * case we allocate the closures first, then destructively update their
- * free variables to point to each other. NFREE and the locals FREE0...
- * are as in make-closure.
+ * Load free variable IDX from the closure SRC into local slot DST.
*/
- VM_DEFINE_OP (49, fix_closure, "fix-closure", OP2 (U8_U24, X8_R24))
+ VM_DEFINE_OP (49, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
{
- scm_t_uint32 dst, nfree, n;
- SCM closure;
+ scm_t_uint16 dst, src;
+ scm_t_uint32 idx;
+ SCM_UNPACK_RTL_12_12 (op, dst, src);
+ SCM_UNPACK_RTL_24 (ip[1], idx);
+ /* CHECK_FREE_VARIABLE (src); */
+ LOCAL_SET (dst, SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src),
idx));
+ NEXT (2);
+ }
- SCM_UNPACK_RTL_24 (op, dst);
- SCM_UNPACK_RTL_24 (ip[1], nfree);
- closure = LOCAL_REF (dst);
- for (n = 0; n < nfree; n++)
- SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, LOCAL_REF (ip[n + 2]));
- NEXT (nfree + 2);
+ /* free-set! dst:12 src:12 _8 idx:24
+ *
+ * Set free variable IDX from the closure DST to SRC.
+ */
+ VM_DEFINE_OP (50, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
+ {
+ scm_t_uint16 dst, src;
+ scm_t_uint32 idx;
+ SCM_UNPACK_RTL_12_12 (op, dst, src);
+ SCM_UNPACK_RTL_24 (ip[1], idx);
+ /* CHECK_FREE_VARIABLE (src); */
+ SCM_RTL_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst), idx, LOCAL_REF
(src));
+ NEXT (2);
}
@@ -1970,7 +1981,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Make an immediate whose low bits are LOW-BITS, and whose top bits are
* 0.
*/
- VM_DEFINE_OP (50, make_short_immediate, "make-short-immediate", OP1
(U8_U8_I16) | OP_DST)
+ VM_DEFINE_OP (51, make_short_immediate, "make-short-immediate", OP1
(U8_U8_I16) | OP_DST)
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -1985,7 +1996,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Make an immediate whose low bits are LOW-BITS, and whose top bits are
* 0.
*/
- VM_DEFINE_OP (51, make_long_immediate, "make-long-immediate", OP2 (U8_U24,
I32))
+ VM_DEFINE_OP (52, make_long_immediate, "make-long-immediate", OP2 (U8_U24,
I32))
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -2000,7 +2011,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Make an immediate with HIGH-BITS and LOW-BITS.
*/
- VM_DEFINE_OP (52, make_long_long_immediate, "make-long-long-immediate", OP3
(U8_U24, A32, B32) | OP_DST)
+ VM_DEFINE_OP (53, make_long_long_immediate, "make-long-long-immediate", OP3
(U8_U24, A32, B32) | OP_DST)
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -2031,7 +2042,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Whether the object is mutable or immutable depends on where it was
* allocated by the compiler, and loaded by the loader.
*/
- VM_DEFINE_OP (53, make_non_immediate, "make-non-immediate", OP2 (U8_U24,
N32) | OP_DST)
+ VM_DEFINE_OP (54, make_non_immediate, "make-non-immediate", OP2 (U8_U24,
N32) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 offset;
@@ -2060,7 +2071,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* that the compiler is unable to statically allocate, like symbols.
* These values would be initialized when the object file loads.
*/
- VM_DEFINE_OP (54, static_ref, "static-ref", OP2 (U8_U24, S32))
+ VM_DEFINE_OP (55, static_ref, "static-ref", OP2 (U8_U24, S32))
{
scm_t_uint32 dst;
scm_t_int32 offset;
@@ -2083,7 +2094,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Store a SCM value into memory, OFFSET 32-bit words away from the
* current instruction pointer. OFFSET is a signed value.
*/
- VM_DEFINE_OP (55, static_set, "static-set!", OP2 (U8_U24, LO32))
+ VM_DEFINE_OP (56, static_set, "static-set!", OP2 (U8_U24, LO32))
{
scm_t_uint32 src;
scm_t_int32 offset;
@@ -2105,7 +2116,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* words away from the current instruction pointer. OFFSET is a
* signed value.
*/
- VM_DEFINE_OP (56, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
+ VM_DEFINE_OP (57, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
{
scm_t_uint32 src;
scm_t_int32 offset;
@@ -2166,7 +2177,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the current module in DST.
*/
- VM_DEFINE_OP (57, current_module, "current-module", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (58, current_module, "current-module", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst;
@@ -2182,7 +2193,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Resolve SYM in MOD, and place the resulting variable in DST.
*/
- VM_DEFINE_OP (58, resolve, "resolve", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (59, resolve, "resolve", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, mod, sym;
@@ -2200,7 +2211,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* nonzero, resolve the public interface, otherwise use the private
* interface.
*/
- VM_DEFINE_OP (59, resolve_module, "resolve-module", OP1 (U8_U8_U8_U8) |
OP_DST)
+ VM_DEFINE_OP (60, resolve_module, "resolve-module", OP1 (U8_U8_U8_U8) |
OP_DST)
{
scm_t_uint8 dst, name, public;
SCM mod;
@@ -2221,7 +2232,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Look up a binding for SYM in the current module, creating it if
* necessary. Set its value to VAL.
*/
- VM_DEFINE_OP (60, define, "define", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (61, define, "define", OP1 (U8_U12_U12))
{
scm_t_uint16 sym, val;
SCM_UNPACK_RTL_12_12 (op, sym, val);
@@ -2249,7 +2260,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* an error if it is unbound, unbox it into DST, and cache the
* resolved variable so that we will hit the cache next time.
*/
- VM_DEFINE_OP (61, toplevel_ref, "toplevel-ref", OP4 (U8_U24, S32, S32, N32)
| OP_DST)
+ VM_DEFINE_OP (62, toplevel_ref, "toplevel-ref", OP4 (U8_U24, S32, S32, N32)
| OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2295,7 +2306,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Set a top-level variable from a variable cache cell. The variable
* is resolved as in toplevel-ref.
*/
- VM_DEFINE_OP (62, toplevel_set, "toplevel-set!", OP4 (U8_U24, S32, S32, N32))
+ VM_DEFINE_OP (63, toplevel_set, "toplevel-set!", OP4 (U8_U24, S32, S32, N32))
{
scm_t_uint32 src;
scm_t_int32 var_offset;
@@ -2340,7 +2351,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Like toplevel-ref, except MOD-OFFSET points at the name of a module
* instead of the module itself.
*/
- VM_DEFINE_OP (63, module_ref, "module-ref", OP4 (U8_U24, S32, N32, N32) |
OP_DST)
+ VM_DEFINE_OP (64, module_ref, "module-ref", OP4 (U8_U24, S32, N32, N32) |
OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2390,7 +2401,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Like toplevel-set!, except MOD-OFFSET points at the name of a module
* instead of the module itself.
*/
- VM_DEFINE_OP (64, module_set, "module-set!", OP4 (U8_U24, S32, N32, N32))
+ VM_DEFINE_OP (65, module_set, "module-set!", OP4 (U8_U24, S32, N32, N32))
{
scm_t_uint32 src;
scm_t_int32 var_offset;
@@ -2445,7 +2456,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* handler at HANDLER-OFFSET words from the current IP. The handler
* will expect a multiple-value return.
*/
- VM_DEFINE_OP (65, prompt, "prompt", OP2 (U8_U24, U8_L24))
+ VM_DEFINE_OP (66, prompt, "prompt", OP2 (U8_U24, U8_L24))
#if 0
{
scm_t_uint32 tag;
@@ -2477,7 +2488,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* the compiler should have inserted checks that they wind and unwind
* procs are thunks, if it could not prove that to be the case.
*/
- VM_DEFINE_OP (66, wind, "wind", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (67, wind, "wind", OP1 (U8_U12_U12))
{
scm_t_uint16 winder, unwinder;
SCM_UNPACK_RTL_12_12 (op, winder, unwinder);
@@ -2486,22 +2497,24 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (1);
}
- /* abort tag:24 _:8 nvalues:24 val0:24 0:8 val1:24 0:8 ...
+ /* abort tag:24 _:8 from:24
*
- * Return a number of values to a prompt handler. The values VAL0,
- * VAL1, etc are 24-bit values, in the lower 24 bits of their words.
- * The upper 8 bits are 0.
+ * Return a number of values to a prompt handler. The values are
+ * expected in a frame pushed on at FROM.
*/
- VM_DEFINE_OP (67, abort, "abort", OP2 (U8_U24, X8_R24))
+ VM_DEFINE_OP (68, abort, "abort", OP2 (U8_U24, X8_U24))
#if 0
{
- scm_t_uint32 tag, nvalues;
+ scm_t_uint32 tag, from, nvalues;
+ SCM *base;
SCM_UNPACK_RTL_24 (op, tag);
- SCM_UNPACK_RTL_24 (ip[1], nvalues);
+ SCM_UNPACK_RTL_24 (ip[1], from);
+ base = (fp - 1) + from + 3;
+ nvalues = FRAME_LOCALS_COUNT () - from - 3;
SYNC_IP ();
- vm_abort (vm, LOCAL_REF (tag), nvalues, &ip[2], ®isters);
+ vm_abort (vm, LOCAL_REF (tag), base, nvalues, ®isters);
/* vm_abort should not return */
abort ();
@@ -2515,7 +2528,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* A normal exit from the dynamic extent of an expression. Pop the top
* entry off of the dynamic stack.
*/
- VM_DEFINE_OP (68, unwind, "unwind", OP1 (U8_X24))
+ VM_DEFINE_OP (69, unwind, "unwind", OP1 (U8_X24))
{
scm_dynstack_pop (¤t_thread->dynstack);
NEXT (1);
@@ -2527,7 +2540,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* allocated in a continguous range on the stack, starting from
* FLUID-BASE. The values do not have this restriction.
*/
- VM_DEFINE_OP (69, push_fluid, "push-fluid", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (70, push_fluid, "push-fluid", OP1 (U8_U12_U12))
{
scm_t_uint32 fluid, value;
@@ -2544,7 +2557,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Leave the dynamic extent of a with-fluids expression, restoring the
* fluids to their previous values.
*/
- VM_DEFINE_OP (70, pop_fluid, "pop-fluid", OP1 (U8_X24))
+ VM_DEFINE_OP (71, pop_fluid, "pop-fluid", OP1 (U8_X24))
{
/* This function must not allocate. */
scm_dynstack_unwind_fluid (¤t_thread->dynstack,
@@ -2556,7 +2569,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Reference the fluid in SRC, and place the value in DST.
*/
- VM_DEFINE_OP (71, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (72, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
size_t num;
@@ -2589,7 +2602,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the value of the fluid in DST to the value in SRC.
*/
- VM_DEFINE_OP (72, fluid_set, "fluid-set", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (73, fluid_set, "fluid-set", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
size_t num;
@@ -2622,7 +2635,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the length of the string in SRC in DST.
*/
- VM_DEFINE_OP (73, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (74, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (str);
if (SCM_LIKELY (scm_is_string (str)))
@@ -2639,7 +2652,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Fetch the character at position IDX in the string in SRC, and store
* it in DST.
*/
- VM_DEFINE_OP (74, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (75, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (str, idx);
@@ -2661,7 +2674,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Parse a string in SRC to a number, and store in DST.
*/
- VM_DEFINE_OP (75, string_to_number, "string->number", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (76, string_to_number, "string->number", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
@@ -2677,7 +2690,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Parse a string in SRC to a symbol, and store in DST.
*/
- VM_DEFINE_OP (76, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (77, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
@@ -2691,7 +2704,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Make a keyword from the symbol in SRC, and store it in DST.
*/
- VM_DEFINE_OP (77, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (78, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -2710,7 +2723,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Cons CAR and CDR, and store the result in DST.
*/
- VM_DEFINE_OP (78, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (79, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
RETURN (scm_cons (x, y));
@@ -2720,7 +2733,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the car of SRC in DST.
*/
- VM_DEFINE_OP (79, car, "car", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (80, car, "car", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "car");
@@ -2731,7 +2744,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the cdr of SRC in DST.
*/
- VM_DEFINE_OP (80, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (81, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "cdr");
@@ -2742,7 +2755,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the car of DST to SRC.
*/
- VM_DEFINE_OP (81, set_car, "set-car!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (82, set_car, "set-car!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2758,7 +2771,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the cdr of DST to SRC.
*/
- VM_DEFINE_OP (82, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (83, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2781,7 +2794,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Add A to B, and place the result in DST.
*/
- VM_DEFINE_OP (83, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (84, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (+, scm_sum);
}
@@ -2790,7 +2803,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Add 1 to the value in SRC, and place the result in DST.
*/
- VM_DEFINE_OP (84, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (85, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2816,7 +2829,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Subtract B from A, and place the result in DST.
*/
- VM_DEFINE_OP (85, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (86, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (-, scm_difference);
}
@@ -2825,7 +2838,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Subtract 1 from SRC, and place the result in DST.
*/
- VM_DEFINE_OP (86, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (87, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2851,7 +2864,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Multiply A and B, and place the result in DST.
*/
- VM_DEFINE_OP (87, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (88, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2862,7 +2875,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Divide A by B, and place the result in DST.
*/
- VM_DEFINE_OP (88, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (89, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2873,7 +2886,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Divide A by B, and place the quotient in DST.
*/
- VM_DEFINE_OP (89, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (90, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2884,7 +2897,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Divide A by B, and place the remainder in DST.
*/
- VM_DEFINE_OP (90, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (91, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2895,7 +2908,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the modulo of A by B in DST.
*/
- VM_DEFINE_OP (91, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (92, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2906,7 +2919,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Shift A arithmetically by B bits, and place the result in DST.
*/
- VM_DEFINE_OP (92, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (93, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2939,7 +2952,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the bitwise AND of A and B into DST.
*/
- VM_DEFINE_OP (93, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (94, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2952,7 +2965,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the bitwise inclusive OR of A with B in DST.
*/
- VM_DEFINE_OP (94, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (95, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2965,7 +2978,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the bitwise exclusive OR of A with B in DST.
*/
- VM_DEFINE_OP (95, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (96, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2978,7 +2991,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 (96, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (97, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
@@ -2995,7 +3008,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 (97, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (98, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
@@ -3016,7 +3029,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Fill DST with the item IDX elements into the vector at SRC. Useful
* for building data types using vectors.
*/
- VM_DEFINE_OP (98, constant_vector_ref, "constant-vector-ref", OP1
(U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (99, constant_vector_ref, "constant-vector-ref", OP1
(U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM v;
@@ -3035,7 +3048,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 (99, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (100, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx_var, src;
SCM vect, idx, val;
@@ -3070,64 +3083,39 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* 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");
RETURN (SCM_STRUCT_VTABLE (obj));
}
- /* make-struct dst:12 vtable:12 _:8 n-init:24 init0:24 0:8 ...
+ /* allocate-struct dst:8 vtable:8 nfields:8
*
- * Make a new struct with VTABLE, and place it in DST. The struct
- * will be constructed with N-INIT initializers, which are located in
- * the locals given by INIT0.... The format of INIT0... is as in the
- * "call" opcode: unsigned 24-bit values, with 0 in the high byte.
+ * 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 (101, make_struct, "make-struct", OP2 (U8_U12_U12, X8_R24))
-#if 0
+ VM_DEFINE_OP (102, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) |
OP_DST)
{
- scm_t_uint16 dst, vtable_r;
- scm_t_uint32 n_init, n;
- SCM vtable, ret;
+ scm_t_uint8 dst, vtable, nfields;
+ SCM ret;
- SCM_UNPACK_RTL_12_12 (op, dst, vtable_r);
- vtable = LOCAL_REF (vtable_r);
- SCM_UNPACK_RTL_24 (ip[1], n_init);
+ SCM_UNPACK_RTL_8_8_8 (op, dst, vtable, nfields);
SYNC_IP ();
-
- if (SCM_LIKELY (SCM_STRUCTP (vtable)
- && SCM_VTABLE_FLAG_IS_SET (vtable,
SCM_VTABLE_FLAG_SIMPLE)
- && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)
- == n_init)
- && !SCM_VTABLE_INSTANCE_FINALIZER (vtable)))
- {
- /* Verily, we are making a simple struct with the right number of
- initializers, and no finalizer. */
- ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) |
scm_tc3_struct,
- n_init + 2);
- SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
-
- for (n = 0; n < n_init; n++)
- SCM_STRUCT_DATA (ret)[n] = SCM_UNPACK (LOCAL_REF (ip[n + 1]));
- }
- else
- ret = scm_c_make_structvs (vtable, fp, &ip[1], n_init);
-
+ ret = scm_allocate_struct (LOCAL_REF (vtable), SCM_I_MAKINUM (nfields));
LOCAL_SET (dst, ret);
- NEXT (n_init + 1);
+
+ NEXT (1);
}
-#else
- abort ();
-#endif
/* struct-ref dst:8 src:8 idx:8
*
* Fetch the item at slot IDX in the struct in SRC, and store it
* in DST.
*/
- VM_DEFINE_OP (102, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (103, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (obj, pos);
@@ -3161,7 +3149,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store SRC into the struct DST at slot IDX.
*/
- VM_DEFINE_OP (103, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (104, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM obj, pos, val;
@@ -3202,7 +3190,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* 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))
@@ -3217,7 +3205,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 (105, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (106, 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);
@@ -3231,7 +3219,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 (106, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (107, 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);
@@ -3252,7 +3240,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 (107, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8,
N32, U32) | OP_DST)
+ VM_DEFINE_OP (108, 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;
@@ -3272,7 +3260,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 (108, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (109, 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);
@@ -3370,42 +3358,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 (109, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (110, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
- VM_DEFINE_OP (110, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (111, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s8, s8, int8, 1);
- VM_DEFINE_OP (111, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (112, 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 (112, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (113, 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 (113, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (114, 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 (114, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (115, 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 (115, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (116, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (u64, uint64, 8);
- VM_DEFINE_OP (116, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (117, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (s64, int64, 8);
- VM_DEFINE_OP (117, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (118, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f32, ieee_single, float, 4);
- VM_DEFINE_OP (118, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (119, 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
@@ -3509,42 +3497,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (1); \
} while (0)
- VM_DEFINE_OP (119, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (120, 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 (120, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (121, 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 (121, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (122, 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 (122, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (123, 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 (123, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (124, 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 (124, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (125, 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 (125, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (126, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (u64, uint64, 8);
- VM_DEFINE_OP (126, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (127, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (s64, int64, 8);
- VM_DEFINE_OP (127, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (128, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f32, ieee_single, float, 4);
- VM_DEFINE_OP (128, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (129, 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/libguile/vm.c b/libguile/vm.c
index dd016b7..e87420b 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -599,8 +599,8 @@ static SCM rtl_apply;
static SCM rtl_values;
static const scm_t_uint32 rtl_boot_continuation_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_halt_values, 0), /* empty stack frame in r0-r2,
results from r3 */
- SCM_PACK_RTL_24 (scm_rtl_op_halt, 0) /* result in r0 */
+ SCM_PACK_RTL_24 (scm_rtl_op_halt_values, 0),
+ SCM_PACK_RTL_24 (scm_rtl_op_halt, 0)
};
static scm_t_uint32* rtl_boot_multiple_value_continuation_code =
@@ -610,11 +610,11 @@ static scm_t_uint32*
rtl_boot_single_value_continuation_code =
(scm_t_uint32 *) rtl_boot_continuation_code + 1;
static const scm_t_uint32 rtl_apply_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_apply, 0) /* proc in r0, args from r1, nargs set
*/
+ SCM_PACK_RTL_24 (scm_rtl_op_apply, 0) /* proc in r1, args from r2, nargs set
*/
};
static const scm_t_uint32 rtl_values_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_values, 0) /* vals from r0 */
+ SCM_PACK_RTL_24 (scm_rtl_op_values, 0) /* vals from r1 */
};
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 39d313f..8bf7248 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1189,6 +1189,16 @@ VALUE."
+;;; {IOTA functions: generating lists of numbers}
+;;;
+
+(define (iota n)
+ (let loop ((count (1- n)) (result '()))
+ (if (< count 0) result
+ (loop (1- count) (cons count result)))))
+
+
+
;;; {Structs}
;;;
@@ -1253,10 +1263,14 @@ VALUE."
#,@(let lp ((n 0))
(if (< n *max-static-argument-count*)
(cons (with-syntax (((formal ...) (make-formals n))
+ ((idx ...) (iota n))
(n n))
#'((n)
(lambda (formal ...)
- (make-struct rtd 0 formal ...))))
+ (let ((s (allocate-struct rtd n)))
+ (struct-set! s idx formal)
+ ...
+ s))))
(lp (1+ n)))
'()))
(else
@@ -2211,14 +2225,21 @@ written into the port is returned."
(cons #'f (field-list #'rest)))))
(define (constructor rtd type-name fields exp)
- (let ((ctor (make-id rtd type-name '-constructor))
- (args (field-list fields)))
+ (let* ((ctor (make-id rtd type-name '-constructor))
+ (args (field-list fields))
+ (n (length fields))
+ (slots (iota n)))
(predicate rtd type-name fields
#`(begin #,exp
(define #,ctor
(let ((rtd #,rtd))
(lambda #,args
- (make-struct rtd 0 #,@args))))
+ (let ((s (allocate-struct rtd #,n)))
+ #,@(map
+ (lambda (arg slot)
+ #`(struct-set! s #,slot #,arg))
+ args slots)
+ s))))
(struct-set! #,rtd (+ vtable-offset-user 2)
#,ctor)))))
@@ -3496,16 +3517,6 @@ but it fails to load."
-;;; {IOTA functions: generating lists of numbers}
-;;;
-
-(define (iota n)
- (let loop ((count (1- n)) (result '()))
- (if (< count 0) result
- (loop (1- count) (cons count result)))))
-
-
-
;;; {While}
;;;
;;; with `continue' and `break'.
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index d213a86..2f092fe 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -1,6 +1,6 @@
;;; srfi-9.scm --- define-record-type
-;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012 Free Software
Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012, 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
@@ -156,7 +156,8 @@
((_ type-name (getter-id ...) check? s (getter expr) ...)
(every identifier? #'(getter ...))
(let ((copier-name (syntax->datum (make-copier-id #'type-name)))
- (getter+exprs #'((getter expr) ...)))
+ (getter+exprs #'((getter expr) ...))
+ (nfields (length #'(getter-id ...))))
(define (lookup id default-expr)
(let ((results
(filter (lambda (g+e)
@@ -175,12 +176,16 @@
copier-name "unknown getter" x id)))
#'(getter ...))
(with-syntax ((unsafe-expr
- #`(make-struct
- type-name 0
- #,@(map (lambda (getter index)
- (lookup getter #`(struct-ref s #,index)))
- #'(getter-id ...)
- (iota (length #'(getter-id ...)))))))
+ #`(let ((new (allocate-struct type-name #,nfields)))
+ #,@(map (lambda (getter index)
+ #`(struct-set!
+ new
+ #,index
+ #,(lookup getter
+ #`(struct-ref s #,index))))
+ #'(getter-id ...)
+ (iota nfields))
+ new)))
(if (syntax->datum #'check?)
#`(if (eq? (struct-vtable s) type-name)
unsafe-expr
@@ -204,26 +209,27 @@
((name getter setter) #'getter)))
field-specs))
- (define (constructor form type-name constructor-spec field-names)
+ (define (constructor form type-name constructor-spec field-ids)
(syntax-case constructor-spec ()
((ctor field ...)
(every identifier? #'(field ...))
- (let ((ctor-args (map (lambda (field)
- (let ((name (syntax->datum field)))
- (or (memq name field-names)
- (syntax-violation
- (syntax-case form ()
- ((macro . args)
- (syntax->datum #'macro)))
- "unknown field in constructor spec"
- form field))
- (cons name field)))
- #'(field ...))))
+ (let ((slots (map (lambda (field)
+ (or (list-index (lambda (x)
+ (free-identifier=? x field))
+ field-ids)
+ (syntax-violation
+ (syntax-case form ()
+ ((macro . args)
+ (syntax->datum #'macro)))
+ "unknown field in constructor spec"
+ form field)))
+ #'(field ...))))
#`(define-inlinable #,constructor-spec
- (make-struct #,type-name 0
- #,@(map (lambda (name)
- (assq-ref ctor-args name))
- field-names)))))))
+ (let ((s (allocate-struct #,type-name #,(length field-ids))))
+ #,@(map (lambda (arg slot)
+ #`(struct-set! s #,slot #,arg))
+ #'(field ...) slots)
+ s))))))
(define (getters type-name getter-ids copier-id)
(map (lambda (getter index)
@@ -267,8 +273,9 @@
(iota (length field-specs))))
(define (record-layout immutable? count)
- (let ((desc (if immutable? "pr" "pw")))
- (string-concatenate (make-list count desc))))
+ ;; Mutability is expressed on the record level; all structs in the
+ ;; future will be mutable.
+ (string-concatenate (make-list count "pw")))
(syntax-case x ()
((_ immutable? form type-name constructor-spec predicate-name
@@ -300,12 +307,11 @@
(field-count (length field-ids))
(immutable? (syntax->datum #'immutable?))
(layout (record-layout immutable? field-count))
- (field-names (map syntax->datum field-ids))
(ctor-name (syntax-case #'constructor-spec ()
((ctor args ...) #'ctor)))
(copier-id (make-copier-id #'type-name)))
#`(begin
- #,(constructor #'form #'type-name #'constructor-spec field-names)
+ #,(constructor #'form #'type-name #'constructor-spec field-ids)
(define type-name
(let ((rtd (make-struct/no-tail
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 556f589..1eea3c0 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -351,9 +351,6 @@ later by the linker."
((U8_L24 label)
(record-label-reference asm label)
(emit asm opcode))
- ((U8_R24 rest)
- (emit asm (pack-u8-u24 opcode (list rest)))
- (for-each (lambda (x) (emit asm x)) rest))
((U8_U8_I16 a imm)
(emit asm (pack-u8-u8-u16 opcode a (object-address imm))))
((U8_U12_U12 a b)
@@ -369,9 +366,6 @@ later by the linker."
((U8_L24 a label)
(record-label-reference asm label)
(emit asm a))
- ((U8_R24 rest)
- (emit asm (pack-u8-u24 a (length rest)))
- (for-each (lambda (x) (emit asm x)) rest))
((U8_U8_I16 a b imm)
(emit asm (pack-u8-u8-u16 a b (object-address imm))))
((U8_U12_U12 a b)
@@ -408,9 +402,6 @@ later by the linker."
(emit asm (pack-u8-u24 0 a)))
((X8_U12_U12 a b)
(emit asm (pack-u8-u12-u12 0 a b)))
- ((X8_R24 rest)
- (emit asm (pack-u8-u24 0 (length rest)))
- (for-each (lambda (x) (emit asm x)) rest))
((X8_L24 label)
(record-label-reference asm label)
(emit asm 0))
@@ -443,7 +434,7 @@ later by the linker."
(define-syntax define-assembler
(lambda (x)
(syntax-case x ()
- ((_ name opcode arg ...)
+ ((_ name opcode kind arg ...)
(with-syntax ((emit (id-append #'name #'emit- #'name)))
#'(define emit
(let ((emit (assembler name opcode arg ...)))
@@ -525,9 +516,9 @@ table, its existing label is used directly."
(let ((src (recur obj)))
(if src
(list (if (statically-allocatable? obj)
- `(make-non-immediate 0 ,src)
- `(static-ref 0 ,src))
- `(static-set! 0 ,dst ,n))
+ `(make-non-immediate 1 ,src)
+ `(static-ref 1 ,src))
+ `(static-set! 1 ,dst ,n))
'())))
(define (intern obj label)
(cond
@@ -543,24 +534,24 @@ table, its existing label is used directly."
(reverse inits))))
((stringbuf? obj) '())
((static-procedure? obj)
- `((make-non-immediate 0 ,label)
- (link-procedure! 0 ,(static-procedure-code obj))))
+ `((make-non-immediate 1 ,label)
+ (link-procedure! 1 ,(static-procedure-code obj))))
((cache-cell? obj) '())
((symbol? obj)
- `((make-non-immediate 0 ,(recur (symbol->string obj)))
- (string->symbol 0 0)
- (static-set! 0 ,label 0)))
+ `((make-non-immediate 1 ,(recur (symbol->string obj)))
+ (string->symbol 1 1)
+ (static-set! 1 ,label 0)))
((string? obj)
- `((make-non-immediate 0 ,(recur (make-stringbuf obj)))
- (static-set! 0 ,label 1)))
+ `((make-non-immediate 1 ,(recur (make-stringbuf obj)))
+ (static-set! 1 ,label 1)))
((keyword? obj)
- `((static-ref 0 ,(recur (keyword->symbol obj)))
- (symbol->keyword 0 0)
- (static-set! 0 ,label 0)))
+ `((static-ref 1 ,(recur (keyword->symbol obj)))
+ (symbol->keyword 1 1)
+ (static-set! 1 ,label 0)))
((number? obj)
- `((make-non-immediate 0 ,(recur (number->string obj)))
- (string->number 0 0)
- (static-set! 0 ,label 0)))
+ `((make-non-immediate 1 ,(recur (number->string obj)))
+ (string->number 1 1)
+ (static-set! 1 ,label 0)))
(else
(error "don't know how to intern" obj))))
(cond
@@ -660,7 +651,10 @@ returned instead."
(let* ((meta (car (asm-meta asm)))
(arity (make-arity req opt rest kw-indices allow-other-keys?
(asm-start asm) #f))
- (nreq (length req))
+ ;; The procedure itself is in slot 0, in the standard calling
+ ;; convention. For procedure prologues, nreq includes the
+ ;; procedure, so here we add 1.
+ (nreq (1+ (length req)))
(nopt (length opt))
(rest? (->bool rest)))
(set-meta-arities! meta (cons arity (meta-arities meta)))
@@ -801,10 +795,10 @@ a procedure to do that and return its label. Otherwise
return
(let ((label (gensym "init-constants")))
(emit-text asm
`((begin-program ,label ())
- (assert-nargs-ee/locals 0 1)
+ (assert-nargs-ee/locals 1 1)
,@(reverse inits)
- (load-constant 0 ,*unspecified*)
- (return 0)
+ (load-constant 1 ,*unspecified*)
+ (return 1)
(end-program)))
label))))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index c70f7c5..0e97df5 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -292,10 +292,10 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(let lp ((pos headers-start))
(cond
((>= pos headers-end) #f)
- ((< text-offset (arity-low-pc* bv pos))
- (lp (+ pos arity-header-len)))
- ((< (arity-high-pc* bv pos) text-offset)
+ ((< text-offset (* (arity-low-pc* bv pos) 4))
#f)
+ ((<= (* (arity-high-pc* bv pos) 4) text-offset)
+ (lp (+ pos arity-header-len)))
(else
(make-arity context base pos))))))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index b815c1e..3b95f19 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -78,8 +78,6 @@
#'((ash word -8)))
((U8_L24)
#'((unpack-s24 (ash word -8))))
- ((U8_R24)
- #'(#:rest (ash word -8)))
((U8_U8_I16)
#'((logand (ash word -8) #xff)
(ash word -16)))
@@ -104,9 +102,6 @@
((U8_L24)
#'((logand word #xff)
(unpack-s24 (ash word -8))))
- ((U8_R24)
- #'((logand word #xff)
- #:rest (ash word -8)))
((U8_U8_I16)
#'((logand word #xff)
(logand (ash word -8) #xff)
@@ -141,8 +136,6 @@
((X8_U12_U12)
#'((logand (ash word -8) #xfff)
(ash word -20)))
- ((X8_R24)
- #'(#:rest (ash word -8)))
((X8_L24)
#'((unpack-s24 (ash word -8))))
((B1_X7_L24)
@@ -181,7 +174,7 @@
(define-syntax define-disassembler
(lambda (x)
(syntax-case x ()
- ((_ name opcode arg ...)
+ ((_ name opcode kind arg ...)
(with-syntax ((parse (id-append #'name #'parse- #'name)))
#'(let ((parse (disassembler name opcode arg ...)))
(vector-set! disassemblers opcode parse)))))))
@@ -191,18 +184,7 @@
;; -> len list
(define (disassemble-one buf offset)
(let ((first (u32-ref buf offset)))
- (call-with-values
- (lambda ()
- ((vector-ref disassemblers (logand first #xff)) buf offset first))
- (lambda (len list)
- (match list
- ((head ... #:rest rest)
- (let lp ((n 0) (rhead (reverse head)))
- (if (= n rest)
- (values (+ len n) (reverse rhead))
- (lp (1+ n)
- (cons (u32-ref buf (+ offset len n)) rhead)))))
- (_ (values len list)))))))
+ ((vector-ref disassemblers (logand first #xff)) buf offset first)))
(define (u32-offset->addr offset context)
"Given an offset into an image in 32-bit units, return the absolute
@@ -236,17 +218,19 @@ address of that offset."
(('make-long-long-immediate _ high low)
(list "~S" (unpack-scm (logior (ash high 32) low))))
(('assert-nargs-ee/locals nargs locals)
- (list "~a arg~:p, ~a local~:p" nargs locals))
+ ;; The nargs includes the procedure.
+ (list "~a arg~:p, ~a local~:p" (1- nargs) locals))
(('tail-call nargs proc)
(list "~a arg~:p" nargs))
- (('make-closure dst target free ...)
+ (('make-closure dst target nfree)
(let* ((addr (u32-offset->addr (+ offset target) context))
(pdi (find-program-debug-info addr context)))
;; FIXME: Disassemble embedded closures as well.
- (list "~A at 0x~X"
+ (list "~A at 0x~X (~A free var~:p)"
(or (and pdi (program-debug-info-name pdi))
"(anonymous procedure)")
- addr)))
+ addr
+ nfree)))
(('make-non-immediate dst target)
(list "address@hidden" (reference-scm target)))
(((or 'static-ref 'static-set!) _ target)
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 0e38a8e..ce0a0c2 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -29,9 +29,9 @@
(define (return-constant val)
(assemble-program `((begin-program foo
((name . foo)))
- (begin-standard-arity () 1 #f)
- (load-constant 0 ,val)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 ,val)
+ (return 1)
(end-arity)
(end-program))))
@@ -67,16 +67,16 @@
(assert-equal 42
(((assemble-program `((begin-program foo
((name . foo)))
- (begin-standard-arity () 1 #f)
- (load-static-procedure 0 bar)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 bar)
+ (return 1)
(end-arity)
(end-program)
(begin-program bar
((name . bar)))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program)))))))
@@ -89,19 +89,19 @@
;; 2: accum
'((begin-program countdown
((name . countdown)))
- (begin-standard-arity (x) 3 #f)
+ (begin-standard-arity (x) 4 #f)
(br fix-body)
(label loop-head)
- (br-if-= 1 0 out)
- (add 2 1 2)
- (add1 1 1)
+ (br-if-= 2 1 out)
+ (add 3 2 3)
+ (add1 2 2)
(br loop-head)
(label fix-body)
- (load-constant 1 0)
(load-constant 2 0)
+ (load-constant 3 0)
(br loop-head)
(label out)
- (return 2)
+ (return 3)
(end-arity)
(end-program)))))
(sumto 1000))))
@@ -115,21 +115,22 @@
;; 2: head
'((begin-program make-accum
((name . make-accum)))
- (begin-standard-arity () 2 #f)
- (load-constant 0 0)
- (box 0 0)
- (make-closure 1 accum (0))
- (return 1)
+ (begin-standard-arity () 3 #f)
+ (load-constant 1 0)
+ (box 1 1)
+ (make-closure 2 accum 1)
+ (free-set! 2 1 0)
+ (return 2)
(end-arity)
(end-program)
(begin-program accum
((name . accum)))
- (begin-standard-arity (x) 3 #f)
- (free-ref 1 0)
- (box-ref 2 1)
- (add 2 2 0)
- (box-set! 1 2)
- (return 2)
+ (begin-standard-arity (x) 4 #f)
+ (free-ref 2 0 0)
+ (box-ref 3 2)
+ (add 3 3 1)
+ (box-set! 2 3)
+ (return 3)
(end-arity)
(end-program)))))
(let ((accum (make-accum)))
@@ -143,10 +144,12 @@
(assemble-program
'((begin-program call
((name . call)))
- (begin-standard-arity (f) 1 #f)
- (call 1 0 ())
- (return 1) ;; MVRA from call
- (return 1) ;; RA from call
+ (begin-standard-arity (f) 2 #f)
+ (push-frame 2 1)
+ (mov 5 1)
+ (call 2)
+ (return 2) ;; MVRA from call
+ (return 2) ;; RA from call
(end-arity)
(end-program)))))
(call (lambda () 42))))
@@ -156,9 +159,11 @@
(assemble-program
'((begin-program call-with-3
((name . call-with-3)))
- (begin-standard-arity (f) 2 #f)
- (load-constant 1 3)
- (call 2 0 (1))
+ (begin-standard-arity (f) 3 #f)
+ (push-frame 2 2)
+ (mov 5 1)
+ (load-constant 6 3)
+ (call 2)
(return 2) ;; MVRA from call
(return 2) ;; RA from call
(end-arity)
@@ -171,8 +176,8 @@
(assemble-program
'((begin-program call
((name . call)))
- (begin-standard-arity (f) 1 #f)
- (tail-call 0 0)
+ (begin-standard-arity (f) 2 #f)
+ (tail-call 0 1)
(end-arity)
(end-program)))))
(call (lambda () 3))))
@@ -182,10 +187,10 @@
(assemble-program
'((begin-program call-with-3
((name . call-with-3)))
- (begin-standard-arity (f) 2 #f)
- (mov 1 0) ;; R1 <- R0
- (load-constant 0 3) ;; R0 <- 3
- (tail-call 1 1)
+ (begin-standard-arity (f) 3 #f)
+ (mov 2 1) ;; R1 <- R0
+ (load-constant 1 3) ;; R0 <- 3
+ (tail-call 1 2)
(end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@@ -196,18 +201,18 @@
(assemble-program
'((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
- (begin-standard-arity () 1 #f)
- (cache-current-module! 0 sqrt-scope)
- (load-static-procedure 0 sqrt-trampoline)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (cache-current-module! 1 sqrt-scope)
+ (load-static-procedure 1 sqrt-trampoline)
+ (return 1)
(end-arity)
(end-program)
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
- (begin-standard-arity (x) 2 #f)
- (cached-toplevel-ref 1 sqrt-scope sqrt)
- (tail-call 1 1)
+ (begin-standard-arity (x) 3 #f)
+ (cached-toplevel-ref 2 sqrt-scope sqrt)
+ (tail-call 1 2)
(end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
@@ -221,20 +226,20 @@
(assemble-program
'((begin-program make-top-incrementor
((name . make-top-incrementor)))
- (begin-standard-arity () 1 #f)
- (cache-current-module! 0 top-incrementor)
- (load-static-procedure 0 top-incrementor)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (cache-current-module! 1 top-incrementor)
+ (load-static-procedure 1 top-incrementor)
+ (return 1)
(end-arity)
(end-program)
(begin-program top-incrementor
((name . top-incrementor)))
- (begin-standard-arity () 1 #f)
- (cached-toplevel-ref 0 top-incrementor *top-val*)
- (add1 0 0)
- (cached-toplevel-set! 0 top-incrementor *top-val*)
- (return/values 0)
+ (begin-standard-arity () 2 #f)
+ (cached-toplevel-ref 1 top-incrementor *top-val*)
+ (add1 1 1)
+ (cached-toplevel-set! 1 top-incrementor *top-val*)
+ (return/values 1)
(end-arity)
(end-program)))))
((make-top-incrementor))
@@ -246,17 +251,17 @@
(assemble-program
'((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
- (begin-standard-arity () 1 #f)
- (load-static-procedure 0 sqrt-trampoline)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 sqrt-trampoline)
+ (return 1)
(end-arity)
(end-program)
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
- (begin-standard-arity (x) 2 #f)
- (cached-module-ref 1 (guile) #t sqrt)
- (tail-call 1 1)
+ (begin-standard-arity (x) 3 #f)
+ (cached-module-ref 2 (guile) #t sqrt)
+ (tail-call 1 2)
(end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
@@ -268,19 +273,19 @@
(assemble-program
'((begin-program make-top-incrementor
((name . make-top-incrementor)))
- (begin-standard-arity () 1 #f)
- (load-static-procedure 0 top-incrementor)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 top-incrementor)
+ (return 1)
(end-arity)
(end-program)
(begin-program top-incrementor
((name . top-incrementor)))
- (begin-standard-arity () 1 #f)
- (cached-module-ref 0 (tests rtl) #f *top-val*)
- (add1 0 0)
- (cached-module-set! 0 (tests rtl) #f *top-val*)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (cached-module-ref 1 (tests rtl) #f *top-val*)
+ (add1 1 1)
+ (cached-module-set! 1 (tests rtl) #f *top-val*)
+ (return 1)
(end-arity)
(end-program)))))
((make-top-incrementor))
@@ -289,9 +294,9 @@
(with-test-prefix "debug contexts"
(let ((return-3 (assemble-program
'((begin-program return-3 ((name . return-3)))
- (begin-standard-arity () 1 #f)
- (load-constant 0 3)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 3)
+ (return 1)
(end-arity)
(end-program)))))
(pass-if "program name"
@@ -311,9 +316,9 @@
(procedure-name
(assemble-program
'((begin-program foo ((name . foo)))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program))))))
@@ -322,18 +327,18 @@
(object->string
(assemble-program
'((begin-program foo ((name . foo)))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program)))))
(pass-if-equal "#<procedure foo (x y)>"
(object->string
(assemble-program
'((begin-program foo ((name . foo)))
- (begin-standard-arity (x y) 2 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity (x y) 3 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program)))))
@@ -341,9 +346,9 @@
(object->string
(assemble-program
'((begin-program foo ((name . foo)))
- (begin-opt-arity (x) (y) z 3 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-opt-arity (x) (y) z 4 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program))))))
@@ -352,9 +357,9 @@
(procedure-documentation
(assemble-program
'((begin-program foo ((name . foo) (documentation . "qux qux")))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program))))))
@@ -364,9 +369,9 @@
(procedure-properties
(assemble-program
'((begin-program foo ())
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program)))))
@@ -376,9 +381,9 @@
(procedure-properties
(assemble-program
'((begin-program foo ((name . foo) (documentation . "qux qux")))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program)))))
@@ -391,9 +396,9 @@
'((begin-program foo ((name . foo)
(documentation . "qux qux")
(moo . "mooooooooooooo")))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program)))))
@@ -404,8 +409,8 @@
'((begin-program foo ((name . foo)
(documentation . "qux qux")
(moo . "mooooooooooooo")))
- (begin-standard-arity () 1 #f)
- (load-constant 0 42)
- (return 0)
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
(end-arity)
(end-program))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-107-g78ff784,
Andy Wingo <=