diff options
-rw-r--r-- | doc/ref/compiler.texi | 7 | ||||
-rw-r--r-- | libguile/_scm.h | 4 | ||||
-rw-r--r-- | libguile/vm-engine.c | 263 | ||||
-rw-r--r-- | module/language/cps.scm | 11 | ||||
-rw-r--r-- | module/language/cps/arities.scm | 8 | ||||
-rw-r--r-- | module/language/cps/closure-conversion.scm | 8 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 73 | ||||
-rw-r--r-- | module/language/cps/dce.scm | 3 | ||||
-rw-r--r-- | module/language/cps/dfg.scm | 5 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 2 | ||||
-rw-r--r-- | module/language/cps/simplify.scm | 3 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 8 | ||||
-rw-r--r-- | module/language/cps/verify.scm | 7 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 2 |
14 files changed, 257 insertions, 147 deletions
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 845d5a8ae..640733838 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -687,10 +687,17 @@ entry. @end deftp @deftp {CPS Expression} $call proc args +@deftpx {CPS Expression} $callk label proc args Call @var{proc} with the arguments @var{args}, and pass all values to the continuation. @var{proc} and the elements of the @var{args} list should all be variable names. The continuation identified by the term's @var{k} should be a @code{$kreceive} or a @code{$ktail} instance. + +@code{$callk} is for the case where the call target is known to be in +the same compilation unit. @var{label} should be some continuation +label, though it need not be in scope. In this case the @var{proc} is +simply an additional argument, since it is not used to determine the +call target at run-time. @end deftp @deftp {CPS Expression} $primcall name args diff --git a/libguile/_scm.h b/libguile/_scm.h index 429861233..003c36d62 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -4,7 +4,7 @@ #define SCM__SCM_H /* Copyright (C) 1995, 1996, 2000, 2001, 2002, 2006, 2008, 2009, 2010, - * 2011, 2013 Free Software Foundation, Inc. + * 2011, 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 License @@ -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 3 +#define SCM_OBJCODE_MINOR_VERSION 4 #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 bc94a6951..5edadd3ac 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -578,13 +578,48 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (0); } + /* call-label proc:24 _:8 nlocals:24 label:32 + * + * Call a procedure in the same compilation unit. + * + * This instruction is just like "call", except that instead of + * dereferencing PROC to find the call target, the call target is + * known to be at LABEL, a signed 32-bit offset in 32-bit units from + * the current IP. Since PROC is not dereferenced, it may be some + * other representation of the closure. + */ + VM_DEFINE_OP (2, call_label, "call-label", OP3 (U8_U24, X8_U24, L32)) + { + scm_t_uint32 proc, nlocals; + scm_t_int32 label; + SCM *old_fp; + + UNPACK_24 (op, proc); + UNPACK_24 (ip[1], nlocals); + label = ip[2]; + + VM_HANDLE_INTERRUPTS; + + old_fp = fp; + fp = vp->fp = old_fp + proc; + SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); + SCM_FRAME_SET_RETURN_ADDRESS (fp, ip + 3); + + RESET_FRAME (nlocals); + + PUSH_CONTINUATION_HOOK (); + APPLY_HOOK (); + + NEXT (label); + } + /* tail-call nlocals:24 * * Tail-call a procedure. Requires that the procedure and all of the * arguments have already been shuffled into position. Will reset the * frame to NLOCALS. */ - VM_DEFINE_OP (2, tail_call, "tail-call", OP1 (U8_U24)) + VM_DEFINE_OP (3, tail_call, "tail-call", OP1 (U8_U24)) { scm_t_uint32 nlocals; @@ -603,6 +638,28 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (0); } + /* tail-call-label nlocals:24 label:32 + * + * Tail-call a known procedure. As call is to call-label, tail-call + * is to tail-call-label. + */ + VM_DEFINE_OP (4, tail_call_label, "tail-call-label", OP2 (U8_U24, L32)) + { + scm_t_uint32 nlocals; + scm_t_int32 label; + + UNPACK_24 (op, nlocals); + label = ip[1]; + + VM_HANDLE_INTERRUPTS; + + RESET_FRAME (nlocals); + + APPLY_HOOK (); + + NEXT (label); + } + /* tail-call/shuffle from:24 * * Tail-call a procedure. The procedure should already be set to slot @@ -610,7 +667,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * FROM, shuffled down to start at slot 0. This is part of the * implementation of the call-with-values builtin. */ - VM_DEFINE_OP (3, tail_call_shuffle, "tail-call/shuffle", OP1 (U8_U24)) + VM_DEFINE_OP (5, tail_call_shuffle, "tail-call/shuffle", OP1 (U8_U24)) { scm_t_uint32 n, from, nlocals; @@ -641,7 +698,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * PROC, asserting that the call actually returned at least one * value. Afterwards, resets the frame to NLOCALS locals. */ - VM_DEFINE_OP (4, receive, "receive", OP2 (U8_U12_U12, X8_U24) | OP_DST) + VM_DEFINE_OP (6, receive, "receive", OP2 (U8_U12_U12, X8_U24) | OP_DST) { scm_t_uint16 dst, proc; scm_t_uint32 nlocals; @@ -661,7 +718,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * return values equals NVALUES exactly. After receive-values has * run, the values can be copied down via `mov'. */ - VM_DEFINE_OP (5, receive_values, "receive-values", OP2 (U8_U24, B1_X7_U24)) + VM_DEFINE_OP (7, receive_values, "receive-values", OP2 (U8_U24, B1_X7_U24)) { scm_t_uint32 proc, nvalues; UNPACK_24 (op, proc); @@ -679,7 +736,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Return a value. */ - VM_DEFINE_OP (6, return, "return", OP1 (U8_U24)) + VM_DEFINE_OP (8, return, "return", OP1 (U8_U24)) { scm_t_uint32 src; UNPACK_24 (op, src); @@ -694,7 +751,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * shuffled down to a contiguous array starting at slot 1. * We also expect the frame has already been reset. */ - VM_DEFINE_OP (7, return_values, "return-values", OP1 (U8_X24)) + VM_DEFINE_OP (9, return_values, "return-values", OP1 (U8_X24)) { SCM *old_fp; @@ -727,7 +784,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * calling frame. This instruction is part of the trampolines * created in gsubr.c, and is not generated by the compiler. */ - VM_DEFINE_OP (8, subr_call, "subr-call", OP1 (U8_U24)) + VM_DEFINE_OP (10, subr_call, "subr-call", OP1 (U8_U24)) { scm_t_uint32 ptr_idx; SCM pointer, ret; @@ -796,7 +853,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * part of the trampolines created by the FFI, and is not generated by * the compiler. */ - VM_DEFINE_OP (9, foreign_call, "foreign-call", OP1 (U8_U12_U12)) + VM_DEFINE_OP (11, foreign_call, "foreign-call", OP1 (U8_U12_U12)) { scm_t_uint16 cif_idx, ptr_idx; SCM closure, cif, pointer, ret; @@ -830,7 +887,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * the implementation of undelimited continuations, and is not * generated by the compiler. */ - VM_DEFINE_OP (10, continuation_call, "continuation-call", OP1 (U8_U24)) + VM_DEFINE_OP (12, continuation_call, "continuation-call", OP1 (U8_U24)) { SCM contregs; scm_t_uint32 contregs_idx; @@ -860,7 +917,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * instruction is part of the implementation of partial continuations, * and is not generated by the compiler. */ - VM_DEFINE_OP (11, compose_continuation, "compose-continuation", OP1 (U8_U24)) + VM_DEFINE_OP (13, compose_continuation, "compose-continuation", OP1 (U8_U24)) { SCM vmcont; scm_t_uint32 cont_idx; @@ -885,7 +942,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * arguments. This instruction is part of the implementation of * `apply', and is not generated by the compiler. */ - VM_DEFINE_OP (12, tail_apply, "tail-apply", OP1 (U8_X24)) + VM_DEFINE_OP (14, tail_apply, "tail-apply", OP1 (U8_X24)) { int i, list_idx, list_len, nlocals; SCM list; @@ -930,7 +987,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * local slot 1 to it. This instruction is part of the implementation * of `call/cc', and is not generated by the compiler. */ - VM_DEFINE_OP (13, call_cc, "call/cc", OP1 (U8_X24)) + VM_DEFINE_OP (15, call_cc, "call/cc", OP1 (U8_X24)) { SCM vm_cont, cont; scm_t_dynstack *dynstack; @@ -981,7 +1038,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * of the values in the frame are returned to the prompt handler. * This corresponds to a tail application of abort-to-prompt. */ - VM_DEFINE_OP (14, abort, "abort", OP1 (U8_X24)) + VM_DEFINE_OP (16, abort, "abort", OP1 (U8_X24)) { scm_t_uint32 nlocals = FRAME_LOCALS_COUNT (); @@ -1002,7 +1059,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Load a builtin stub by index into DST. */ - VM_DEFINE_OP (15, builtin_ref, "builtin-ref", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (17, builtin_ref, "builtin-ref", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, idx; @@ -1027,15 +1084,15 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to * the current instruction pointer. */ - VM_DEFINE_OP (16, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24)) + VM_DEFINE_OP (18, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24)) { BR_NARGS (!=); } - VM_DEFINE_OP (17, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24)) + VM_DEFINE_OP (19, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24)) { BR_NARGS (<); } - VM_DEFINE_OP (18, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24)) + VM_DEFINE_OP (20, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24)) { BR_NARGS (>); } @@ -1047,7 +1104,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the number of actual arguments is not ==, >=, or <= EXPECTED, * respectively, signal an error. */ - VM_DEFINE_OP (19, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24)) + VM_DEFINE_OP (21, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24)) { scm_t_uint32 expected; UNPACK_24 (op, expected); @@ -1055,7 +1112,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp))); NEXT (1); } - VM_DEFINE_OP (20, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24)) + VM_DEFINE_OP (22, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24)) { scm_t_uint32 expected; UNPACK_24 (op, expected); @@ -1063,7 +1120,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp))); NEXT (1); } - VM_DEFINE_OP (21, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24)) + VM_DEFINE_OP (23, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24)) { scm_t_uint32 expected; UNPACK_24 (op, expected); @@ -1078,7 +1135,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * setting them all to SCM_UNDEFINED, except those nargs values that * were passed as arguments and procedure. */ - VM_DEFINE_OP (22, alloc_frame, "alloc-frame", OP1 (U8_U24)) + VM_DEFINE_OP (24, alloc_frame, "alloc-frame", OP1 (U8_U24)) { scm_t_uint32 nlocals, nargs; UNPACK_24 (op, nlocals); @@ -1097,7 +1154,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Used to reset the frame size to something less than the size that * was previously set via alloc-frame. */ - VM_DEFINE_OP (23, reset_frame, "reset-frame", OP1 (U8_U24)) + VM_DEFINE_OP (25, reset_frame, "reset-frame", OP1 (U8_U24)) { scm_t_uint32 nlocals; UNPACK_24 (op, nlocals); @@ -1110,7 +1167,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The * number of locals reserved is EXPECTED + NLOCALS. */ - VM_DEFINE_OP (24, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12)) + VM_DEFINE_OP (26, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12)) { scm_t_uint16 expected, nlocals; UNPACK_12_12 (op, expected, nlocals); @@ -1133,7 +1190,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * See "Case-lambda" in the manual, for more on how case-lambda * chooses the clause to apply. */ - VM_DEFINE_OP (25, br_if_npos_gt, "br-if-npos-gt", OP3 (U8_U24, X8_U24, X8_L24)) + VM_DEFINE_OP (27, br_if_npos_gt, "br-if-npos-gt", OP3 (U8_U24, X8_U24, X8_L24)) { scm_t_uint32 nreq, npos; @@ -1171,7 +1228,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * A macro-mega-instruction. */ - VM_DEFINE_OP (26, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32)) + VM_DEFINE_OP (28, 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; @@ -1257,7 +1314,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Collect any arguments at or above DST into a list, and store that * list at DST. */ - VM_DEFINE_OP (27, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST) + VM_DEFINE_OP (29, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST) { scm_t_uint32 dst, nargs; SCM rest = SCM_EOL; @@ -1299,7 +1356,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Add OFFSET, a signed 24-bit number, to the current instruction * pointer. */ - VM_DEFINE_OP (28, br, "br", OP1 (U8_L24)) + VM_DEFINE_OP (30, br, "br", OP1 (U8_L24)) { scm_t_int32 offset = op; offset >>= 8; /* Sign-extending shift. */ @@ -1311,7 +1368,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (29, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (31, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, scm_is_true (x)); } @@ -1321,7 +1378,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (30, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (32, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, scm_is_null (x)); } @@ -1331,7 +1388,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit * number, to the current instruction pointer. */ - VM_DEFINE_OP (31, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (33, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, scm_is_lisp_false (x)); } @@ -1341,7 +1398,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in TEST is a pair, add OFFSET, a signed 24-bit number, * to the current instruction pointer. */ - VM_DEFINE_OP (32, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (34, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, scm_is_pair (x)); } @@ -1351,7 +1408,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in TEST is a struct, add OFFSET, a signed 24-bit * number, to the current instruction pointer. */ - VM_DEFINE_OP (33, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (35, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, SCM_STRUCTP (x)); } @@ -1361,7 +1418,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in TEST is a char, add OFFSET, a signed 24-bit number, * to the current instruction pointer. */ - VM_DEFINE_OP (34, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (36, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, SCM_CHARP (x)); } @@ -1371,7 +1428,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (35, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24)) + VM_DEFINE_OP (37, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24)) { BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f)); } @@ -1381,7 +1438,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (36, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (38, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24)) { BR_BINARY (x, y, scm_is_eq (x, y)); } @@ -1391,7 +1448,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (37, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (39, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24)) { BR_BINARY (x, y, scm_is_eq (x, y) @@ -1407,7 +1464,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ // FIXME: Should sync_ip before calling out and cache_fp before coming // back! Another reason to remove this opcode! - VM_DEFINE_OP (38, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (40, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24)) { BR_BINARY (x, y, scm_is_eq (x, y) @@ -1420,7 +1477,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (41, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24)) { BR_ARITHMETIC (==, scm_num_eq_p); } @@ -1430,7 +1487,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (42, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24)) { BR_ARITHMETIC (<, scm_less_p); } @@ -1440,7 +1497,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (41, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (43, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24)) { BR_ARITHMETIC (<=, scm_leq_p); } @@ -1456,7 +1513,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Copy a value from one local slot to another. */ - VM_DEFINE_OP (42, mov, "mov", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (44, mov, "mov", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst; scm_t_uint16 src; @@ -1471,7 +1528,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Copy a value from one local slot to another. */ - VM_DEFINE_OP (43, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST) + VM_DEFINE_OP (45, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST) { scm_t_uint32 dst; scm_t_uint32 src; @@ -1487,7 +1544,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Create a new variable holding SRC, and place it in DST. */ - VM_DEFINE_OP (44, box, "box", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (46, box, "box", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; UNPACK_12_12 (op, dst, src); @@ -1501,7 +1558,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (47, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; SCM var; @@ -1519,7 +1576,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Set the contents of the variable at DST to SET. */ - VM_DEFINE_OP (46, box_set, "box-set!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (48, box_set, "box-set!", OP1 (U8_U12_U12)) { scm_t_uint16 dst, src; SCM var; @@ -1538,7 +1595,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * signed 32-bit integer. Space for NFREE free variables will be * allocated. */ - VM_DEFINE_OP (47, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST) + VM_DEFINE_OP (49, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST) { scm_t_uint32 dst, nfree, n; scm_t_int32 offset; @@ -1563,7 +1620,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Load free variable IDX from the closure SRC into local slot DST. */ - VM_DEFINE_OP (48, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST) + VM_DEFINE_OP (50, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST) { scm_t_uint16 dst, src; scm_t_uint32 idx; @@ -1578,7 +1635,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Set free variable IDX from the closure DST to SRC. */ - VM_DEFINE_OP (49, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24)) + VM_DEFINE_OP (51, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24)) { scm_t_uint16 dst, src; scm_t_uint32 idx; @@ -1601,7 +1658,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (52, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST) { scm_t_uint8 dst; scm_t_bits val; @@ -1616,7 +1673,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (53, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32)) { scm_t_uint32 dst; scm_t_bits val; @@ -1631,7 +1688,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * 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 (54, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST) { scm_t_uint32 dst; scm_t_bits val; @@ -1662,7 +1719,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (55, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST) { scm_t_uint32 dst; scm_t_int32 offset; @@ -1691,7 +1748,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (56, static_ref, "static-ref", OP2 (U8_U24, S32)) { scm_t_uint32 dst; scm_t_int32 offset; @@ -1714,7 +1771,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (57, static_set, "static-set!", OP2 (U8_U24, LO32)) { scm_t_uint32 src; scm_t_int32 offset; @@ -1736,7 +1793,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * are signed 32-bit values, indicating a memory address as a number * of 32-bit words away from the current instruction pointer. */ - VM_DEFINE_OP (56, static_patch, "static-patch!", OP3 (U8_X24, LO32, L32)) + VM_DEFINE_OP (58, static_patch, "static-patch!", OP3 (U8_X24, LO32, L32)) { scm_t_int32 dst_offset, src_offset; void *src; @@ -1794,7 +1851,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Store the current module in DST. */ - VM_DEFINE_OP (57, current_module, "current-module", OP1 (U8_U24) | OP_DST) + VM_DEFINE_OP (59, current_module, "current-module", OP1 (U8_U24) | OP_DST) { scm_t_uint32 dst; @@ -1811,7 +1868,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Resolve SYM in the current module, and place the resulting variable * in DST. */ - VM_DEFINE_OP (58, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST) + VM_DEFINE_OP (60, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST) { scm_t_uint32 dst; scm_t_uint32 sym; @@ -1836,7 +1893,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Look up a binding for SYM in the current module, creating it if * necessary. Set its value to VAL. */ - VM_DEFINE_OP (59, define, "define!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (61, define, "define!", OP1 (U8_U12_U12)) { scm_t_uint16 sym, val; UNPACK_12_12 (op, sym, val); @@ -1865,7 +1922,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * DST, and caching the resolved variable so that we will hit the cache next * time. */ - VM_DEFINE_OP (60, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST) + VM_DEFINE_OP (62, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST) { scm_t_uint32 dst; scm_t_int32 var_offset; @@ -1918,7 +1975,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Like toplevel-box, except MOD-OFFSET points at the name of a module * instead of the module itself. */ - VM_DEFINE_OP (61, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST) + VM_DEFINE_OP (63, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST) { scm_t_uint32 dst; scm_t_int32 var_offset; @@ -1990,7 +2047,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * will expect a multiple-value return as if from a call with the * procedure at PROC-SLOT. */ - VM_DEFINE_OP (62, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24)) + VM_DEFINE_OP (64, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24)) { scm_t_uint32 tag, proc_slot; scm_t_int32 offset; @@ -2022,7 +2079,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * 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 (63, wind, "wind", OP1 (U8_U12_U12)) + VM_DEFINE_OP (65, wind, "wind", OP1 (U8_U12_U12)) { scm_t_uint16 winder, unwinder; UNPACK_12_12 (op, winder, unwinder); @@ -2036,7 +2093,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * A normal exit from the dynamic extent of an expression. Pop the top * entry off of the dynamic stack. */ - VM_DEFINE_OP (64, unwind, "unwind", OP1 (U8_X24)) + VM_DEFINE_OP (66, unwind, "unwind", OP1 (U8_X24)) { scm_dynstack_pop (&thread->dynstack); NEXT (1); @@ -2046,7 +2103,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Dynamically bind VALUE to FLUID. */ - VM_DEFINE_OP (65, push_fluid, "push-fluid", OP1 (U8_U12_U12)) + VM_DEFINE_OP (67, push_fluid, "push-fluid", OP1 (U8_U12_U12)) { scm_t_uint32 fluid, value; @@ -2063,7 +2120,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Leave the dynamic extent of a with-fluid* expression, restoring the * fluid to its previous value. */ - VM_DEFINE_OP (66, pop_fluid, "pop-fluid", OP1 (U8_X24)) + VM_DEFINE_OP (68, pop_fluid, "pop-fluid", OP1 (U8_X24)) { /* This function must not allocate. */ scm_dynstack_unwind_fluid (&thread->dynstack, @@ -2075,7 +2132,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Reference the fluid in SRC, and place the value in DST. */ - VM_DEFINE_OP (67, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (69, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; size_t num; @@ -2108,7 +2165,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Set the value of the fluid in DST to the value in SRC. */ - VM_DEFINE_OP (68, fluid_set, "fluid-set", OP1 (U8_U12_U12)) + VM_DEFINE_OP (70, fluid_set, "fluid-set", OP1 (U8_U12_U12)) { scm_t_uint16 a, b; size_t num; @@ -2141,7 +2198,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Store the length of the string in SRC in DST. */ - VM_DEFINE_OP (69, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (71, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (str); if (SCM_LIKELY (scm_is_string (str))) @@ -2158,7 +2215,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Fetch the character at position IDX in the string in SRC, and store * it in DST. */ - VM_DEFINE_OP (70, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (72, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_signed_bits i = 0; ARGS2 (str, idx); @@ -2180,7 +2237,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Parse a string in SRC to a number, and store in DST. */ - VM_DEFINE_OP (71, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (73, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; @@ -2196,7 +2253,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Parse a string in SRC to a symbol, and store in DST. */ - VM_DEFINE_OP (72, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (74, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; @@ -2210,7 +2267,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Make a keyword from the symbol in SRC, and store it in DST. */ - VM_DEFINE_OP (73, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (75, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; UNPACK_12_12 (op, dst, src); @@ -2229,7 +2286,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Cons CAR and CDR, and store the result in DST. */ - VM_DEFINE_OP (74, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (76, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); RETURN (scm_inline_cons (thread, x, y)); @@ -2239,7 +2296,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Place the car of SRC in DST. */ - VM_DEFINE_OP (75, car, "car", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (77, car, "car", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (x); VM_VALIDATE_PAIR (x, "car"); @@ -2250,7 +2307,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Place the cdr of SRC in DST. */ - VM_DEFINE_OP (76, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (78, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (x); VM_VALIDATE_PAIR (x, "cdr"); @@ -2261,7 +2318,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Set the car of DST to SRC. */ - VM_DEFINE_OP (77, set_car, "set-car!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (79, set_car, "set-car!", OP1 (U8_U12_U12)) { scm_t_uint16 a, b; SCM x, y; @@ -2277,7 +2334,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Set the cdr of DST to SRC. */ - VM_DEFINE_OP (78, set_cdr, "set-cdr!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (80, set_cdr, "set-cdr!", OP1 (U8_U12_U12)) { scm_t_uint16 a, b; SCM x, y; @@ -2300,7 +2357,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Add A to B, and place the result in DST. */ - VM_DEFINE_OP (79, add, "add", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (81, add, "add", OP1 (U8_U8_U8_U8) | OP_DST) { BINARY_INTEGER_OP (+, scm_sum); } @@ -2309,7 +2366,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Add 1 to the value in SRC, and place the result in DST. */ - VM_DEFINE_OP (80, add1, "add1", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (82, add1, "add1", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (x); @@ -2333,7 +2390,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Subtract B from A, and place the result in DST. */ - VM_DEFINE_OP (81, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (83, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST) { BINARY_INTEGER_OP (-, scm_difference); } @@ -2342,7 +2399,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Subtract 1 from SRC, and place the result in DST. */ - VM_DEFINE_OP (82, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (84, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (x); @@ -2366,7 +2423,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Multiply A and B, and place the result in DST. */ - VM_DEFINE_OP (83, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (85, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); RETURN_EXP (scm_product (x, y)); @@ -2376,7 +2433,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Divide A by B, and place the result in DST. */ - VM_DEFINE_OP (84, div, "div", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (86, div, "div", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); RETURN_EXP (scm_divide (x, y)); @@ -2386,7 +2443,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Divide A by B, and place the quotient in DST. */ - VM_DEFINE_OP (85, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (87, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); RETURN_EXP (scm_quotient (x, y)); @@ -2396,7 +2453,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Divide A by B, and place the remainder in DST. */ - VM_DEFINE_OP (86, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (88, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); RETURN_EXP (scm_remainder (x, y)); @@ -2406,7 +2463,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Place the modulo of A by B in DST. */ - VM_DEFINE_OP (87, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (89, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); RETURN_EXP (scm_modulo (x, y)); @@ -2416,7 +2473,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Shift A arithmetically by B bits, and place the result in DST. */ - VM_DEFINE_OP (88, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (90, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2451,7 +2508,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Place the bitwise AND of A and B into DST. */ - VM_DEFINE_OP (89, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (91, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2464,7 +2521,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Place the bitwise inclusive OR of A with B in DST. */ - VM_DEFINE_OP (90, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (92, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2477,7 +2534,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Place the bitwise exclusive OR of A with B in DST. */ - VM_DEFINE_OP (91, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (93, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2491,7 +2548,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * will have space for LENGTH slots, an immediate value. They will be * filled with the value in slot INIT. */ - VM_DEFINE_OP (92, make_vector_immediate, "make-vector/immediate", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (94, make_vector_immediate, "make-vector/immediate", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, init; scm_t_int32 length, n; @@ -2512,7 +2569,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Store the length of the vector in SRC in DST. */ - VM_DEFINE_OP (93, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (95, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (vect); if (SCM_LIKELY (SCM_I_IS_VECTOR (vect))) @@ -2529,7 +2586,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 (94, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (96, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_signed_bits i = 0; ARGS2 (vect, idx); @@ -2550,7 +2607,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 (95, vector_ref_immediate, "vector-ref/immediate", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (97, vector_ref_immediate, "vector-ref/immediate", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, src, idx; SCM v; @@ -2569,7 +2626,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Store SRC into the vector DST at index IDX. */ - VM_DEFINE_OP (96, vector_set, "vector-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (98, vector_set, "vector-set!", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx_var, src; SCM vect, idx, val; @@ -2598,7 +2655,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 (97, vector_set_immediate, "vector-set!/immediate", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (99, vector_set_immediate, "vector-set!/immediate", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx, src; SCM vect, val; @@ -2629,7 +2686,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Store the vtable of SRC into DST. */ - VM_DEFINE_OP (98, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (100, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (obj); VM_VALIDATE_STRUCT (obj, "struct_vtable"); @@ -2642,7 +2699,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 (99, allocate_struct_immediate, "allocate-struct/immediate", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (101, allocate_struct_immediate, "allocate-struct/immediate", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, vtable, nfields; SCM ret; @@ -2661,7 +2718,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 (100, struct_ref_immediate, "struct-ref/immediate", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (102, struct_ref_immediate, "struct-ref/immediate", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, src, idx; SCM obj; @@ -2686,7 +2743,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 (101, struct_set_immediate, "struct-set!/immediate", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (103, struct_set_immediate, "struct-set!/immediate", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx, src; SCM obj, val; @@ -2717,7 +2774,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Store the vtable of SRC into DST. */ - VM_DEFINE_OP (102, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (104, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (obj); if (SCM_INSTANCEP (obj)) @@ -2726,10 +2783,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, RETURN (scm_class_of (obj)); } - VM_DEFINE_OP (103, unused_103, NULL, NOP) - VM_DEFINE_OP (104, unused_104, NULL, NOP) - goto op_unused_255; - /* diff --git a/module/language/cps.scm b/module/language/cps.scm index b4bcbb56f..e0d708ae8 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -121,7 +121,7 @@ $kif $kreceive $kargs $kentry $ktail $kclause ;; Expressions. - $void $const $prim $fun $call $primcall $values $prompt + $void $const $prim $fun $call $callk $primcall $values $prompt ;; Building macros. let-gensyms @@ -182,6 +182,7 @@ (define-cps-type $prim name) (define-cps-type $fun src meta free body) (define-cps-type $call proc args) +(define-cps-type $callk k proc args) (define-cps-type $primcall name args) (define-cps-type $values args) (define-cps-type $prompt escape? tag handler) @@ -226,7 +227,7 @@ (define-syntax build-cps-exp (syntax-rules (unquote - $void $const $prim $fun $call $primcall $values $prompt) + $void $const $prim $fun $call $callk $primcall $values $prompt) ((_ (unquote exp)) exp) ((_ ($void)) (make-$void)) ((_ ($const val)) (make-$const val)) @@ -235,6 +236,8 @@ (make-$fun src meta free (build-cps-cont body))) ((_ ($call proc (arg ...))) (make-$call proc (list arg ...))) ((_ ($call proc args)) (make-$call proc args)) + ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...))) + ((_ ($callk k proc args)) (make-$callk k proc args)) ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...))) ((_ ($primcall name args)) (make-$primcall name args)) ((_ ($values (arg ...))) (make-$values (list arg ...))) @@ -336,6 +339,8 @@ ($letrec name sym (map parse-cps fun) ,(parse-cps body)))) (('call proc arg ...) (build-cps-exp ($call proc arg))) + (('callk k proc arg ...) + (build-cps-exp ($callk k proc arg))) (('primcall name arg ...) (build-cps-exp ($primcall name arg))) (('values arg ...) @@ -392,6 +397,8 @@ ,(unparse-cps body))) (($ $call proc args) `(call ,proc ,@args)) + (($ $callk k proc args) + `(callk ,k ,proc ,@args)) (($ $primcall name args) `(primcall ,name ,@args)) (($ $values args) diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm index 6c589a3a1..1cd87040b 100644 --- a/module/language/cps/arities.scm +++ b/module/language/cps/arities.scm @@ -136,11 +136,11 @@ ,(adapt-exp 1 k src exp)) (($ $fun) ,(adapt-exp 1 k src (fix-arities exp))) - (($ $call) + ((or ($ $call) ($ $callk)) ;; In general, calls have unknown return arity. For that - ;; reason every non-tail call has an implicit adaptor - ;; continuation to adapt the return to the target - ;; continuation, and we don't need to do any adapting here. + ;; reason every non-tail call has a $kreceive continuation to + ;; adapt the return to the target continuation, and we don't + ;; need to do any adapting here. ($continue k src ,exp)) (($ $primcall 'return (arg)) ;; Primcalls to return are in tail position. diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index 4221cb8f7..c03b409a3 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -198,6 +198,14 @@ convert functions to flat closures." ($continue k src ($call proc args))) '()))))) + (($ $continue k src ($ $callk k* proc args)) + (convert-free-vars (cons proc args) self bound + (match-lambda + ((proc . args) + (values (build-cps-term + ($continue k src ($callk k* proc args))) + '()))))) + (($ $continue k src ($ $primcall name args)) (convert-free-vars args self bound (lambda (args) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index adc51594e..f89730302 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -226,6 +226,13 @@ (let ((tail-slots (cdr (iota (1+ (length args)))))) (for-each maybe-load-constant tail-slots args)) (emit-tail-call asm (1+ (length args)))) + (($ $callk k proc args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (let ((tail-slots (cdr (iota (1+ (length args)))))) + (for-each maybe-load-constant tail-slots args)) + (emit-tail-call-label asm (1+ (length args)) k)) (($ $values ()) (emit-reset-frame asm 1) (emit-return-values asm)) @@ -442,37 +449,45 @@ (($ $primcall '> (a b)) (binary emit-br-if-< b a)))) (define (compile-trunc label k exp nreq rest-var nlocals) + (define (do-call proc args emit-call) + (let* ((proc-slot (lookup-call-proc-slot label allocation)) + (nargs (1+ (length args))) + (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs)))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (for-each maybe-load-constant arg-slots (cons proc args)) + (emit-call asm proc-slot nargs) + (emit-dead-slot-map asm proc-slot + (lookup-dead-slot-map label allocation)) + (cond + ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var)) + (match (lookup-parallel-moves k allocation) + ((((? (lambda (src) (= src (1+ proc-slot))) src) + . dst)) dst) + (_ #f))) + ;; The usual case: one required live return value, ignoring + ;; any additional values. + => (lambda (dst) + (emit-receive asm dst proc-slot nlocals))) + (else + (unless (and (zero? nreq) rest-var) + (emit-receive-values asm proc-slot (->bool rest-var) nreq)) + (when (and rest-var (maybe-slot rest-var)) + (emit-bind-rest asm (+ proc-slot 1 nreq))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves k allocation)) + (emit-reset-frame asm nlocals))))) (match exp (($ $call proc args) - (let* ((proc-slot (lookup-call-proc-slot label allocation)) - (nargs (1+ (length args))) - (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs)))) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation)) - (for-each maybe-load-constant arg-slots (cons proc args)) - (emit-call asm proc-slot nargs) - (emit-dead-slot-map asm proc-slot - (lookup-dead-slot-map label allocation)) - (cond - ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var)) - (match (lookup-parallel-moves k allocation) - ((((? (lambda (src) (= src (1+ proc-slot))) src) - . dst)) dst) - (_ #f))) - ;; The usual case: one required live return value, ignoring - ;; any additional values. - => (lambda (dst) - (emit-receive asm dst proc-slot nlocals))) - (else - (unless (and (zero? nreq) rest-var) - (emit-receive-values asm proc-slot (->bool rest-var) nreq)) - (when (and rest-var (maybe-slot rest-var)) - (emit-bind-rest asm (+ proc-slot 1 nreq))) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves k allocation)) - (emit-reset-frame asm nlocals))))))) + (do-call proc args + (lambda (asm proc-slot nargs) + (emit-call asm proc-slot nargs)))) + (($ $callk k proc args) + (do-call proc args + (lambda (asm proc-slot nargs) + (emit-call-label asm proc-slot nargs k)))))) (match f (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses))) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index 98c1f2c69..8b16bd1e9 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -147,6 +147,9 @@ (($ $call proc args) (mark-live! proc) (for-each mark-live! args)) + (($ $callk k proc args) + (mark-live! proc) + (for-each mark-live! args)) (($ $primcall name args) (for-each mark-live! args)) (($ $values args) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm index dd612ebd1..551b80e9e 100644 --- a/module/language/cps/dfg.scm +++ b/module/language/cps/dfg.scm @@ -839,6 +839,10 @@ BODY for each body continuation in the prompt." (use! proc) (for-each use! args)) + (($ $callk k proc args) + (use! proc) + (for-each use! args)) + (($ $primcall name args) (for-each use! args)) @@ -979,6 +983,7 @@ BODY for each body continuation in the prompt." (lambda (use) (match (find-expression (lookup-cont use conts)) (($ $call) #f) + (($ $callk) #f) (($ $values) #f) (($ $primcall 'free-ref (closure slot)) (not (eq? sym slot))) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 46c7e8884..66e659583 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -451,7 +451,7 @@ (cause &allocation)) (($ $prompt) (cause &prompt)) - (($ $call) + ((or ($ $call) ($ $callk)) (logior &all-effects-but-bailout (cause &all-effects-but-bailout))) (($ $primcall name args) (primitive-effects dfg name args)))) diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm index 0e3c831f5..bd7909806 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -255,6 +255,9 @@ (($ $call proc args) (let ((args (map subst args))) (build-cps-exp ($call (subst proc) args)))) + (($ $callk k proc args) + (let ((args (map subst args))) + (build-cps-exp ($callk k (subst proc) args)))) (($ $primcall name args) (let ((args (map subst args))) (build-cps-exp ($primcall name args)))) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index a4e5129f4..24a6d5fd7 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -352,6 +352,8 @@ are comparable with eqv?. A tmp slot may be used." (match (find-expression body) (($ $call proc args) (cons proc args)) + (($ $callk k proc args) + (cons proc args)) (($ $primcall name args) args) (($ $values args) @@ -423,7 +425,7 @@ are comparable with eqv?. A tmp slot may be used." (match (vector-ref contv n) (($ $kargs names syms body) (match (find-expression body) - (($ $call) + ((or ($ $call) ($ $callk)) (let ((args (make-bitvector (bitvector-length needs-slotv) #f))) (bit-set*! args (live-before n) #t) (bit-set*! args (live-after n) #f) @@ -460,7 +462,7 @@ are comparable with eqv?. A tmp slot may be used." (if (bit-position #t dead 0) (finish-hints n (live-before n) args) (scan-for-hints (1- n) args)))) - ((or ($ $call) ($ $values)) + ((or ($ $call) ($ $callk) ($ $values)) (finish-hints n (live-before n) args)))) ;; Otherwise we kill uses of the block entry. (_ (finish-hints n (live-before (1+ n)) args)))) @@ -640,7 +642,7 @@ are comparable with eqv?. A tmp slot may be used." (($ $kargs names syms body) (let ((uses (vector-ref usev n))) (match (find-call body) - (($ $continue k src ($ $call)) + (($ $continue k src (or ($ $call) ($ $callk))) (allocate-call label k uses live post-live)) (($ $continue k src ($ $primcall)) #t) (($ $continue k src ($ $values)) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index 9da5037ba..10cb7488c 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -124,6 +124,13 @@ (($ $call (? symbol? proc) ((? symbol? arg) ...)) (check-var proc v-env) (for-each (cut check-var <> v-env) arg)) + (($ $callk (? symbol? k*) (? symbol? proc) ((? symbol? arg) ...)) + ;; We don't check that k* is in scope; it's actually inside some + ;; other function, probably. We rely on the transformation that + ;; introduces the $callk to be correct, and the linker to resolve + ;; the reference. + (check-var proc v-env) + (for-each (cut check-var <> v-env) arg)) (($ $primcall (? symbol? name) ((? symbol? arg) ...)) (for-each (cut check-var <> v-env) arg)) (($ $values ((? symbol? arg) ...)) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index e040314c3..5ddc64205 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1275,7 +1275,7 @@ needed." ;; FIXME: Define these somewhere central, shared with C. (define *bytecode-major-version* #x0202) -(define *bytecode-minor-version* 3) +(define *bytecode-minor-version* 4) (define (link-dynamic-section asm text rw rw-init frame-maps) "Link the dynamic section for an ELF image with bytecode @var{text}, |