mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 16:50:21 +02:00
Code Activity

Add VM and compiler support for calls to known procedures

Browse source 
* module/language/cps.scm ($callk): New expression type, for calls to
  known labels.  Part of "low CPS".
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/dce.scm:
* module/language/cps/dfg.scm:
* module/language/cps/effects-analysis.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/verify.scm: Adapt call sites.

* libguile/vm-engine.c (call-label, tail-call-label): New instructions.
  Renumber the rest; this is an ABI change.

* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION):
* module/system/vm/assembler.scm (*bytecode-minor-version*): Bump.

* doc/ref/compiler.texi (CPS in Guile): Document $callk.
This commit is contained in:
Andy Wingo 2014-02-02 23:19:22 +01:00
parent 0320b1fc3f
commit b3ae2b5068
14 changed files with 257 additions and 147 deletions
Download patch file Download diff file Expand all files Collapse all files

7
doc/ref/compiler.texi
View file

@ -687,10 +687,17 @@ entry.
@end deftp @end deftp
@deftp {CPS Expression} $call proc args @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 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 the continuation. @var{proc} and the elements of the @var{args} list
should all be variable names. The continuation identified by the term's should all be variable names. The continuation identified by the term's
@var{k} should be a @code{$kreceive} or a @code{$ktail} instance. @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 @end deftp
@deftp {CPS Expression} $primcall name args @deftp {CPS Expression} $primcall name args

4
libguile/_scm.h
View file

