[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-627-gb3ae2b5
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-627-gb3ae2b5 |
|
Date: |
Sun, 02 Feb 2014 22:31:18 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b3ae2b5068cbfcb6e9eec7ff96cd936f1c861396
The branch, master has been updated
via b3ae2b5068cbfcb6e9eec7ff96cd936f1c861396 (commit)
via 0320b1fc3f22e4edda5f79e949e5fccda49b8680 (commit)
from aef1fcf94e635c51bc1d0849ad1f60a1d1274276 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit b3ae2b5068cbfcb6e9eec7ff96cd936f1c861396
Author: Andy Wingo <address@hidden>
Date: Sun Feb 2 23:19:22 2014 +0100
Add VM and compiler support for calls to known procedures
* 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.
commit 0320b1fc3f22e4edda5f79e949e5fccda49b8680
Author: Andy Wingo <address@hidden>
Date: Sun Feb 2 19:15:48 2014 +0100
Remove code to run GC more frequently as process image size increased
* libguile/gc.c: Remove code that would try to run GC more frequently as
the process image size was increasing. Before, it was often the case
that the heap was the main component of image size, but with
expandable stacks and statically allocated data that is no longer
true. Also, once scm_gc_register_allocation was incorporated, we
don't need to be so conservative any more. It seems this code was
simply causing too many gc's to run. Removing it improves some
micro-benchmarks; time will tell.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/compiler.texi | 7 +
libguile/_scm.h | 4 +-
libguile/gc.c | 148 +----------------
libguile/vm-engine.c | 263 +++++++++++++++++-----------
module/language/cps.scm | 11 +-
module/language/cps/arities.scm | 8 +-
module/language/cps/closure-conversion.scm | 8 +
module/language/cps/compile-bytecode.scm | 73 +++++---
module/language/cps/dce.scm | 3 +
module/language/cps/dfg.scm | 5 +
module/language/cps/effects-analysis.scm | 2 +-
module/language/cps/simplify.scm | 3 +
module/language/cps/slot-allocation.scm | 8 +-
module/language/cps/verify.scm | 7 +
module/system/vm/assembler.scm | 2 +-
15 files changed, 258 insertions(+), 294 deletions(-)
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index 845d5a8..6407338 100644
--- a/doc/ref/compiler.texi
+++ b/doc/ref/compiler.texi
@@ -687,10 +687,17 @@ entry.
@end deftp
@deftp {CPS Expression} $call proc args
address@hidden {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.
+
address@hidden 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 4298612..003c36d 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/gc.c b/libguile/gc.c
index 7015af9..2bcdaff 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006,
- * 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ * 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -684,151 +684,9 @@ accumulate_gc_timer (void * hook_data SCM_UNUSED,
return NULL;
}
-/* Return some idea of the memory footprint of a process, in bytes.
- Currently only works on Linux systems. */
-static size_t
-get_image_size (void)
-{
- unsigned long size, resident, share;
- size_t ret = 0;
-
- FILE *fp = fopen ("/proc/self/statm", "r");
-
- if (fp && fscanf (fp, "%lu %lu %lu", &size, &resident, &share) == 3)
- ret = resident * 4096;
-
- if (fp)
- fclose (fp);
-
- return ret;
-}
-
-/* These are discussed later. */
static size_t bytes_until_gc = DEFAULT_INITIAL_HEAP_SIZE;
static scm_i_pthread_mutex_t bytes_until_gc_lock =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
-/* Make GC run more frequently when the process image size is growing,
- measured against the number of bytes allocated through the GC.
-
- If Guile is allocating at a GC-managed heap size H, libgc will tend
- to limit the process image size to H*N. But if at the same time the
- user program is mallocating at a rate M bytes per GC-allocated byte,
- then the process stabilizes at H*N*M -- assuming that collecting data
- will result in malloc'd data being freed. It doesn't take a very
- large M for this to be a bad situation. To limit the image size,
- Guile should GC more often -- the bigger the M, the more often.
-
- Numeric functions that produce bigger and bigger integers are
- pessimal, because M is an increasing function of time. Here is an
- example of such a function:
-
- (define (factorial n)
- (define (fac n acc)
- (if (<= n 1)
- acc
- (fac (1- n) (* n acc))))
- (fac n 1))
-
- It is possible for a process to grow for reasons that will not be
- solved by faster GC. In that case M will be estimated as
- artificially high for a while, and so GC will happen more often on
- the Guile side. But when it stabilizes, Guile can ease back the GC
- frequency.
-
- The key is to measure process image growth, not mallocation rate.
- For maximum effectiveness, Guile reacts quickly to process growth,
- and exponentially backs down when the process stops growing.
-
- See http://thread.gmane.org/gmane.lisp.guile.devel/12552/focus=12936
- for further discussion.
- */
-static void *
-adjust_gc_frequency (void * hook_data SCM_UNUSED,
- void *fn_data SCM_UNUSED,
- void *data SCM_UNUSED)
-{
- static size_t prev_image_size = 0;
- static size_t prev_bytes_alloced = 0;
- size_t image_size;
- size_t bytes_alloced;
-
- scm_i_pthread_mutex_lock (&bytes_until_gc_lock);
- bytes_until_gc = GC_get_heap_size ();
- scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
-
- image_size = get_image_size ();
- bytes_alloced = GC_get_total_bytes ();
-
-#define HEURISTICS_DEBUG 0
-
-#if HEURISTICS_DEBUG
- fprintf (stderr, "prev image / alloced: %lu / %lu\n", prev_image_size,
prev_bytes_alloced);
- fprintf (stderr, " image / alloced: %lu / %lu\n", image_size,
bytes_alloced);
- fprintf (stderr, "divisor %lu / %f\n", free_space_divisor,
target_free_space_divisor);
-#endif
-
- if (prev_image_size && bytes_alloced != prev_bytes_alloced)
- {
- double growth_rate, new_target_free_space_divisor;
- double decay_factor = 0.5;
- double hysteresis = 0.1;
-
- growth_rate = ((double) image_size - prev_image_size)
- / ((double)bytes_alloced - prev_bytes_alloced);
-
-#if HEURISTICS_DEBUG
- fprintf (stderr, "growth rate %f\n", growth_rate);
-#endif
-
- new_target_free_space_divisor = minimum_free_space_divisor;
-
- if (growth_rate > 0)
- new_target_free_space_divisor *= 1.0 + growth_rate;
-
-#if HEURISTICS_DEBUG
- fprintf (stderr, "new divisor %f\n", new_target_free_space_divisor);
-#endif
-
- if (new_target_free_space_divisor < target_free_space_divisor)
- /* Decay down. */
- target_free_space_divisor =
- (decay_factor * target_free_space_divisor
- + (1.0 - decay_factor) * new_target_free_space_divisor);
- else
- /* Jump up. */
- target_free_space_divisor = new_target_free_space_divisor;
-
-#if HEURISTICS_DEBUG
- fprintf (stderr, "new target divisor %f\n", target_free_space_divisor);
-#endif
-
- if (free_space_divisor + 0.5 + hysteresis < target_free_space_divisor
- || free_space_divisor - 0.5 - hysteresis > target_free_space_divisor)
- {
- free_space_divisor = lround (target_free_space_divisor);
-#if HEURISTICS_DEBUG
- fprintf (stderr, "new divisor %lu\n", free_space_divisor);
-#endif
- GC_set_free_space_divisor (free_space_divisor);
- }
- }
-
- prev_image_size = image_size;
- prev_bytes_alloced = bytes_alloced;
-
- return NULL;
-}
-
-/* The adjust_gc_frequency routine handles transients in the process
- image size. It can't handle instense non-GC-managed steady-state
- allocation though, as it decays the FSD at steady-state down to its
- minimum value.
-
- The only real way to handle continuous, high non-GC allocation is to
- let the GC know about it. This routine can handle non-GC allocation
- rates that are similar in size to the GC-managed heap size.
- */
-
void
scm_gc_register_allocation (size_t size)
{
@@ -866,10 +724,6 @@ scm_init_gc ()
scm_c_hook_add (&scm_before_gc_c_hook, start_gc_timer, NULL, 0);
scm_c_hook_add (&scm_after_gc_c_hook, accumulate_gc_timer, NULL, 0);
- /* GC_get_heap_usage does not take a lock, and so can run in the GC
- start hook. */
- scm_c_hook_add (&scm_before_gc_c_hook, adjust_gc_frequency, NULL, 0);
-
GC_set_start_callback (run_before_gc_c_hook);
#include "libguile/gc.x"
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index bc94a69..5edadd3 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 b4bcbb5..e0d708a 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 6c589a3..1cd8704 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 4221cb8..c03b409 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 adc5159..f897303 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 98c1f2c..8b16bd1 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 dd612eb..551b80e 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 46c7e88..66e6595 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 0e3c831..bd79098 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 a4e5129..24a6d5f 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 9da5037..10cb748 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 e040314..5ddc642 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},
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-627-gb3ae2b5,
Andy Wingo <=