@ -4,7 +4,7 @@
#define SCM__SCM_H #define SCM__SCM_H
/* Copyright (C) 1995, 1996, 2000, 2001, 2002, 2006, 2008, 2009, 2010, /* 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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. */ /* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 3 #define SCM_OBJCODE_MAJOR_VERSION 3
#define SCM_OBJCODE_MINOR_VERSION 3 #define SCM_OBJCODE_MINOR_VERSION 4
#define SCM_OBJCODE_MAJOR_VERSION_STRING \ #define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \ #define SCM_OBJCODE_MINOR_VERSION_STRING \

263
libguile/vm-engine.c
View file

@ -578,13 +578,48 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (0); 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 nlocals:24
* *
* Tail-call a procedure. Requires that the procedure and all of the * Tail-call a procedure. Requires that the procedure and all of the
* arguments have already been shuffled into position. Will reset the * arguments have already been shuffled into position. Will reset the
* frame to NLOCALS. * 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; scm_t_uint32 nlocals;
@ -603,6 +638,28 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (0); 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/shuffle from:24
* *
* Tail-call a procedure. The procedure should already be set to slot * 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 * FROM, shuffled down to start at slot 0. This is part of the
* implementation of the call-with-values builtin. * 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; 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 * PROC, asserting that the call actually returned at least one
* value. Afterwards, resets the frame to NLOCALS locals. * 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_uint16 dst, proc;
scm_t_uint32 nlocals; 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 * return values equals NVALUES exactly. After receive-values has
* run, the values can be copied down via `mov'. * 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; scm_t_uint32 proc, nvalues;
UNPACK_24 (op, proc); UNPACK_24 (op, proc);
@ -679,7 +736,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* *
* Return a value. * 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; scm_t_uint32 src;
UNPACK_24 (op, 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. * shuffled down to a contiguous array starting at slot 1.
* We also expect the frame has already been reset. * 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; 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 * calling frame. This instruction is part of the trampolines
* created in gsubr.c, and is not generated by the compiler. * 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_t_uint32 ptr_idx;
SCM pointer, ret; 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 * part of the trampolines created by the FFI, and is not generated by
* the compiler. * 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_t_uint16 cif_idx, ptr_idx;
SCM closure, cif, pointer, ret; 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 * the implementation of undelimited continuations, and is not
* generated by the compiler. * 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 contregs;
scm_t_uint32 contregs_idx; 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, * instruction is part of the implementation of partial continuations,
* and is not generated by the compiler. * 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 vmcont;
scm_t_uint32 cont_idx; 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 * arguments. This instruction is part of the implementation of
* `apply', and is not generated by the compiler. * `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; int i, list_idx, list_len, nlocals;
SCM list; 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 * local slot 1 to it. This instruction is part of the implementation
* of `call/cc', and is not generated by the compiler. * 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 vm_cont, cont;
scm_t_dynstack *dynstack; 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. * of the values in the frame are returned to the prompt handler.
* This corresponds to a tail application of abort-to-prompt. * 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 (); 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. * 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; 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 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
* the current instruction pointer. * 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 (!=); 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 (<); 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 (>); 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, * If the number of actual arguments is not ==, >=, or <= EXPECTED,
* respectively, signal an error. * 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; scm_t_uint32 expected;
UNPACK_24 (op, 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))); vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
NEXT (1); 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; scm_t_uint32 expected;
UNPACK_24 (op, 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))); vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
NEXT (1); 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; scm_t_uint32 expected;
UNPACK_24 (op, 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 * setting them all to SCM_UNDEFINED, except those nargs values that
* were passed as arguments and procedure. * 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; scm_t_uint32 nlocals, nargs;
UNPACK_24 (op, nlocals); 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 * Used to reset the frame size to something less than the size that
* was previously set via alloc-frame. * 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; scm_t_uint32 nlocals;
UNPACK_24 (op, 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 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
* number of locals reserved is EXPECTED + NLOCALS. * 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; scm_t_uint16 expected, nlocals;
UNPACK_12_12 (op, 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 * See "Case-lambda" in the manual, for more on how case-lambda
* chooses the clause to apply. * 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; scm_t_uint32 nreq, npos;
@ -1171,7 +1228,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* *
* A macro-mega-instruction. * 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_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n, nargs;
scm_t_int32 kw_offset; 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 * Collect any arguments at or above DST into a list, and store that
* list at DST. * 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_t_uint32 dst, nargs;
SCM rest = SCM_EOL; 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 * Add OFFSET, a signed 24-bit number, to the current instruction
* pointer. * pointer.
*/ */
VM_DEFINE_OP (28, br, "br", OP1 (U8_L24)) VM_DEFINE_OP (30, br, "br", OP1 (U8_L24))
{ {
scm_t_int32 offset = op; scm_t_int32 offset = op;
offset >>= 8; /* Sign-extending shift. */ 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 * If the value in TEST is true for the purposes of Scheme, add
* OFFSET, a signed 24-bit number, to the current instruction pointer. * 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)); 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 * 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. * 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)); 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 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
* number, to the current instruction pointer. * 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)); 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, * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
* to the current instruction pointer. * 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)); 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 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
* number, to the current instruction pointer. * 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)); 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, * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
* to the current instruction pointer. * 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)); 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 * 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. * 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)); 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 * If the value in A is eq? to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer. * 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)); 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 * If the value in A is eqv? to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer. * 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, BR_BINARY (x, y,
scm_is_eq (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 // FIXME: Should sync_ip before calling out and cache_fp before coming
// back! Another reason to remove this opcode! // 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, BR_BINARY (x, y,
scm_is_eq (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 * If the value in A is = to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer. * 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); 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 * If the value in A is < to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer. * 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); 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 * If the value in A is <= to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer. * 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); 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. * 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 dst;
scm_t_uint16 src; 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. * 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 dst;
scm_t_uint32 src; 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. * 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; scm_t_uint16 dst, src;
UNPACK_12_12 (op, 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 * Unpack the variable at SRC into DST, asserting that the variable is
* actually bound. * 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_t_uint16 dst, src;
SCM var; 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. * 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_t_uint16 dst, src;
SCM var; 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 * signed 32-bit integer. Space for NFREE free variables will be
* allocated. * 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_uint32 dst, nfree, n;
scm_t_int32 offset; 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. * 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_uint16 dst, src;
scm_t_uint32 idx; 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. * 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_uint16 dst, src;
scm_t_uint32 idx; 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 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
* 0. * 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_uint8 dst;
scm_t_bits val; 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 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
* 0. * 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_uint32 dst;
scm_t_bits val; 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. * 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_uint32 dst;
scm_t_bits val; 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 * Whether the object is mutable or immutable depends on where it was
* allocated by the compiler, and loaded by the loader. * 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_uint32 dst;
scm_t_int32 offset; 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. * that the compiler is unable to statically allocate, like symbols.
* These values would be initialized when the object file loads. * 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_uint32 dst;
scm_t_int32 offset; 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 * Store a SCM value into memory, OFFSET 32-bit words away from the
* current instruction pointer. OFFSET is a signed value. * 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_uint32 src;
scm_t_int32 offset; 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 * are signed 32-bit values, indicating a memory address as a number
* of 32-bit words away from the current instruction pointer. * 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; scm_t_int32 dst_offset, src_offset;
void *src; void *src;
@ -1794,7 +1851,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* *
* Store the current module in DST. * 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; 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 * Resolve SYM in the current module, and place the resulting variable
* in DST. * 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 dst;
scm_t_uint32 sym; 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 * Look up a binding for SYM in the current module, creating it if
* necessary. Set its value to VAL. * 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; scm_t_uint16 sym, val;
UNPACK_12_12 (op, 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 * DST, and caching the resolved variable so that we will hit the cache next
* time. * 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_uint32 dst;
scm_t_int32 var_offset; 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 * Like toplevel-box, except MOD-OFFSET points at the name of a module
* instead of the module itself. * 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_uint32 dst;
scm_t_int32 var_offset; 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 * will expect a multiple-value return as if from a call with the
* procedure at PROC-SLOT. * 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_uint32 tag, proc_slot;
scm_t_int32 offset; 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 * the compiler should have inserted checks that they wind and unwind
* procs are thunks, if it could not prove that to be the case. * 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; scm_t_uint16 winder, unwinder;
UNPACK_12_12 (op, 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 * A normal exit from the dynamic extent of an expression. Pop the top
* entry off of the dynamic stack. * 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); scm_dynstack_pop (&thread->dynstack);
NEXT (1); NEXT (1);
@ -2046,7 +2103,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* *
* Dynamically bind VALUE to FLUID. * 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; 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 * Leave the dynamic extent of a with-fluid* expression, restoring the
* fluid to its previous value. * 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. */ /* This function must not allocate. */
scm_dynstack_unwind_fluid (&thread->dynstack, 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. * 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; scm_t_uint16 dst, src;
size_t num; 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. * 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; scm_t_uint16 a, b;
size_t num; 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. * 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); ARGS1 (str);
if (SCM_LIKELY (scm_is_string (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 * Fetch the character at position IDX in the string in SRC, and store
* it in DST. * 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; scm_t_signed_bits i = 0;
ARGS2 (str, idx); 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. * 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; 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. * 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; 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. * 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; scm_t_uint16 dst, src;
UNPACK_12_12 (op, 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. * 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); ARGS2 (x, y);
RETURN (scm_inline_cons (thread, 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. * 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); ARGS1 (x);
VM_VALIDATE_PAIR (x, "car"); 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. * 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); ARGS1 (x);
VM_VALIDATE_PAIR (x, "cdr"); 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. * 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_t_uint16 a, b;
SCM x, y; SCM x, y;
@ -2277,7 +2334,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* *
* Set the cdr of DST to SRC. * 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_t_uint16 a, b;
SCM x, y; 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. * 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); 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. * 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); 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. * 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); 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. * 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); 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. * 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); ARGS2 (x, y);
RETURN_EXP (scm_product (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. * 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); ARGS2 (x, y);
RETURN_EXP (scm_divide (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. * 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); ARGS2 (x, y);
RETURN_EXP (scm_quotient (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. * 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); ARGS2 (x, y);
RETURN_EXP (scm_remainder (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. * 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); ARGS2 (x, y);
RETURN_EXP (scm_modulo (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. * 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); ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (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. * 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); ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (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. * 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); ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (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. * 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); ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (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 * will have space for LENGTH slots, an immediate value. They will be
* filled with the value in slot INIT. * filled with the value in slot INIT.
*/ */
VM_DEFINE_OP (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_uint8 dst, init;
scm_t_int32 length, n; 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. * 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); ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (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 * Fetch the item at position IDX in the vector in SRC, and store it
* in DST. * 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; scm_t_signed_bits i = 0;
ARGS2 (vect, idx); 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 * Fill DST with the item IDX elements into the vector at SRC. Useful
* for building data types using vectors. * for building data types using vectors.
*/ */
VM_DEFINE_OP (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_t_uint8 dst, src, idx;
SCM v; 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. * 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_t_uint8 dst, idx_var, src;
SCM vect, idx, val; 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 * Store SRC into the vector DST at index IDX. Here IDX is an
* immediate value. * 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_t_uint8 dst, idx, src;
SCM vect, val; SCM vect, val;
@ -2629,7 +2686,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* *
* Store the vtable of SRC into DST. * 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); ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable"); 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 * will be constructed with space for NFIELDS fields, which should
* correspond to the field count of the VTABLE. * correspond to the field count of the VTABLE.
*/ */
VM_DEFINE_OP (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_t_uint8 dst, vtable, nfields;
SCM ret; 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 * Fetch the item at slot IDX in the struct in SRC, and store it
* in DST. IDX is an immediate unsigned 8-bit value. * 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_t_uint8 dst, src, idx;
SCM obj; 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 * Store SRC into the struct DST at slot IDX. IDX is an immediate
* unsigned 8-bit value. * 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_t_uint8 dst, idx, src;
SCM obj, val; SCM obj, val;
@ -2717,7 +2774,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
* *
* Store the vtable of SRC into DST. * 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); ARGS1 (obj);
if (SCM_INSTANCEP (obj)) if (SCM_INSTANCEP (obj))
@ -2726,10 +2783,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
RETURN (scm_class_of (obj)); 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;
/* /*

11
module/language/cps.scm
View file

@ -121,7 +121,7 @@
$kif $kreceive $kargs $kentry $ktail $kclause $kif $kreceive $kargs $kentry $ktail $kclause
;; Expressions. ;; Expressions.
$void $const $prim $fun $call $primcall $values $prompt $void $const $prim $fun $call $callk $primcall $values $prompt
;; Building macros. ;; Building macros.
let-gensyms let-gensyms
@ -182,6 +182,7 @@
(define-cps-type $prim name) (define-cps-type $prim name)
(define-cps-type $fun src meta free body) (define-cps-type $fun src meta free body)
(define-cps-type $call proc args) (define-cps-type $call proc args)
(define-cps-type $callk k proc args)
(define-cps-type $primcall name args) (define-cps-type $primcall name args)
(define-cps-type $values args) (define-cps-type $values args)
(define-cps-type $prompt escape? tag handler) (define-cps-type $prompt escape? tag handler)
@ -226,7 +227,7 @@
(define-syntax build-cps-exp (define-syntax build-cps-exp
(syntax-rules (unquote (syntax-rules (unquote
$void $const $prim $fun $call $primcall $values $prompt) $void $const $prim $fun $call $callk $primcall $values $prompt)
((_ (unquote exp)) exp) ((_ (unquote exp)) exp)
((_ ($void)) (make-$void)) ((_ ($void)) (make-$void))
((_ ($const val)) (make-$const val)) ((_ ($const val)) (make-$const val))
@ -235,6 +236,8 @@
(make-$fun src meta free (build-cps-cont body))) (make-$fun src meta free (build-cps-cont body)))
((_ ($call proc (arg ...))) (make-$call proc (list arg ...))) ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
((_ ($call proc args)) (make-$call proc args)) ((_ ($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 (arg ...))) (make-$primcall name (list arg ...)))
((_ ($primcall name args)) (make-$primcall name args)) ((_ ($primcall name args)) (make-$primcall name args))
((_ ($values (arg ...))) (make-$values (list arg ...))) ((_ ($values (arg ...))) (make-$values (list arg ...)))
@ -336,6 +339,8 @@
($letrec name sym (map parse-cps fun) ,(parse-cps body)))) ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
(('call proc arg ...) (('call proc arg ...)
(build-cps-exp ($call proc arg))) (build-cps-exp ($call proc arg)))
(('callk k proc arg ...)
(build-cps-exp ($callk k proc arg)))
(('primcall name arg ...) (('primcall name arg ...)
(build-cps-exp ($primcall name arg))) (build-cps-exp ($primcall name arg)))
(('values arg ...) (('values arg ...)
@ -392,6 +397,8 @@
,(unparse-cps body))) ,(unparse-cps body)))
(($ $call proc args) (($ $call proc args)
`(call ,proc ,@args)) `(call ,proc ,@args))
(($ $callk k proc args)
`(callk ,k ,proc ,@args))
(($ $primcall name args) (($ $primcall name args)
`(primcall ,name ,@args)) `(primcall ,name ,@args))
(($ $values args) (($ $values args)

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

@ -136,11 +136,11 @@
,(adapt-exp 1 k src exp)) ,(adapt-exp 1 k src exp))
(($ $fun) (($ $fun)
,(adapt-exp 1 k src (fix-arities exp))) ,(adapt-exp 1 k src (fix-arities exp)))
(($ $call) ((or ($ $call) ($ $callk))
;; In general, calls have unknown return arity. For that ;; In general, calls have unknown return arity. For that
;; reason every non-tail call has an implicit adaptor ;; reason every non-tail call has a $kreceive continuation to
;; continuation to adapt the return to the target ;; adapt the return to the target continuation, and we don't
;; continuation, and we don't need to do any adapting here. ;; need to do any adapting here.
($continue k src ,exp)) ($continue k src ,exp))
(($ $primcall 'return (arg)) (($ $primcall 'return (arg))
;; Primcalls to return are in tail position. ;; Primcalls to return are in tail position.

8
module/language/cps/closure-conversion.scm
View file

@ -198,6 +198,14 @@ convert functions to flat closures."
($continue k src ($call proc args))) ($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)) (($ $continue k src ($ $primcall name args))
(convert-free-vars args self bound (convert-free-vars args self bound
(lambda (args) (lambda (args)

21
module/language/cps/compile-bytecode.scm
View file

@ -226,6 +226,13 @@
(let ((tail-slots (cdr (iota (1+ (length args)))))) (let ((tail-slots (cdr (iota (1+ (length args))))))
(for-each maybe-load-constant tail-slots args)) (for-each maybe-load-constant tail-slots args))
(emit-tail-call asm (1+ (length 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 ()) (($ $values ())
(emit-reset-frame asm 1) (emit-reset-frame asm 1)
(emit-return-values asm)) (emit-return-values asm))
@ -442,8 +449,7 @@
(($ $primcall '> (a b)) (binary emit-br-if-< b a)))) (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
(define (compile-trunc label k exp nreq rest-var nlocals) (define (compile-trunc label k exp nreq rest-var nlocals)
(match exp (define (do-call proc args emit-call)
(($ $call proc args)
(let* ((proc-slot (lookup-call-proc-slot label allocation)) (let* ((proc-slot (lookup-call-proc-slot label allocation))
(nargs (1+ (length args))) (nargs (1+ (length args)))
(arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs)))) (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
@ -472,7 +478,16 @@
(for-each (match-lambda (for-each (match-lambda
((src . dst) (emit-mov asm dst src))) ((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves k allocation)) (lookup-parallel-moves k allocation))
(emit-reset-frame asm nlocals))))))) (emit-reset-frame asm nlocals)))))
(match exp
(($ $call proc args)
(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 (match f
(($ $fun src meta free ($ $cont k ($ $kentry self tail clauses))) (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))

3
module/language/cps/dce.scm
View file

@ -147,6 +147,9 @@
(($ $call proc args) (($ $call proc args)
(mark-live! proc) (mark-live! proc)
(for-each mark-live! args)) (for-each mark-live! args))
(($ $callk k proc args)
(mark-live! proc)
(for-each mark-live! args))
(($ $primcall name args) (($ $primcall name args)
(for-each mark-live! args)) (for-each mark-live! args))
(($ $values args) (($ $values args)

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

@ -839,6 +839,10 @@ BODY for each body continuation in the prompt."
(use! proc) (use! proc)
(for-each use! args)) (for-each use! args))
(($ $callk k proc args)
(use! proc)
(for-each use! args))
(($ $primcall name args) (($ $primcall name args)
(for-each use! args)) (for-each use! args))
@ -979,6 +983,7 @@ BODY for each body continuation in the prompt."
(lambda (use) (lambda (use)
(match (find-expression (lookup-cont use conts)) (match (find-expression (lookup-cont use conts))
(($ $call) #f) (($ $call) #f)
(($ $callk) #f)
(($ $values) #f) (($ $values) #f)
(($ $primcall 'free-ref (closure slot)) (($ $primcall 'free-ref (closure slot))
(not (eq? sym slot))) (not (eq? sym slot)))

2
module/language/cps/effects-analysis.scm
View file

@ -451,7 +451,7 @@
(cause &allocation)) (cause &allocation))
(($ $prompt) (($ $prompt)
(cause &prompt)) (cause &prompt))
(($ $call) ((or ($ $call) ($ $callk))
(logior &all-effects-but-bailout (cause &all-effects-but-bailout))) (logior &all-effects-but-bailout (cause &all-effects-but-bailout)))
(($ $primcall name args) (($ $primcall name args)
(primitive-effects dfg name args)))) (primitive-effects dfg name args))))

3
module/language/cps/simplify.scm
View file

@ -255,6 +255,9 @@
(($ $call proc args) (($ $call proc args)
(let ((args (map subst args))) (let ((args (map subst args)))
(build-cps-exp ($call (subst proc) 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) (($ $primcall name args)
(let ((args (map subst args))) (let ((args (map subst args)))
(build-cps-exp ($primcall name args)))) (build-cps-exp ($primcall name args))))

8
module/language/cps/slot-allocation.scm
View file

@ -352,6 +352,8 @@ are comparable with eqv?. A tmp slot may be used."
(match (find-expression body) (match (find-expression body)
(($ $call proc args) (($ $call proc args)
(cons proc args)) (cons proc args))
(($ $callk k proc args)
(cons proc args))
(($ $primcall name args) (($ $primcall name args)
args) args)
(($ $values args) (($ $values args)
@ -423,7 +425,7 @@ are comparable with eqv?. A tmp slot may be used."
(match (vector-ref contv n) (match (vector-ref contv n)
(($ $kargs names syms body) (($ $kargs names syms body)
(match (find-expression body) (match (find-expression body)
(($ $call) ((or ($ $call) ($ $callk))
(let ((args (make-bitvector (bitvector-length needs-slotv) #f))) (let ((args (make-bitvector (bitvector-length needs-slotv) #f)))
(bit-set*! args (live-before n) #t) (bit-set*! args (live-before n) #t)
(bit-set*! args (live-after n) #f) (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) (if (bit-position #t dead 0)
(finish-hints n (live-before n) args) (finish-hints n (live-before n) args)
(scan-for-hints (1- n) args)))) (scan-for-hints (1- n) args))))
((or ($ $call) ($ $values)) ((or ($ $call) ($ $callk) ($ $values))
(finish-hints n (live-before n) args)))) (finish-hints n (live-before n) args))))
;; Otherwise we kill uses of the block entry. ;; Otherwise we kill uses of the block entry.
(_ (finish-hints n (live-before (1+ n)) args)))) (_ (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) (($ $kargs names syms body)
(let ((uses (vector-ref usev n))) (let ((uses (vector-ref usev n)))
(match (find-call body) (match (find-call body)
(($ $continue k src ($ $call)) (($ $continue k src (or ($ $call) ($ $callk)))
(allocate-call label k uses live post-live)) (allocate-call label k uses live post-live))
(($ $continue k src ($ $primcall)) #t) (($ $continue k src ($ $primcall)) #t)
(($ $continue k src ($ $values)) (($ $continue k src ($ $values))

7
module/language/cps/verify.scm
View file

@ -124,6 +124,13 @@
(($ $call (? symbol? proc) ((? symbol? arg) ...)) (($ $call (? symbol? proc) ((? symbol? arg) ...))
(check-var proc v-env) (check-var proc v-env)
(for-each (cut check-var <> v-env) arg)) (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) ...)) (($ $primcall (? symbol? name) ((? symbol? arg) ...))
(for-each (cut check-var <> v-env) arg)) (for-each (cut check-var <> v-env) arg))
(($ $values ((? symbol? arg) ...)) (($ $values ((? symbol? arg) ...))

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

@ -1275,7 +1275,7 @@ needed."
;; FIXME: Define these somewhere central, shared with C. ;; FIXME: Define these somewhere central, shared with C.
(define *bytecode-major-version* #x0202) (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) (define (link-dynamic-section asm text rw rw-init frame-maps)
"Link the dynamic section for an ELF image with bytecode @var{text}, "Link the dynamic section for an ELF image with bytecode @var{text},