[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-358-g8734229
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-358-g8734229 |
|
Date: |
Fri, 08 Nov 2013 13:24:28 +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=873422952847a458f5a236ee8d73e17963f0d58e
The branch, master has been updated
via 873422952847a458f5a236ee8d73e17963f0d58e (commit)
via 9f309e2cd9ec78408d2b0df77c46d44f7bddb368 (commit)
via f41accb9c26e3b4df4170bda04b8860ee962657f (commit)
via d547e1c9a647c8218bdf64b00e8c11af1f7d5a0a (commit)
via b0ed216b6f17f9f63fbf1d9542c0722241317837 (commit)
via f90c0554640c6e0c28ec01ed597a3b78b47bdd29 (commit)
via d2bd8fa810c130261135dd4b6676397ec517421f (commit)
via be564260bef9b2d0f9df64affdbcf7e9b02507d2 (commit)
via 6a59420a9d5ed5a3ee054f9de5615c577d1ec651 (commit)
via 0e3a59f75050041f4f6b423a53193609335f708d (commit)
via 1ab116f39075f8dcf1b6c8084d9afc547f9a85b7 (commit)
via 3a858c327539522d39c6a46d3a573909b030680d (commit)
via 697c4f29d93bb3b9dc44a666cf2e1b585f070da9 (commit)
via 7a5a533595ec3df028adea46eebeb76f72c832ec (commit)
via 581a4eb82b1534970060e3cbd79b9a96d351edf9 (commit)
via 72b82b0f210ef47798133dabf2a81eef3e036ba6 (commit)
via e15aa022847507c3eeb84c180d20a4209ece1cb6 (commit)
via 0128bb9c38b28e74675e72539a162b5cf9848845 (commit)
via 4b8d21c17c9e72fb6f61747099c0798d5e264496 (commit)
via 31602aa04aefe58fa780eb066caefd20f87b275b (commit)
via 32ca15d7d733202bd1495d1beed7251bd566ec2d (commit)
via 6e422a3599d0f293078576b1e77c74f408d80a14 (commit)
via 963d95f1d92248d2689efc8b67a9de1f1c8204fb (commit)
via 111a305be88a318f65707d251051d3b95c46d647 (commit)
via 0a1d52ac77e6424dbd1359827718af5a4d6c154a (commit)
via 3659ef543e9b55a9747a83414dd07336608e4c5d (commit)
via da60ba8062406cc017ecdd14f0a0bfc65245c449 (commit)
via 0d0465135d3cc5d7882fefa6bc4e68f132f594ed (commit)
via 3abe29e677f2fc40452492c3a20136efc4541c94 (commit)
via 8f4fbba55208ebca298e9b8e9da2045df3e8a88d (commit)
via d65514a2de2ef922d3613f0e35dea27a88313392 (commit)
via 9ae9debbd35505ef4040c1a876f7bd64434d6d14 (commit)
via 92afe25d5c162c29d971c2c36bd04a5b9d0b29c5 (commit)
via be6e40a1df4cc97d1bf3d4567e980b92454d5180 (commit)
via 91fc226e24bea970b5d6814fdceebd3c97c54a28 (commit)
via 1d15832ffc1e46be2d5549c744681cf88776698e (commit)
via 03f16599e37d91fdc7564e4baed9a489b2901dec (commit)
via 14b9aa95e61e2d593bd96ab0a7675ed72d55503c (commit)
via b681671ede9cefcbfa9d59169030b013f5ddfc6a (commit)
via d258fcccee2d96dc3cf90cecf3f3ee9ebb25b9db (commit)
via 4a565538bd9fe196494b3a4d4c9918bf5a6ed029 (commit)
via 58dee5b9e47c8186d894e847da0ff81aa9e9c073 (commit)
via cb8054c7acf7bcc05cefbe93ae242f394b9a105c (commit)
via ef47c4229c9c19db56bb0c123eba01c71c4a2011 (commit)
via 3e248c70e3be268b6ad71c9eee9895519ab0495f (commit)
via 5bff312598d025730976a52a27b8582b3707c73b (commit)
via dda5fd94de382e96b4c9bad9750aee3e4fe3bacc (commit)
via c7cb2bc20042cbaa4058b92eb36762e5ea72a1e0 (commit)
via 57a5cc97609bfb6e90952352095cc8245473b8c5 (commit)
via b73a2ee01773d910d82074a818c3955b45a6e6e1 (commit)
via 30b7cf9df0f51bc2a3553396dc368c197eab4d8d (commit)
via 6165d8120d5973ea177514d0632247e1d38904ee (commit)
via becce37b5835720857068c4865f1cd48275133d1 (commit)
via ecbef96687363cbf2eadeaaf8fab8d8efd33f944 (commit)
via 7bfbc7b1c50df58a26e3ffb88f809858a03b0e11 (commit)
via 6a37b7faaf150e9fb7945ef79969cb7671d17367 (commit)
via 334bd8e3c157fddf7a8f7b6c9d51358c15f257a3 (commit)
via 2ab2a10d508b521d4a1909fdd362811418f1aba4 (commit)
via 11eff826853a34bf0de205f13519659d4926d22c (commit)
via 4a39546bc4c06879464de80ad21b1b19786658bc (commit)
via 96af4a18b89f52bb94eb0ef69898b7f6a059beaa (commit)
via 2700f1983373a336d67bc622538988b36da73f09 (commit)
via 73ba69a633c63de7ef8344e10fba027102d1f245 (commit)
via 88e5caded5edf000f559c56d0ff2ea46d1ccffa1 (commit)
via 186b56c4dc870e0441a69b35ac9ea504251b6ca8 (commit)
via 486013d67c2db6b454c4b684f0317ff948bd6eb1 (commit)
via d76de8716d36e1fe419224119111fdb594a5d1b9 (commit)
from d6fbf0c00e913ab2726f98f70b3026aafb7fcdc6 (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 -----------------------------------------------------------------
-----------------------------------------------------------------------
Summary of changes:
.dir-locals.el | 2 +-
libguile/Makefile.am | 1 +
libguile/arrays.c | 7 +-
libguile/bitvectors.c | 8 +-
libguile/bytevectors.c | 5 +-
libguile/continuations.c | 20 --
libguile/continuations.h | 2 -
libguile/control.c | 104 ++----
libguile/eval.c | 29 +--
libguile/expand.c | 1 -
libguile/frames.c | 47 +--
libguile/gsubr.c | 4 +-
libguile/gsubr.h | 2 +-
libguile/memoize.c | 67 +++-
libguile/memoize.h | 1 +
libguile/objcodes.c | 23 ++
libguile/procprop.c | 7 +-
libguile/procs.c | 12 +-
libguile/programs.c | 24 ++-
libguile/programs.h | 2 +
libguile/uniform.c | 19 +
libguile/uniform.h | 3 +-
libguile/vm-builtins.h | 47 +++
libguile/vm-engine.c | 427 ++++++++++++++----------
libguile/vm-i-system.c | 4 +-
libguile/vm.c | 187 +++++++++--
libguile/vm.h | 3 +-
module/ice-9/boot-9.scm | 18 +-
module/ice-9/eval-string.scm | 4 +-
module/ice-9/eval.scm | 86 +++--
module/ice-9/match.upstream.scm | 13 +-
module/ice-9/session.scm | 5 +-
module/language/cps.scm | 91 +++---
module/language/cps/arities.scm | 144 +++++---
module/language/cps/closure-conversion.scm | 91 +++---
module/language/cps/compile-rtl.scm | 495 ++++++++++++++++------------
module/language/cps/constructors.scm | 52 ++--
module/language/cps/contification.scm | 117 ++++---
module/language/cps/dfg.scm | 385 ++++++++++++----------
module/language/cps/elide-values.scm | 30 +-
module/language/cps/primitives.scm | 25 ++-
module/language/cps/reify-primitives.scm | 118 +++++---
module/language/cps/slot-allocation.scm | 25 +-
module/language/cps/verify.scm | 23 +-
module/language/elisp/lexer.scm | 30 +-
module/language/rtl.scm | 7 +-
module/language/rtl/spec.scm | 13 +-
module/language/tree-il/compile-cps.scm | 287 ++++++++++------
module/language/tree-il/primitives.scm | 6 +-
module/language/tree-il/spec.scm | 4 +-
module/scripts/compile.scm | 4 +-
module/system/base/compile.scm | 4 +-
module/system/repl/command.scm | 43 +--
module/system/repl/common.scm | 5 +-
module/system/repl/debug.scm | 24 +-
module/system/repl/error-handling.scm | 6 +-
module/system/vm/assembler.scm | 201 ++++++++---
module/system/vm/coverage.scm | 362 +++++++++-----------
module/system/vm/debug.scm | 106 +++++-
module/system/vm/disassembler.scm | 13 +-
module/system/vm/dwarf.scm | 5 +-
module/system/vm/frame.scm | 11 +-
module/system/vm/objcode.scm | 2 +-
module/system/vm/program.scm | 22 +-
module/system/vm/trap-state.scm | 6 +-
test-suite/tests/bytevectors.test | 14 +-
test-suite/tests/compiler.test | 8 +-
test-suite/tests/coverage.test | 11 +-
test-suite/tests/dwarf.test | 12 +-
test-suite/tests/eval.test | 4 +-
test-suite/tests/peval.test | 2 +-
test-suite/tests/rtl.test | 6 +-
test-suite/tests/session.test | 6 +-
test-suite/tests/tree-il.test | 13 +-
74 files changed, 2371 insertions(+), 1646 deletions(-)
create mode 100644 libguile/vm-builtins.h
diff --git a/.dir-locals.el b/.dir-locals.el
index 94a2126..0589229 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -21,7 +21,7 @@
(eval . (put '$letk 'scheme-indent-function 1))
(eval . (put '$letk* 'scheme-indent-function 1))
(eval . (put '$letconst 'scheme-indent-function 1))
- (eval . (put '$continue 'scheme-indent-function 1))
+ (eval . (put '$continue 'scheme-indent-function 2))
(eval . (put '$kargs 'scheme-indent-function 2))
(eval . (put '$kentry 'scheme-indent-function 2))
(eval . (put '$kclause 'scheme-indent-function 1))
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index ce437e4..e3a9e00 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -639,6 +639,7 @@ modinclude_HEADERS = \
values.h \
variable.h \
vectors.h \
+ vm-builtins.h \
vm-expand.h \
vm.h \
vports.h \
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 83d7db2..98c8075 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005,
- * 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2006, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -242,8 +242,9 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds,
const void *bytes,
}
else if (sz < 8)
{
- /* byte_len ?= ceil (rlen * sz / 8) */
- if (byte_len != (rlen * sz + 7) / 8)
+ /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
+ units. */
+ if (byte_len != ((rlen * sz + 31) / 32) * 4)
SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
}
else
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index ffea6d1..2eef1dc 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -39,8 +39,8 @@
*/
#define IS_BITVECTOR(obj) SCM_TYP16_PREDICATE(scm_tc7_bitvector,(obj))
-#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_1(obj))
-#define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_2(obj))
+#define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_1(obj))
+#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_2(obj))
int
scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate)
@@ -110,7 +110,7 @@ scm_c_make_bitvector (size_t len, SCM fill)
bits = scm_gc_malloc_pointerless (sizeof (scm_t_uint32) * word_len,
"bitvector");
- res = scm_double_cell (scm_tc7_bitvector, (scm_t_bits)bits, len, 0);
+ res = scm_double_cell (scm_tc7_bitvector, len, (scm_t_bits)bits, 0);
if (!SCM_UNBNDP (fill))
scm_bitvector_fill_x (res, fill);
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index f91b845..064c427 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -649,8 +649,9 @@ SCM_DEFINE (scm_uniform_array_to_bytevector,
"uniform-array->bytevector",
if (sz >= 8 && ((sz % 8) == 0))
byte_len = len * (sz / 8);
else if (sz < 8)
- /* byte_len = ceil (len * sz / 8) */
- byte_len = (len * sz + 7) / 8;
+ /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
+ units. */
+ byte_len = ((len * sz + 31) / 32) * 4;
else
/* an internal guile error, really */
SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole
bytes", SCM_EOL);
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 58a1936..21fc5e2 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -68,15 +68,6 @@ static const scm_t_uint32 continuation_stub_code[] =
SCM_PACK_RTL_24 (scm_rtl_op_continuation_call, 0)
};
-/* Before Scheme's call/cc is compiled, eval.c will use this hand-coded
- call/cc. */
-
-static const scm_t_uint32 call_cc_code[] =
- {
- SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 2),
- SCM_PACK_RTL_24 (scm_rtl_op_call_cc, 0)
- };
-
static SCM
make_continuation_trampoline (SCM contregs)
{
@@ -175,17 +166,6 @@ scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
#undef FUNC_NAME
SCM
-scm_i_call_with_current_continuation (SCM proc)
-{
- static SCM call_cc = SCM_BOOL_F;
-
- if (scm_is_false (call_cc))
- call_cc = scm_i_make_rtl_program (call_cc_code);
-
- return scm_call_1 (call_cc, proc);
-}
-
-SCM
scm_i_continuation_to_frame (SCM continuation)
{
SCM contregs;
diff --git a/libguile/continuations.h b/libguile/continuations.h
index e7fa16d..ca658bd 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -74,8 +74,6 @@ SCM_INTERNAL SCM scm_i_make_continuation (int *first, SCM vm,
SCM vm_cont);
SCM_INTERNAL void scm_i_check_continuation (SCM cont);
SCM_INTERNAL void scm_i_reinstate_continuation (SCM cont);
-SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);
-
SCM_INTERNAL SCM scm_i_continuation_to_frame (SCM cont);
SCM_INTERNAL SCM scm_i_contregs_vm (SCM contregs);
SCM_INTERNAL SCM scm_i_contregs_vm_cont (SCM contregs);
diff --git a/libguile/control.c b/libguile/control.c
index 162ff14..7120ffe 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -24,7 +24,7 @@
#include "libguile/_scm.h"
#include "libguile/control.h"
-#include "libguile/objcodes.h"
+#include "libguile/programs.h"
#include "libguile/instructions.h"
#include "libguile/vm.h"
@@ -57,69 +57,25 @@ scm_i_prompt_pop_abort_args_x (SCM vm)
}
-#ifdef WORDS_BIGENDIAN
-#define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
-#define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
-#else
-#define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
-#define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
-#endif
+static const scm_t_uint32 compose_continuation_code[] =
+ {
+ SCM_PACK_RTL_24 (scm_rtl_op_compose_continuation, 0)
+ };
-#define OBJCODE_TAG SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0)
-
-#if defined (SCM_ALIGNED)
-#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym) \
-static const type sym[]
-#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
-static SCM_ALIGNED (alignment) const type sym[]
-#define SCM_STATIC_OBJCODE(sym) \
- SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
- SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
- { SCM_PACK (OBJCODE_TAG), SCM_PACK (sym##__bytecode) }, \
- { SCM_BOOL_F, SCM_PACK (0) } \
- }; \
- static const SCM sym = SCM_PACK (sym##__cells); \
- SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
-#else
-#define SCM_STATIC_OBJCODE(sym) \
-static SCM sym; \
-static scm_t_uint8 *sym##_bytecode; \
-SCM_SNARF_INIT(sym##_bytecode = scm_gc_malloc_pointerless
(sizeof(sym##_bytecode__unaligned), "partial continuation stub"); \
- memcpy (sym##_bytecode, sym##_bytecode__unaligned,
sizeof(sym##_bytecode__unaligned));) \
-SCM_SNARF_INIT(sym = scm_double_cell (OBJCODE_TAG, \
- (scm_t_bits)sym##_bytecode, \
- SCM_UNPACK (SCM_BOOL_F), \
- 0);) \
-static const scm_t_uint8 sym##_bytecode__unaligned[]
-#endif
+static SCM
+make_partial_continuation (SCM vm_cont)
+{
+ scm_t_bits nfree = 1;
+ scm_t_bits flags = SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION;
+ SCM ret;
-SCM_STATIC_OBJCODE (cont_objcode) = {
- /* Like in continuations.c, but with partial-cont-call. */
- OBJCODE_HEADER (8, 19),
- /* leave args on the stack */
- /* 0 */ scm_op_object_ref, 0, /* push scm_vm_cont object */
- /* 2 */ scm_op_partial_cont_call, /* and go! */
- /* 3 */ scm_op_nop,
- /* 4 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, /* pad to 8 bytes */
- /* 8 */
-
- /* We could put some meta-info to say that this proc is a continuation. Not
sure
- how to do that, though. */
- META_HEADER (19),
- /* 0 */ scm_op_make_eol, /* bindings */
- /* 1 */ scm_op_make_eol, /* sources */
- /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 3, /* arity: from ip 0 to ip
3 */
- /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
- /* 7 */ scm_op_make_int8_0, /* 0 optionals */
- /* 8 */ scm_op_make_true, /* and a rest arg */
- /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */
- /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one
list */
- /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list
*/
- /* 18 */ scm_op_return /* and return */
- /* 19 */
-};
+ ret = scm_words (scm_tc7_rtl_program | (nfree << 16) | flags, nfree + 2);
+ SCM_SET_CELL_WORD_1 (ret, compose_continuation_code);
+ SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 0, vm_cont);
+ return ret;
+}
static SCM
reify_partial_continuation (SCM vm,
@@ -128,8 +84,9 @@ reify_partial_continuation (SCM vm,
scm_t_dynstack *dynstack,
scm_i_jmp_buf *current_registers)
{
- SCM vm_cont, ret;
+ SCM vm_cont;
scm_t_uint32 flags;
+ SCM *bottom_fp;
flags = SCM_F_VM_CONT_PARTIAL;
/* If we are aborting to a prompt that has the same registers as those
@@ -139,15 +96,21 @@ reify_partial_continuation (SCM vm,
if (saved_registers && saved_registers == current_registers)
flags |= SCM_F_VM_CONT_REWINDABLE;
- /* Since non-escape continuations should begin with a thunk application, the
- first bit of the stack should be a frame, with the saved fp equal to the
fp
- that was current when the prompt was made. */
- if ((SCM*)SCM_UNPACK (saved_sp[1]) != saved_fp)
- abort ();
+ /* Walk the stack down until we find the first frame after saved_fp.
+ We will save the stack down to that frame. It used to be that we
+ could determine the stack bottom in O(1) time, but that's no longer
+ the case, since the thunk application doesn't occur where the
+ prompt is saved. */
+ for (bottom_fp = SCM_VM_DATA (vm)->fp;
+ SCM_FRAME_DYNAMIC_LINK (bottom_fp) > saved_fp;
+ bottom_fp = SCM_FRAME_DYNAMIC_LINK (bottom_fp));
+
+ if (SCM_FRAME_DYNAMIC_LINK (bottom_fp) != saved_fp)
+ abort();
/* Capture from the top of the thunk application frame up to the end. Set an
MVRA only, as the post-abort code is in an MV context. */
- vm_cont = scm_i_vm_capture_stack (saved_sp + 4,
+ vm_cont = scm_i_vm_capture_stack (bottom_fp - 1,
SCM_VM_DATA (vm)->fp,
SCM_VM_DATA (vm)->sp,
NULL,
@@ -155,12 +118,7 @@ reify_partial_continuation (SCM vm,
dynstack,
flags);
- ret = scm_make_program (cont_objcode,
- scm_c_make_vector (1, vm_cont),
- SCM_BOOL_F);
- SCM_SET_CELL_WORD_0 (ret,
- SCM_CELL_WORD_0 (ret) |
SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION);
- return ret;
+ return make_partial_continuation (vm_cont);
}
void
diff --git a/libguile/eval.c b/libguile/eval.c
index 43a182a..1572c87 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -245,18 +245,6 @@ truncate_values (SCM x)
}
#define EVAL1(x, env) (truncate_values (eval ((x), (env))))
-/* the environment:
- (VAL ... . MOD)
- If MOD is #f, it means the environment was captured before modules were
- booted.
- If MOD is the literal value '(), we are evaluating at the top level, and so
- should track changes to the current module. You have to be careful in this
- case, because further lexical contours should capture the current module.
-*/
-#define CAPTURE_ENV(env) \
- (scm_is_null (env) ? scm_current_module () : \
- (scm_is_false (env) ? scm_the_root_module () : env))
-
static SCM
eval (SCM x, SCM env)
{
@@ -288,8 +276,7 @@ eval (SCM x, SCM env)
SCM new_env;
int i;
- new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED,
- CAPTURE_ENV (env));
+ new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env);
for (i = 0; i < VECTOR_LENGTH (inits); i++)
env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
env = new_env;
@@ -298,7 +285,7 @@ eval (SCM x, SCM env)
}
case SCM_M_LAMBDA:
- RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
+ RETURN_BOOT_CLOSURE (mx, env);
case SCM_M_QUOTE:
return mx;
@@ -307,6 +294,9 @@ eval (SCM x, SCM env)
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
+ case SCM_M_CAPTURE_MODULE:
+ return eval (mx, scm_current_module ());
+
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
@@ -405,8 +395,7 @@ eval (SCM x, SCM env)
else
{
env = env_tail (env);
- return SCM_VARIABLE_REF
- (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
+ return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, env));
}
case SCM_M_TOPLEVEL_SET:
@@ -421,9 +410,7 @@ eval (SCM x, SCM env)
else
{
env = env_tail (env);
- SCM_VARIABLE_SET
- (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
- val);
+ SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, env), val);
return SCM_UNSPECIFIED;
}
}
@@ -654,7 +641,7 @@ scm_c_primitive_eval (SCM exp)
{
if (!SCM_EXPANDED_P (exp))
exp = scm_call_1 (scm_current_module_transformer (), exp);
- return eval (scm_memoize_expression (exp), SCM_EOL);
+ return eval (scm_memoize_expression (exp), SCM_BOOL_F);
}
static SCM var_primitive_eval;
diff --git a/libguile/expand.c b/libguile/expand.c
index a8625ea..7d6a6ed 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -173,7 +173,6 @@ SCM_SYNTAX ("case-lambda", expand_case_lambda);
SCM_SYNTAX ("case-lambda*", expand_case_lambda_star);
-SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
diff --git a/libguile/frames.c b/libguile/frames.c
index b2973bf..d32f837 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -104,18 +104,9 @@ SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_source
{
- SCM proc;
-
SCM_VALIDATE_VM_FRAME (1, frame);
- proc = scm_frame_procedure (frame);
-
- if (SCM_PROGRAM_P (proc) || SCM_RTL_PROGRAM_P (proc))
- return scm_program_source (scm_frame_procedure (frame),
- scm_frame_instruction_pointer (frame),
- SCM_UNDEFINED);
-
- return SCM_BOOL_F;
+ return scm_find_source_for_addr (scm_frame_instruction_pointer (frame));
}
#undef FUNC_NAME
@@ -142,7 +133,7 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0,
0,
/* The frame size of an RTL program is fixed, except in the case of
passing a wrong number of arguments to the program. So we do
need to use an SP for determining the number of locals. */
- return scm_from_uint32 (sp + 1 - p);
+ return scm_from_ptrdiff_t (sp + 1 - p);
sp = SCM_VM_FRAME_SP (frame);
p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
@@ -234,7 +225,7 @@ SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
#define FUNC_NAME s_scm_frame_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_FRAME_FP (frame));
+ return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_FP (frame));
}
#undef FUNC_NAME
@@ -245,7 +236,7 @@ SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer",
1, 0, 0,
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_FRAME_SP (frame));
+ return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_SP (frame));
}
#undef FUNC_NAME
@@ -254,22 +245,9 @@ SCM_DEFINE (scm_frame_instruction_pointer,
"frame-instruction-pointer", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_instruction_pointer
{
- SCM program;
- const struct scm_objcode *c_objcode;
-
SCM_VALIDATE_VM_FRAME (1, frame);
- program = scm_frame_procedure (frame);
-
- if (SCM_RTL_PROGRAM_P (program))
- return scm_from_ptrdiff_t (SCM_VM_FRAME_IP (frame) -
- (scm_t_uint8 *) SCM_RTL_PROGRAM_CODE (program));
-
- if (!SCM_PROGRAM_P (program))
- return SCM_INUM0;
- c_objcode = SCM_PROGRAM_DATA (program);
- return scm_from_unsigned_integer ((SCM_VM_FRAME_IP (frame)
- - SCM_C_OBJCODE_BASE (c_objcode)));
+ return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_IP (frame));
}
#undef FUNC_NAME
@@ -279,9 +257,8 @@ SCM_DEFINE (scm_frame_return_address,
"frame-return-address", 1, 0, 0,
#define FUNC_NAME s_scm_frame_return_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_unsigned_integer ((scm_t_bits)
- (SCM_FRAME_RETURN_ADDRESS
- (SCM_VM_FRAME_FP (frame))));
+ return scm_from_uintptr_t ((scm_t_uintptr) (SCM_FRAME_RETURN_ADDRESS
+ (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME
@@ -291,9 +268,9 @@ SCM_DEFINE (scm_frame_mv_return_address,
"frame-mv-return-address", 1, 0, 0,
#define FUNC_NAME s_scm_frame_mv_return_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_unsigned_integer ((scm_t_bits)
- (SCM_FRAME_MV_RETURN_ADDRESS
- (SCM_VM_FRAME_FP (frame))));
+ return scm_from_uintptr_t ((scm_t_uintptr)
+ (SCM_FRAME_MV_RETURN_ADDRESS
+ (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME
@@ -304,8 +281,8 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link",
1, 0, 0,
{
SCM_VALIDATE_VM_FRAME (1, frame);
/* fixme: munge fp if holder is a continuation */
- return scm_from_ulong
- ((unsigned long)
+ return scm_from_uintptr_t
+ ((scm_t_uintptr)
RELOC (frame,
SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
}
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 5dd767d..96fab4e 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -286,7 +286,7 @@ scm_i_primitive_arity (SCM prim, int *req, int *opt, int
*rest)
return 1;
}
-int
+scm_t_uintptr
scm_i_primitive_call_ip (SCM subr)
{
const scm_t_uint32 *code = SCM_RTL_PROGRAM_CODE (subr);
@@ -294,7 +294,7 @@ scm_i_primitive_call_ip (SCM subr)
/* A stub is 4 32-bit words long, or 16 bytes. The call will be one
instruction, in either the fourth, third, or second word. Return a
byte offset from the entry. */
- return code[3] ? 12 : code[2] ? 8 : 4;
+ return (scm_t_uintptr)(code + (code[3] ? 3 : code[2] ? 2 : 1));
}
SCM
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 6bdfe6b..3350e2f 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -55,7 +55,7 @@
SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int
*rest);
-SCM_INTERNAL int scm_i_primitive_call_ip (SCM subr);
+SCM_INTERNAL scm_t_uintptr scm_i_primitive_call_ip (SCM subr);
SCM_API SCM scm_c_make_gsubr (const char *name,
int req, int opt, int rst, scm_t_subr fcn);
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 6eb36d4..5c7129f 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -131,6 +131,8 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_QUOTE, exp)
#define MAKMEMO_DEFINE(var, val) \
MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
+#define MAKMEMO_CAPTURE_MODULE(exp) \
+ MAKMEMO (SCM_M_CAPTURE_MODULE, exp)
#define MAKMEMO_APPLY(proc, args)\
MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
#define MAKMEMO_CONT(proc) \
@@ -166,6 +168,7 @@ static const char *const memoized_tags[] =
"let",
"quote",
"define",
+ "capture-module",
"apply",
"call/cc",
"call-with-values",
@@ -240,6 +243,22 @@ memoize_exps (SCM exps, SCM env)
}
static SCM
+capture_env (SCM env)
+{
+ if (scm_is_false (env))
+ return SCM_BOOL_T;
+ return env;
+}
+
+static SCM
+maybe_makmemo_capture_module (SCM exp, SCM env)
+{
+ if (scm_is_false (env))
+ return MAKMEMO_CAPTURE_MODULE (exp);
+ return exp;
+}
+
+static SCM
memoize (SCM exp, SCM env)
{
if (!SCM_EXPANDED_P (exp))
@@ -255,7 +274,9 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_PRIMITIVE_REF:
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
- return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME)),
+ env);
else
return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F);
@@ -279,11 +300,15 @@ memoize (SCM exp, SCM env)
REF (exp, MODULE_SET, PUBLIC));
case SCM_EXPANDED_TOPLEVEL_REF:
- return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME)), env);
case SCM_EXPANDED_TOPLEVEL_SET:
- return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
- memoize (REF (exp, TOPLEVEL_SET, EXP), env));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
+ memoize (REF (exp, TOPLEVEL_SET, EXP),
+ capture_env (env))),
+ env);
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
@@ -343,7 +368,9 @@ memoize (SCM exp, SCM env)
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
- return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
+ return MAKMEMO_CALL (maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (name), env),
+ nargs, args);
else
return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
SCM_BOOL_F),
@@ -381,11 +408,11 @@ memoize (SCM exp, SCM env)
meta);
else
{
- proc = memoize (body, env);
+ proc = memoize (body, capture_env (env));
SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
}
- return proc;
+ return maybe_makmemo_capture_module (proc, env);
}
case SCM_EXPANDED_LAMBDA_CASE:
@@ -462,11 +489,12 @@ memoize (SCM exp, SCM env)
varsv = scm_vector (vars);
inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
SCM_BOOL_F);
- new_env = scm_cons (varsv, env);
+ new_env = scm_cons (varsv, capture_env (env));
for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
VECTOR_SET (inits, i, memoize (CAR (exps), env));
- return MAKMEMO_LET (inits, memoize (body, new_env));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (inits, memoize (body, new_env)), env);
}
case SCM_EXPANDED_LETREC:
@@ -484,7 +512,7 @@ memoize (SCM exp, SCM env)
expsv = scm_vector (exps);
undefs = scm_c_make_vector (nvars, MAKMEMO_QUOTE (SCM_UNDEFINED));
- new_env = scm_cons (varsv, env);
+ new_env = scm_cons (varsv, capture_env (env));
if (in_order_p)
{
@@ -495,7 +523,8 @@ memoize (SCM exp, SCM env)
body_exps = MAKMEMO_SEQ (MAKMEMO_LEX_SET (make_pos (0, i),
init),
body_exps);
}
- return MAKMEMO_LET (undefs, body_exps);
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (undefs, body_exps), env);
}
else
{
@@ -518,9 +547,11 @@ memoize (SCM exp, SCM env)
if (scm_is_false (sets))
return memoize (body, env);
- return MAKMEMO_LET (undefs,
- MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
- memoize (body, new_env)));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (undefs,
+ MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
+ memoize (body, new_env))),
+ env);
}
}
@@ -538,7 +569,7 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression",
1, 0, 0,
#define FUNC_NAME s_scm_memoize_expression
{
SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
- return memoize (exp, scm_current_module ());
+ return memoize (exp, SCM_BOOL_F);
}
#undef FUNC_NAME
@@ -612,6 +643,9 @@ unmemoize (const SCM expr)
unmemoize (CAR (args)), unmemoize (CDR (args)));
case SCM_M_DEFINE:
return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
+ case SCM_M_CAPTURE_MODULE:
+ return scm_list_2 (scm_from_latin1_symbol ("capture-module"),
+ unmemoize (args));
case SCM_M_IF:
return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
unmemoize (scm_cadr (args)), unmemoize (scm_cddr
(args)));
@@ -735,6 +769,9 @@ SCM_DEFINE (scm_memoize_variable_access_x,
"memoize-variable-access!", 2, 0, 0,
{
SCM mx = SCM_MEMOIZED_ARGS (m);
+ if (scm_is_false (mod))
+ mod = scm_the_root_module ();
+
switch (SCM_MEMOIZED_TAG (m))
{
case SCM_M_TOPLEVEL_REF:
diff --git a/libguile/memoize.h b/libguile/memoize.h
index 95e92a3..68dcd21 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -69,6 +69,7 @@ enum
SCM_M_LET,
SCM_M_QUOTE,
SCM_M_DEFINE,
+ SCM_M_CAPTURE_MODULE,
SCM_M_APPLY,
SCM_M_CONT,
SCM_M_CALL_WITH_VALUES,
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 734bdde..fa4e28b 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -741,6 +741,27 @@ scm_find_mapped_elf_image (SCM ip)
return result;
}
+static SCM
+scm_all_mapped_elf_images (void)
+{
+ SCM result = SCM_EOL;
+
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ {
+ size_t n;
+ for (n = 0; n < mapped_elf_images_count; n++)
+ {
+ signed char *data = (signed char *) mapped_elf_images[n].start;
+ size_t len = mapped_elf_images[n].end - mapped_elf_images[n].start;
+ result = scm_cons (scm_c_take_gc_bytevector (data, len, SCM_BOOL_F),
+ result);
+ }
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+
+ return result;
+}
+
/*
* Scheme interface
@@ -881,6 +902,8 @@ scm_init_objcodes (void)
scm_c_define_gsubr ("find-mapped-elf-image", 1, 0, 0,
(scm_t_subr) scm_find_mapped_elf_image);
+ scm_c_define_gsubr ("all-mapped-elf-images", 0, 0, 0,
+ (scm_t_subr) scm_all_mapped_elf_images);
scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 78a40c1..5bb9e62 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -33,6 +33,7 @@
#include "libguile/vectors.h"
#include "libguile/weak-table.h"
#include "libguile/programs.h"
+#include "libguile/vm-builtins.h"
#include "libguile/validate.h"
#include "libguile/procprop.h"
@@ -249,9 +250,6 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
SCM_VALIDATE_PROC (1, proc);
- while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
- proc = SCM_STRUCT_PROCEDURE (proc);
-
user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
if (scm_is_true (user_props))
{
@@ -266,6 +264,8 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
return scm_i_rtl_program_name (proc);
else if (SCM_PROGRAM_P (proc))
return scm_assq_ref (scm_i_program_properties (proc), scm_sym_name);
+ else if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ return scm_procedure_name (SCM_STRUCT_PROCEDURE (proc));
else
return SCM_BOOL_F;
}
@@ -343,6 +343,7 @@ scm_init_procprop ()
overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
arity_overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
#include "libguile/procprop.x"
+ scm_init_vm_builtin_properties ();
}
diff --git a/libguile/procs.c b/libguile/procs.c
index 8d9ef15..b021824 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -89,18 +89,10 @@ SCM_DEFINE (scm_make_procedure_with_setter,
"make-procedure-with-setter", 2, 0,
"with the associated setter @var{setter}.")
#define FUNC_NAME s_scm_make_procedure_with_setter
{
- SCM name, ret;
SCM_VALIDATE_PROC (1, procedure);
SCM_VALIDATE_PROC (2, setter);
- ret = scm_make_struct (pws_vtable, SCM_INUM0,
- scm_list_2 (procedure, setter));
-
- /* don't use procedure_name, because don't care enough to do a reverse
- lookup */
- name = scm_procedure_property (procedure, scm_sym_name);
- if (scm_is_true (name))
- scm_set_procedure_property_x (ret, scm_sym_name, name);
- return ret;
+ return scm_make_struct (pws_vtable, SCM_INUM0,
+ scm_list_2 (procedure, setter));
}
#undef FUNC_NAME
diff --git a/libguile/programs.c b/libguile/programs.c
index a0decdd..f74e4ed 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -106,8 +106,7 @@ SCM_DEFINE (scm_rtl_program_code, "rtl-program-code", 1, 0,
0,
{
SCM_VALIDATE_RTL_PROGRAM (1, program);
- /* FIXME: we need scm_from_uintptr (). */
- return scm_from_size_t ((size_t) SCM_RTL_PROGRAM_CODE (program));
+ return scm_from_uintptr_t ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program));
}
#undef FUNC_NAME
@@ -249,7 +248,7 @@ SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1,
0, 0,
{
SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
- return scm_from_int (scm_i_primitive_call_ip (prim));
+ return scm_from_uintptr_t (scm_i_primitive_call_ip (prim));
}
#undef FUNC_NAME
@@ -400,6 +399,22 @@ scm_i_program_properties (SCM program)
#undef FUNC_NAME
SCM
+scm_find_source_for_addr (SCM ip)
+{
+ static SCM source_for_addr = SCM_BOOL_F;
+
+ if (scm_is_false (source_for_addr)) {
+ if (!scm_module_system_booted_p)
+ return SCM_BOOL_F;
+
+ source_for_addr =
+ scm_c_private_variable ("system vm program", "source-for-addr");
+ }
+
+ return scm_call_1 (scm_variable_ref (source_for_addr), ip);
+}
+
+SCM
scm_program_source (SCM program, SCM ip, SCM sources)
{
static SCM program_source = SCM_BOOL_F;
@@ -527,7 +542,8 @@ scm_i_rtl_program_minimum_arity (SCM program, int *req, int
*opt, int *rest)
if (SCM_PROGRAM_IS_FOREIGN (program))
return scm_i_foreign_arity (program, req, opt, rest);
- if (SCM_PROGRAM_IS_CONTINUATION (program))
+ if (SCM_PROGRAM_IS_CONTINUATION (program)
+ || SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
{
*req = *opt = 0;
*rest = 1;
diff --git a/libguile/programs.h b/libguile/programs.h
index f2518ca..0d33957 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -51,6 +51,8 @@ SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program);
SCM_INTERNAL SCM scm_i_rtl_program_documentation (SCM program);
SCM_INTERNAL SCM scm_i_rtl_program_properties (SCM program);
+SCM_INTERNAL SCM scm_find_source_for_addr (SCM ip);
+
/*
* Programs
*/
diff --git a/libguile/uniform.c b/libguile/uniform.c
index a58242d..f8cd2d3 100644
--- a/libguile/uniform.c
+++ b/libguile/uniform.c
@@ -132,6 +132,25 @@ SCM_DEFINE (scm_uniform_vector_element_type,
"uniform-vector-element-type", 1, 0
}
#undef FUNC_NAME
+SCM_DEFINE (scm_uniform_vector_element_type_code,
+ "uniform-vector-element-type-code", 1, 0, 0,
+ (SCM v),
+ "Return the type of the elements in the uniform vector, @var{v},\n"
+ "as an integer code.")
+#define FUNC_NAME s_scm_uniform_vector_element_type_code
+{
+ scm_t_array_handle h;
+ SCM ret;
+
+ if (!scm_is_uniform_vector (v))
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, v, "uniform vector");
+ scm_array_get_handle (v, &h);
+ ret = scm_from_uint16 (h.element_type);
+ scm_array_handle_release (&h);
+ return ret;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_uniform_vector_element_size, "uniform-vector-element-size", 1,
0, 0,
(SCM v),
"Return the number of bytes allocated to each element in the\n"
diff --git a/libguile/uniform.h b/libguile/uniform.h
index f0d5915..f655a29 100644
--- a/libguile/uniform.h
+++ b/libguile/uniform.h
@@ -3,7 +3,7 @@
#ifndef SCM_UNIFORM_H
#define SCM_UNIFORM_H
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2013
Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -47,6 +47,7 @@ SCM_API void *scm_array_handle_uniform_writable_elements
(scm_t_array_handle *h)
SCM_API SCM scm_uniform_vector_p (SCM v);
SCM_API SCM scm_uniform_vector_length (SCM v);
SCM_API SCM scm_uniform_vector_element_type (SCM v);
+SCM_API SCM scm_uniform_vector_element_type_code (SCM v);
SCM_API SCM scm_uniform_vector_element_size (SCM v);
SCM_API SCM scm_uniform_vector_ref (SCM v, SCM idx);
SCM_API SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val);
diff --git a/libguile/vm-builtins.h b/libguile/vm-builtins.h
new file mode 100644
index 0000000..ea9b9e2
--- /dev/null
+++ b/libguile/vm-builtins.h
@@ -0,0 +1,47 @@
+/* Copyright (C) 2013 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#ifndef _SCM_VM_BUILTINS_H_
+#define _SCM_VM_BUILTINS_H_
+
+#ifdef BUILDING_LIBGUILE
+
+#define FOR_EACH_VM_BUILTIN(M) \
+ M(apply, APPLY, 2, 0, 1) \
+ M(values, VALUES, 0, 0, 1) \
+ M(abort_to_prompt, ABORT_TO_PROMPT, 1, 0, 1) \
+ M(call_with_values, CALL_WITH_VALUES, 2, 0, 0) \
+ M(call_with_current_continuation, CALL_WITH_CURRENT_CONTINUATION, 1, 0, 0)
+
+/* These enumerated values are embedded in RTL code, and as such are
+ part of Guile's ABI. */
+enum scm_vm_builtins
+{
+#define ENUM(builtin, BUILTIN, req, opt, rest) SCM_VM_BUILTIN_##BUILTIN,
+ FOR_EACH_VM_BUILTIN(ENUM)
+#undef ENUM
+ SCM_VM_BUILTIN_COUNT
+};
+
+SCM_INTERNAL SCM scm_vm_builtin_name_to_index (SCM name);
+SCM_INTERNAL SCM scm_vm_builtin_index_to_name (SCM idx);
+SCM_INTERNAL void scm_init_vm_builtin_properties (void);
+
+#endif /* BUILDING_LIBGUILE */
+
+#endif /* _SCM_VM_BUILTINS_H_ */
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 548dc4e..567bdbc 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -659,16 +659,16 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
do { \
SCM vals = vals_; \
VM_HANDLE_INTERRUPTS; \
- fp[-1] = rtl_apply; \
- fp[0] = rtl_values; \
+ fp[-1] = vm_builtin_apply; \
+ fp[0] = vm_builtin_values; \
fp[1] = vals; \
RESET_FRAME (3); \
- ip = (scm_t_uint32 *) rtl_apply_code; \
+ ip = (scm_t_uint32 *) vm_builtin_apply_code; \
goto op_tail_apply; \
} while (0)
#define BR_NARGS(rel) \
- scm_t_uint16 expected; \
+ scm_t_uint32 expected; \
SCM_UNPACK_RTL_24 (op, expected); \
if (FRAME_LOCALS_COUNT() rel expected) \
{ \
@@ -1022,7 +1022,8 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
/* tail-call nlocals:24
*
* Tail-call a procedure. Requires that the procedure and all of the
- * arguments have already been shuffled into position.
+ * arguments have already been shuffled into position. Will reset the
+ * frame to NLOCALS.
*/
VM_DEFINE_OP (2, tail_call, "tail-call", OP1 (U8_U24))
{
@@ -1033,6 +1034,39 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
VM_HANDLE_INTERRUPTS;
RESET_FRAME (nlocals);
+
+ APPLY_HOOK ();
+
+ if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+ goto apply;
+
+ ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ NEXT (0);
+ }
+
+ /* tail-call/shuffle from:24
+ *
+ * Tail-call a procedure. The procedure should already be set to slot
+ * 0. The rest of the args are taken from the frame, starting at
+ * 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))
+ {
+ scm_t_uint32 n, from, nlocals;
+
+ SCM_UNPACK_RTL_24 (op, from);
+
+ VM_HANDLE_INTERRUPTS;
+
+ VM_ASSERT (from > 0, abort ());
+ nlocals = FRAME_LOCALS_COUNT ();
+
+ for (n = 0; from + n < nlocals; n++)
+ LOCAL_SET (n + 1, LOCAL_REF (from + n));
+
+ RESET_FRAME (n + 1);
+
APPLY_HOOK ();
if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
@@ -1048,7 +1082,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* PROC, asserting that the call actually returned at least one
* value. Afterwards, resets the frame to NLOCALS locals.
*/
- VM_DEFINE_OP (3, receive, "receive", OP2 (U8_U12_U12, X8_U24) | OP_DST)
+ VM_DEFINE_OP (4, receive, "receive", OP2 (U8_U12_U12, X8_U24) | OP_DST)
{
scm_t_uint16 dst, proc;
scm_t_uint32 nlocals;
@@ -1068,7 +1102,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* return values equals NVALUES exactly. After receive-values has
* run, the values can be copied down via `mov'.
*/
- VM_DEFINE_OP (4, receive_values, "receive-values", OP2 (U8_U24, B1_X7_U24))
+ VM_DEFINE_OP (5, receive_values, "receive-values", OP2 (U8_U24, B1_X7_U24))
{
scm_t_uint32 proc, nvalues;
SCM_UNPACK_RTL_24 (op, proc);
@@ -1077,7 +1111,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
VM_ASSERT (FRAME_LOCALS_COUNT () > proc + nvalues,
vm_error_not_enough_values ());
else
- VM_ASSERT (FRAME_LOCALS_COUNT () == proc + nvalues,
+ VM_ASSERT (FRAME_LOCALS_COUNT () == proc + 1 + nvalues,
vm_error_wrong_number_of_values (nvalues));
NEXT (2);
}
@@ -1086,7 +1120,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Return a value.
*/
- VM_DEFINE_OP (5, return, "return", OP1 (U8_U24))
+ VM_DEFINE_OP (6, return, "return", OP1 (U8_U24))
{
scm_t_uint32 src;
SCM_UNPACK_RTL_24 (op, src);
@@ -1101,7 +1135,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* shuffled down to a contiguous array starting at slot 1.
* We also expect the frame has already been reset.
*/
- VM_DEFINE_OP (6, return_values, "return-values", OP1 (U8_X24))
+ VM_DEFINE_OP (7, return_values, "return-values", OP1 (U8_X24))
{
scm_t_uint32 nvalues _GL_UNUSED = FRAME_LOCALS_COUNT();
SCM *base = fp;
@@ -1134,7 +1168,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* calling frame. This instruction is part of the trampolines
* created in gsubr.c, and is not generated by the compiler.
*/
- VM_DEFINE_OP (7, subr_call, "subr-call", OP1 (U8_U24))
+ VM_DEFINE_OP (8, subr_call, "subr-call", OP1 (U8_U24))
{
scm_t_uint32 ptr_idx;
SCM pointer, ret;
@@ -1204,7 +1238,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* part of the trampolines created by the FFI, and is not generated by
* the compiler.
*/
- VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (9, foreign_call, "foreign-call", OP1 (U8_U12_U12))
{
scm_t_uint16 cif_idx, ptr_idx;
SCM closure, cif, pointer, ret;
@@ -1238,7 +1272,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* the implementation of undelimited continuations, and is not
* generated by the compiler.
*/
- VM_DEFINE_OP (9, continuation_call, "continuation-call", OP1 (U8_U24))
+ VM_DEFINE_OP (10, continuation_call, "continuation-call", OP1 (U8_U24))
{
SCM contregs;
scm_t_uint32 contregs_idx;
@@ -1267,13 +1301,13 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* instruction is part of the implementation of partial continuations,
* and is not generated by the compiler.
*/
- VM_DEFINE_OP (10, compose_continuation, "compose-continuation", OP1 (U8_U24))
+ VM_DEFINE_OP (11, compose_continuation, "compose-continuation", OP1 (U8_U24))
{
SCM vmcont;
scm_t_uint32 cont_idx;
SCM_UNPACK_RTL_24 (op, cont_idx);
- vmcont = LOCAL_REF (cont_idx);
+ vmcont = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), cont_idx);
SYNC_IP ();
VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
@@ -1291,7 +1325,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* arguments. This instruction is part of the implementation of
* `apply', and is not generated by the compiler.
*/
- VM_DEFINE_OP (11, tail_apply, "tail-apply", OP1 (U8_X24))
+ VM_DEFINE_OP (12, tail_apply, "tail-apply", OP1 (U8_X24))
{
int i, list_idx, list_len, nlocals;
SCM list;
@@ -1336,7 +1370,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* 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 (12, call_cc, "call/cc", OP1 (U8_X24))
+ VM_DEFINE_OP (13, call_cc, "call/cc", OP1 (U8_X24))
{
SCM vm_cont, cont;
scm_t_dynstack *dynstack;
@@ -1382,6 +1416,43 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
}
}
+ /* abort _:24
+ *
+ * Abort to a prompt handler. The tag is expected in r1, and the rest
+ * 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))
+ {
+ scm_t_uint32 nlocals = FRAME_LOCALS_COUNT ();
+
+ ASSERT (nlocals >= 2);
+ /* FIXME: Really we should capture the caller's registers. Until
+ then, manually advance the IP so that when the prompt resumes,
+ it continues with the next instruction. */
+ ip++;
+ SYNC_IP ();
+ vm_abort (vm, LOCAL_REF (1), nlocals - 2, &LOCAL_REF (2),
+ SCM_EOL, &LOCAL_REF (0), ®isters);
+
+ /* vm_abort should not return */
+ abort ();
+ }
+
+ /* builtin-ref dst:12 idx:12
+ *
+ * Load a builtin stub by index into DST.
+ */
+ VM_DEFINE_OP (15, builtin_ref, "builtin-ref", OP1 (U8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst, idx;
+
+ SCM_UNPACK_RTL_12_12 (op, dst, idx);
+ LOCAL_SET (dst, scm_vm_builtin_ref (idx));
+
+ NEXT (1);
+ }
+
@@ -1397,15 +1468,15 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
* the current instruction pointer.
*/
- VM_DEFINE_OP (13, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
+ VM_DEFINE_OP (16, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
{
BR_NARGS (!=);
}
- VM_DEFINE_OP (14, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
+ VM_DEFINE_OP (17, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
{
BR_NARGS (<);
}
- VM_DEFINE_OP (15, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
+ VM_DEFINE_OP (18, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
{
BR_NARGS (>);
}
@@ -1417,7 +1488,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the number of actual arguments is not ==, >=, or <= EXPECTED,
* respectively, signal an error.
*/
- VM_DEFINE_OP (16, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
+ VM_DEFINE_OP (19, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
@@ -1425,7 +1496,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
NEXT (1);
}
- VM_DEFINE_OP (17, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
+ VM_DEFINE_OP (20, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
@@ -1433,7 +1504,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
NEXT (1);
}
- VM_DEFINE_OP (18, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
+ VM_DEFINE_OP (21, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
{
scm_t_uint32 expected;
SCM_UNPACK_RTL_24 (op, expected);
@@ -1448,7 +1519,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* setting them all to SCM_UNDEFINED, except those nargs values that
* were passed as arguments and procedure.
*/
- VM_DEFINE_OP (19, alloc_frame, "alloc-frame", OP1 (U8_U24))
+ VM_DEFINE_OP (22, alloc_frame, "alloc-frame", OP1 (U8_U24))
{
scm_t_uint32 nlocals, nargs;
SCM_UNPACK_RTL_24 (op, nlocals);
@@ -1467,7 +1538,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Used to reset the frame size to something less than the size that
* was previously set via alloc-frame.
*/
- VM_DEFINE_OP (20, reset_frame, "reset-frame", OP1 (U8_U24))
+ VM_DEFINE_OP (23, reset_frame, "reset-frame", OP1 (U8_U24))
{
scm_t_uint32 nlocals;
SCM_UNPACK_RTL_24 (op, nlocals);
@@ -1480,7 +1551,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
* number of locals reserved is EXPECTED + NLOCALS.
*/
- VM_DEFINE_OP (21, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1
(U8_U12_U12))
+ VM_DEFINE_OP (24, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1
(U8_U12_U12))
{
scm_t_uint16 expected, nlocals;
SCM_UNPACK_RTL_12_12 (op, expected, nlocals);
@@ -1493,6 +1564,41 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (1);
}
+ /* br-if-npos-gt nreq:24 _:8 npos:24 _:8 offset:24
+ *
+ * Find the first positional argument after NREQ. If it is greater
+ * than NPOS, jump to OFFSET.
+ *
+ * This instruction is only emitted for functions with multiple
+ * clauses, and an earlier clause has keywords and no rest arguments.
+ * 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))
+ {
+ scm_t_uint32 nreq, npos;
+
+ SCM_UNPACK_RTL_24 (op, nreq);
+ SCM_UNPACK_RTL_24 (ip[1], npos);
+
+ /* We can only have too many positionals if there are more
+ arguments than NPOS. */
+ if (FRAME_LOCALS_COUNT() > npos)
+ {
+ scm_t_uint32 n;
+ for (n = nreq; n < npos; n++)
+ if (scm_is_keyword (LOCAL_REF (n)))
+ break;
+ if (n == npos && !scm_is_keyword (LOCAL_REF (n)))
+ {
+ scm_t_int32 offset = ip[2];
+ offset >>= 8; /* Sign-extending shift. */
+ NEXT (offset);
+ }
+ }
+ NEXT (3);
+ }
+
/* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
* _:8 ntotal:24 kw-offset:32
*
@@ -1505,7 +1611,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* A macro-mega-instruction.
*/
- VM_DEFINE_OP (22, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24,
N32))
+ VM_DEFINE_OP (26, 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;
@@ -1591,7 +1697,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Collect any arguments at or above DST into a list, and store that
* list at DST.
*/
- VM_DEFINE_OP (23, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (27, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst, nargs;
SCM rest = SCM_EOL;
@@ -1633,7 +1739,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Add OFFSET, a signed 24-bit number, to the current instruction
* pointer.
*/
- VM_DEFINE_OP (24, br, "br", OP1 (U8_L24))
+ VM_DEFINE_OP (28, br, "br", OP1 (U8_L24))
{
scm_t_int32 offset = op;
offset >>= 8; /* Sign-extending shift. */
@@ -1645,7 +1751,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is true for the purposes of Scheme, add
* OFFSET, a signed 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (25, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (29, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_true (x));
}
@@ -1655,7 +1761,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
* signed 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (26, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (30, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_null (x));
}
@@ -1665,7 +1771,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
* number, to the current instruction pointer.
*/
- VM_DEFINE_OP (27, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (31, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_lisp_false (x));
}
@@ -1675,7 +1781,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
* to the current instruction pointer.
*/
- VM_DEFINE_OP (28, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (32, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_pair (x));
}
@@ -1685,7 +1791,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is a struct, add OFFSET, a signed 24-bit
* number, to the current instruction pointer.
*/
- VM_DEFINE_OP (29, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (33, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_STRUCTP (x));
}
@@ -1695,7 +1801,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST is a char, add OFFSET, a signed 24-bit number,
* to the current instruction pointer.
*/
- VM_DEFINE_OP (30, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
+ VM_DEFINE_OP (34, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_CHARP (x));
}
@@ -1705,7 +1811,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in TEST has the TC7 given in the second word, add
* OFFSET, a signed 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (31, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
+ VM_DEFINE_OP (35, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
{
BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f));
}
@@ -1715,7 +1821,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is eq? to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (32, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (36, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y, scm_is_eq (x, y));
}
@@ -1725,7 +1831,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is eqv? to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (33, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (37, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
@@ -1740,7 +1846,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* 24-bit number, to the current instruction pointer.
*/
// FIXME: should sync_ip before calling out?
- VM_DEFINE_OP (34, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (38, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
@@ -1753,7 +1859,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is = to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (35, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (39, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_ARITHMETIC (==, scm_num_eq_p);
}
@@ -1763,7 +1869,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is < to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (36, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (40, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_ARITHMETIC (<, scm_less_p);
}
@@ -1773,7 +1879,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* If the value in A is <= to the value in B, add OFFSET, a signed
* 24-bit number, to the current instruction pointer.
*/
- VM_DEFINE_OP (37, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24))
+ VM_DEFINE_OP (41, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_ARITHMETIC (<=, scm_leq_p);
}
@@ -1789,7 +1895,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Copy a value from one local slot to another.
*/
- VM_DEFINE_OP (38, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (42, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst;
scm_t_uint16 src;
@@ -1804,7 +1910,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Copy a value from one local slot to another.
*/
- VM_DEFINE_OP (39, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
+ VM_DEFINE_OP (43, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
{
scm_t_uint32 dst;
scm_t_uint32 src;
@@ -1820,7 +1926,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Create a new variable holding SRC, and place it in DST.
*/
- VM_DEFINE_OP (40, box, "box", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (44, box, "box", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -1833,7 +1939,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Unpack the variable at SRC into DST, asserting that the variable is
* actually bound.
*/
- VM_DEFINE_OP (41, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (45, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
SCM var;
@@ -1851,7 +1957,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the contents of the variable at DST to SET.
*/
- VM_DEFINE_OP (42, box_set, "box-set!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (46, box_set, "box-set!", OP1 (U8_U12_U12))
{
scm_t_uint16 dst, src;
SCM var;
@@ -1870,7 +1976,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* signed 32-bit integer. Space for NFREE free variables will be
* allocated.
*/
- VM_DEFINE_OP (43, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) |
OP_DST)
+ VM_DEFINE_OP (47, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) |
OP_DST)
{
scm_t_uint32 dst, nfree, n;
scm_t_int32 offset;
@@ -1894,7 +2000,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Load free variable IDX from the closure SRC into local slot DST.
*/
- VM_DEFINE_OP (44, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
+ VM_DEFINE_OP (48, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
{
scm_t_uint16 dst, src;
scm_t_uint32 idx;
@@ -1909,7 +2015,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set free variable IDX from the closure DST to SRC.
*/
- VM_DEFINE_OP (45, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
+ VM_DEFINE_OP (49, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
{
scm_t_uint16 dst, src;
scm_t_uint32 idx;
@@ -1932,7 +2038,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Make an immediate whose low bits are LOW-BITS, and whose top bits are
* 0.
*/
- VM_DEFINE_OP (46, make_short_immediate, "make-short-immediate", OP1
(U8_U8_I16) | OP_DST)
+ VM_DEFINE_OP (50, make_short_immediate, "make-short-immediate", OP1
(U8_U8_I16) | OP_DST)
{
scm_t_uint8 dst;
scm_t_bits val;
@@ -1947,9 +2053,9 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Make an immediate whose low bits are LOW-BITS, and whose top bits are
* 0.
*/
- VM_DEFINE_OP (47, make_long_immediate, "make-long-immediate", OP2 (U8_U24,
I32))
+ VM_DEFINE_OP (51, make_long_immediate, "make-long-immediate", OP2 (U8_U24,
I32))
{
- scm_t_uint8 dst;
+ scm_t_uint32 dst;
scm_t_bits val;
SCM_UNPACK_RTL_24 (op, dst);
@@ -1962,9 +2068,9 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Make an immediate with HIGH-BITS and LOW-BITS.
*/
- VM_DEFINE_OP (48, make_long_long_immediate, "make-long-long-immediate", OP3
(U8_U24, A32, B32) | OP_DST)
+ VM_DEFINE_OP (52, make_long_long_immediate, "make-long-long-immediate", OP3
(U8_U24, A32, B32) | OP_DST)
{
- scm_t_uint8 dst;
+ scm_t_uint32 dst;
scm_t_bits val;
SCM_UNPACK_RTL_24 (op, dst);
@@ -1993,7 +2099,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Whether the object is mutable or immutable depends on where it was
* allocated by the compiler, and loaded by the loader.
*/
- VM_DEFINE_OP (49, make_non_immediate, "make-non-immediate", OP2 (U8_U24,
N32) | OP_DST)
+ VM_DEFINE_OP (53, make_non_immediate, "make-non-immediate", OP2 (U8_U24,
N32) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 offset;
@@ -2022,7 +2128,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* that the compiler is unable to statically allocate, like symbols.
* These values would be initialized when the object file loads.
*/
- VM_DEFINE_OP (50, static_ref, "static-ref", OP2 (U8_U24, S32))
+ VM_DEFINE_OP (54, static_ref, "static-ref", OP2 (U8_U24, S32))
{
scm_t_uint32 dst;
scm_t_int32 offset;
@@ -2045,7 +2151,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Store a SCM value into memory, OFFSET 32-bit words away from the
* current instruction pointer. OFFSET is a signed value.
*/
- VM_DEFINE_OP (51, static_set, "static-set!", OP2 (U8_U24, LO32))
+ VM_DEFINE_OP (55, static_set, "static-set!", OP2 (U8_U24, LO32))
{
scm_t_uint32 src;
scm_t_int32 offset;
@@ -2061,25 +2167,28 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (2);
}
- /* link-procedure! src:24 offset:32
+ /* static-patch! _:24 dst-offset:32 src-offset:32
*
- * Set the code pointer of the procedure in SRC to point OFFSET 32-bit
- * words away from the current instruction pointer. OFFSET is a
- * signed value.
+ * Patch a pointer at DST-OFFSET to point to SRC-OFFSET. Both offsets
+ * 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 (52, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
+ VM_DEFINE_OP (56, static_patch, "static-patch!", OP3 (U8_X24, LO32, L32))
{
- scm_t_uint32 src;
- scm_t_int32 offset;
- scm_t_uint32* loc;
+ scm_t_int32 dst_offset, src_offset;
+ void *src;
+ void** dst_loc;
- SCM_UNPACK_RTL_24 (op, src);
- offset = ip[1];
- loc = ip + offset;
+ dst_offset = ip[1];
+ src_offset = ip[2];
- SCM_SET_CELL_WORD_1 (LOCAL_REF (src), (scm_t_bits) loc);
+ dst_loc = (void **) (ip + dst_offset);
+ src = ip + src_offset;
+ VM_ASSERT (ALIGNED_P (dst_loc, void*), abort());
- NEXT (2);
+ *dst_loc = src;
+
+ NEXT (3);
}
@@ -2122,7 +2231,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the current module in DST.
*/
- VM_DEFINE_OP (53, current_module, "current-module", OP1 (U8_U24) | OP_DST)
+ VM_DEFINE_OP (57, current_module, "current-module", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst;
@@ -2139,7 +2248,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Resolve SYM in the current module, and place the resulting variable
* in DST.
*/
- VM_DEFINE_OP (54, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST)
+ VM_DEFINE_OP (58, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST)
{
scm_t_uint32 dst;
scm_t_uint32 sym;
@@ -2158,12 +2267,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (2);
}
- /* define sym:12 val:12
+ /* define! sym:12 val:12
*
* Look up a binding for SYM in the current module, creating it if
* necessary. Set its value to VAL.
*/
- VM_DEFINE_OP (55, define, "define", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (59, define, "define!", OP1 (U8_U12_U12))
{
scm_t_uint16 sym, val;
SCM_UNPACK_RTL_12_12 (op, sym, val);
@@ -2191,7 +2300,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* DST, and caching the resolved variable so that we will hit the cache next
* time.
*/
- VM_DEFINE_OP (56, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32,
B1_X31) | OP_DST)
+ VM_DEFINE_OP (60, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32,
B1_X31) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2243,7 +2352,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Like toplevel-box, except MOD-OFFSET points at the name of a module
* instead of the module itself.
*/
- VM_DEFINE_OP (57, module_box, "module-box", OP5 (U8_U24, S32, N32, N32,
B1_X31) | OP_DST)
+ VM_DEFINE_OP (61, module_box, "module-box", OP5 (U8_U24, S32, N32, N32,
B1_X31) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2313,7 +2422,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* will expect a multiple-value return as if from a call with the
* procedure at PROC-SLOT.
*/
- VM_DEFINE_OP (58, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24))
+ VM_DEFINE_OP (62, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24))
{
scm_t_uint32 tag, proc_slot;
scm_t_int32 offset;
@@ -2345,7 +2454,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* the compiler should have inserted checks that they wind and unwind
* procs are thunks, if it could not prove that to be the case.
*/
- VM_DEFINE_OP (59, wind, "wind", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (63, wind, "wind", OP1 (U8_U12_U12))
{
scm_t_uint16 winder, unwinder;
SCM_UNPACK_RTL_12_12 (op, winder, unwinder);
@@ -2354,38 +2463,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (1);
}
- /* abort tag:24 _:8 proc:24
- *
- * Return a number of values to a prompt handler. The values are
- * expected in a frame pushed on at PROC.
- */
- VM_DEFINE_OP (60, abort, "abort", OP2 (U8_U24, X8_U24))
-#if 0
- {
- scm_t_uint32 tag, from, nvalues;
- SCM *base;
-
- SCM_UNPACK_RTL_24 (op, tag);
- SCM_UNPACK_RTL_24 (ip[1], from);
- base = (fp - 1) + from + 3;
- nvalues = FRAME_LOCALS_COUNT () - from - 3;
-
- SYNC_IP ();
- vm_abort (vm, LOCAL_REF (tag), base, nvalues, ®isters);
-
- /* vm_abort should not return */
- abort ();
- }
-#else
- abort();
-#endif
-
/* unwind _:24
*
* A normal exit from the dynamic extent of an expression. Pop the top
* entry off of the dynamic stack.
*/
- VM_DEFINE_OP (61, unwind, "unwind", OP1 (U8_X24))
+ VM_DEFINE_OP (64, unwind, "unwind", OP1 (U8_X24))
{
scm_dynstack_pop (¤t_thread->dynstack);
NEXT (1);
@@ -2397,7 +2480,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* allocated in a continguous range on the stack, starting from
* FLUID-BASE. The values do not have this restriction.
*/
- VM_DEFINE_OP (62, push_fluid, "push-fluid", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (65, push_fluid, "push-fluid", OP1 (U8_U12_U12))
{
scm_t_uint32 fluid, value;
@@ -2414,7 +2497,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Leave the dynamic extent of a with-fluids expression, restoring the
* fluids to their previous values.
*/
- VM_DEFINE_OP (63, pop_fluid, "pop-fluid", OP1 (U8_X24))
+ VM_DEFINE_OP (66, pop_fluid, "pop-fluid", OP1 (U8_X24))
{
/* This function must not allocate. */
scm_dynstack_unwind_fluid (¤t_thread->dynstack,
@@ -2426,7 +2509,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Reference the fluid in SRC, and place the value in DST.
*/
- VM_DEFINE_OP (64, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (67, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
size_t num;
@@ -2459,7 +2542,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the value of the fluid in DST to the value in SRC.
*/
- VM_DEFINE_OP (65, fluid_set, "fluid-set", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (68, fluid_set, "fluid-set", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
size_t num;
@@ -2492,7 +2575,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the length of the string in SRC in DST.
*/
- VM_DEFINE_OP (66, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (69, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (str);
if (SCM_LIKELY (scm_is_string (str)))
@@ -2509,7 +2592,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Fetch the character at position IDX in the string in SRC, and store
* it in DST.
*/
- VM_DEFINE_OP (67, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (70, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (str, idx);
@@ -2531,7 +2614,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Parse a string in SRC to a number, and store in DST.
*/
- VM_DEFINE_OP (68, string_to_number, "string->number", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (71, string_to_number, "string->number", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
@@ -2547,7 +2630,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Parse a string in SRC to a symbol, and store in DST.
*/
- VM_DEFINE_OP (69, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (72, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
@@ -2561,7 +2644,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Make a keyword from the symbol in SRC, and store it in DST.
*/
- VM_DEFINE_OP (70, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (73, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -2580,7 +2663,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Cons CAR and CDR, and store the result in DST.
*/
- VM_DEFINE_OP (71, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (74, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
RETURN (scm_cons (x, y));
@@ -2590,7 +2673,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the car of SRC in DST.
*/
- VM_DEFINE_OP (72, car, "car", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (75, car, "car", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "car");
@@ -2601,7 +2684,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the cdr of SRC in DST.
*/
- VM_DEFINE_OP (73, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (76, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "cdr");
@@ -2612,7 +2695,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the car of DST to SRC.
*/
- VM_DEFINE_OP (74, set_car, "set-car!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (77, set_car, "set-car!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2628,7 +2711,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the cdr of DST to SRC.
*/
- VM_DEFINE_OP (75, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (78, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2651,7 +2734,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Add A to B, and place the result in DST.
*/
- VM_DEFINE_OP (76, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (79, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (+, scm_sum);
}
@@ -2660,7 +2743,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Add 1 to the value in SRC, and place the result in DST.
*/
- VM_DEFINE_OP (77, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (80, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2685,7 +2768,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Subtract B from A, and place the result in DST.
*/
- VM_DEFINE_OP (78, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (81, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (-, scm_difference);
}
@@ -2694,7 +2777,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Subtract 1 from SRC, and place the result in DST.
*/
- VM_DEFINE_OP (79, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (82, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2719,7 +2802,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Multiply A and B, and place the result in DST.
*/
- VM_DEFINE_OP (80, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (83, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2730,7 +2813,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Divide A by B, and place the result in DST.
*/
- VM_DEFINE_OP (81, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (84, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2741,7 +2824,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Divide A by B, and place the quotient in DST.
*/
- VM_DEFINE_OP (82, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (85, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2752,7 +2835,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Divide A by B, and place the remainder in DST.
*/
- VM_DEFINE_OP (83, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (86, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2763,7 +2846,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the modulo of A by B in DST.
*/
- VM_DEFINE_OP (84, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (87, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2774,7 +2857,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Shift A arithmetically by B bits, and place the result in DST.
*/
- VM_DEFINE_OP (85, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (88, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2810,7 +2893,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the bitwise AND of A and B into DST.
*/
- VM_DEFINE_OP (86, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (89, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2824,7 +2907,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the bitwise inclusive OR of A with B in DST.
*/
- VM_DEFINE_OP (87, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (90, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2838,7 +2921,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the bitwise exclusive OR of A with B in DST.
*/
- VM_DEFINE_OP (88, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (91, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2852,7 +2935,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Make a vector and write it to DST. The vector will have space for
* LENGTH slots. They will be filled with the value in slot INIT.
*/
- VM_DEFINE_OP (89, make_vector, "make-vector", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (92, make_vector, "make-vector", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, length, init;
@@ -2869,7 +2952,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* will have space for LENGTH slots, an immediate value. They will be
* filled with the value in slot INIT.
*/
- VM_DEFINE_OP (90, constant_make_vector, "constant-make-vector", OP1
(U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (93, constant_make_vector, "constant-make-vector", OP1
(U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, init;
scm_t_int32 length, n;
@@ -2889,7 +2972,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the length of the vector in SRC in DST.
*/
- VM_DEFINE_OP (91, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (94, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
@@ -2906,7 +2989,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Fetch the item at position IDX in the vector in SRC, and store it
* in DST.
*/
- VM_DEFINE_OP (92, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (95, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
@@ -2927,7 +3010,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Fill DST with the item IDX elements into the vector at SRC. Useful
* for building data types using vectors.
*/
- VM_DEFINE_OP (93, constant_vector_ref, "constant-vector-ref", OP1
(U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (96, constant_vector_ref, "constant-vector-ref", OP1
(U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM v;
@@ -2946,7 +3029,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store SRC into the vector DST at index IDX.
*/
- VM_DEFINE_OP (94, vector_set, "vector-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (97, vector_set, "vector-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx_var, src;
SCM vect, idx, val;
@@ -2975,7 +3058,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Store SRC into the vector DST at index IDX. Here IDX is an
* immediate value.
*/
- VM_DEFINE_OP (95, constant_vector_set, "constant-vector-set!", OP1
(U8_U8_U8_U8))
+ VM_DEFINE_OP (98, constant_vector_set, "constant-vector-set!", OP1
(U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM vect, val;
@@ -3006,7 +3089,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (96, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (99, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable");
@@ -3019,7 +3102,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* will be constructed with space for NFIELDS fields, which should
* correspond to the field count of the VTABLE.
*/
- VM_DEFINE_OP (97, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) |
OP_DST)
+ VM_DEFINE_OP (100, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) |
OP_DST)
{
scm_t_uint8 dst, vtable, nfields;
SCM ret;
@@ -3038,7 +3121,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Fetch the item at slot IDX in the struct in SRC, and store it
* in DST.
*/
- VM_DEFINE_OP (98, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (101, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (obj, pos);
@@ -3072,7 +3155,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store SRC into the struct DST at slot IDX.
*/
- VM_DEFINE_OP (99, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (102, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM obj, pos, val;
@@ -3113,7 +3196,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (100, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (103, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
@@ -3128,7 +3211,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
* index into the stack.
*/
- VM_DEFINE_OP (101, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (104, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
@@ -3142,7 +3225,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
* IDX is an 8-bit immediate value, not an index into the stack.
*/
- VM_DEFINE_OP (102, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (105, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
@@ -3163,7 +3246,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* from the instruction pointer, and store into DST. LEN is a byte
* length. OFFSET is signed.
*/
- VM_DEFINE_OP (103, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8,
N32, U32) | OP_DST)
+ VM_DEFINE_OP (106, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8,
N32, U32) | OP_DST)
{
scm_t_uint8 dst, type, shape;
scm_t_int32 offset;
@@ -3183,7 +3266,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
*/
- VM_DEFINE_OP (104, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (107, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, type, fill, bounds;
SCM_UNPACK_RTL_12_12 (op, dst, type);
@@ -3281,42 +3364,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
} while (0)
- VM_DEFINE_OP (105, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (108, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
- VM_DEFINE_OP (106, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (109, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s8, s8, int8, 1);
- VM_DEFINE_OP (107, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (110, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2);
- VM_DEFINE_OP (108, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (111, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2);
- VM_DEFINE_OP (109, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (112, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4);
#else
BV_INT_REF (u32, uint32, 4);
#endif
- VM_DEFINE_OP (110, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (113, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (s32, s32_native, int32, 4);
#else
BV_INT_REF (s32, int32, 4);
#endif
- VM_DEFINE_OP (111, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (114, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (u64, uint64, 8);
- VM_DEFINE_OP (112, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (115, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (s64, int64, 8);
- VM_DEFINE_OP (113, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (116, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f32, ieee_single, float, 4);
- VM_DEFINE_OP (114, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (117, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f64, ieee_double, double, 8);
/* bv-u8-set! dst:8 idx:8 src:8
@@ -3344,7 +3427,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
bv = LOCAL_REF (dst); \
scm_idx = LOCAL_REF (idx); \
val = LOCAL_REF (src); \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
i = SCM_I_INUM (scm_idx); \
int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
\
@@ -3375,7 +3458,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
bv = LOCAL_REF (dst); \
scm_idx = LOCAL_REF (idx); \
val = LOCAL_REF (src); \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
i = SCM_I_INUM (scm_idx); \
int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
\
@@ -3403,7 +3486,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
bv = LOCAL_REF (dst); \
scm_idx = LOCAL_REF (idx); \
val = LOCAL_REF (src); \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
i = SCM_I_INUM (scm_idx); \
float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
\
@@ -3420,42 +3503,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (1); \
} while (0)
- VM_DEFINE_OP (115, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (118, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1);
- VM_DEFINE_OP (116, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (119, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1);
- VM_DEFINE_OP (117, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (120, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2);
- VM_DEFINE_OP (118, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (121, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN,
SCM_T_INT16_MAX, 2);
- VM_DEFINE_OP (119, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (122, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4);
#else
BV_INT_SET (u32, uint32, 4);
#endif
- VM_DEFINE_OP (120, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (123, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN,
SCM_T_INT32_MAX, 4);
#else
BV_INT_SET (s32, int32, 4);
#endif
- VM_DEFINE_OP (121, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (124, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (u64, uint64, 8);
- VM_DEFINE_OP (122, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (125, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (s64, int64, 8);
- VM_DEFINE_OP (123, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (126, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f32, ieee_single, float, 4);
- VM_DEFINE_OP (124, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (127, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f64, ieee_double, double, 8);
END_DISPATCH_SWITCH;
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 8df56de..e023d56 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1482,7 +1482,9 @@ VM_DEFINE_INSTRUCTION (89, abort, "abort", 1, -1, -1)
tail = sp[0];
stack_args = sp - n;
tag = sp[-(n + 1)];
- vm_abort (vm, tag, n, stack_args, tail, sp - (n + 2), ®isters);
+ /* Partial continuations are now RTL programs, and therefore not
+ resumable. Pass NULL as registers to indicate that fact. */
+ vm_abort (vm, tag, n, stack_args, tail, sp - (n + 2), NULL);
/* vm_abort should not return */
abort ();
}
diff --git a/libguile/vm.c b/libguile/vm.c
index 5a2aef7..f87236e 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -36,6 +36,7 @@
#include "objcodes.h"
#include "programs.h"
#include "vm.h"
+#include "vm-builtins.h"
#include "private-gc.h" /* scm_getenv_int */
@@ -149,7 +150,7 @@ vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM
*argv)
scm_misc_error (NULL, "Too few values returned to continuation",
SCM_EOL);
- if (vp->stack_size < cp->stack_size + n + 1)
+ if (vp->stack_size < cp->stack_size + n + 4)
scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
scm_list_2 (vm, cont));
@@ -166,24 +167,24 @@ vm_return_to_continuation (SCM vm, SCM cont, size_t n,
SCM *argv)
vp->fp = cp->fp;
memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
- if (n == 1 || !cp->mvra)
- {
- vp->ip = cp->ra;
- vp->sp++;
- *vp->sp = argv_copy[0];
- }
- else
- {
- size_t i;
- for (i = 0; i < n; i++)
- {
- vp->sp++;
- *vp->sp = argv_copy[i];
- }
- vp->sp++;
- *vp->sp = scm_from_size_t (n);
- vp->ip = cp->mvra;
- }
+ {
+ size_t i;
+
+ /* Push on an empty frame, as the continuation expects. */
+ for (i = 0; i < 4; i++)
+ {
+ vp->sp++;
+ *vp->sp = SCM_BOOL_F;
+ }
+
+ /* Push the return values. */
+ for (i = 0; i < n; i++)
+ {
+ vp->sp++;
+ *vp->sp = argv_copy[i];
+ }
+ vp->ip = cp->mvra;
+ }
}
SCM
@@ -349,8 +350,11 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont,
size_t n, SCM *argv,
vp->sp++;
*vp->sp = argv_copy[i];
}
+#if 0
+ /* The number-of-values marker, only used by the stack VM. */
vp->sp++;
*vp->sp = scm_from_size_t (n);
+#endif
/* The prompt captured a slice of the dynamic stack. Here we wind
those entries onto the current thread's stack. We also have to
@@ -602,21 +606,115 @@ vm_error_bad_wide_string_length (size_t len)
static SCM boot_continuation;
static SCM rtl_boot_continuation;
-static SCM rtl_apply;
-static SCM rtl_values;
+static SCM vm_builtin_apply;
+static SCM vm_builtin_values;
+static SCM vm_builtin_abort_to_prompt;
+static SCM vm_builtin_call_with_values;
+static SCM vm_builtin_call_with_current_continuation;
static const scm_t_uint32 rtl_boot_continuation_code[] = {
SCM_PACK_RTL_24 (scm_rtl_op_halt, 0)
};
-static const scm_t_uint32 rtl_apply_code[] = {
- SCM_PACK_RTL_24 (scm_rtl_op_tail_apply, 0) /* proc in r1, args from r2,
nargs set */
+static const scm_t_uint32 vm_builtin_apply_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, 3),
+ SCM_PACK_RTL_24 (scm_rtl_op_tail_apply, 0), /* proc in r1, args from r2 */
+};
+
+static const scm_t_uint32 vm_builtin_values_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
};
-static const scm_t_uint32 rtl_values_code[] = {
+static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, 2),
+ SCM_PACK_RTL_24 (scm_rtl_op_abort, 0), /* tag in r1, vals from r2 */
+ /* FIXME: Partial continuation should capture caller regs. */
SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
};
+static const scm_t_uint32 vm_builtin_call_with_values_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 3),
+ SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, 7),
+ SCM_PACK_RTL_12_12 (scm_rtl_op_mov, 6, 1),
+ SCM_PACK_RTL_24 (scm_rtl_op_call, 6), SCM_PACK_RTL_24 (0, 1),
+ SCM_PACK_RTL_12_12 (scm_rtl_op_mov, 0, 2),
+ SCM_PACK_RTL_24 (scm_rtl_op_tail_call_shuffle, 7)
+};
+
+static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = {
+ SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 2),
+ SCM_PACK_RTL_24 (scm_rtl_op_call_cc, 0)
+};
+
+
+static SCM
+scm_vm_builtin_ref (unsigned idx)
+{
+ switch (idx)
+ {
+#define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
+ case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
+ FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
+#undef INDEX_TO_NAME
+ default: abort();
+ }
+}
+
+SCM scm_sym_apply;
+static SCM scm_sym_values;
+static SCM scm_sym_abort_to_prompt;
+static SCM scm_sym_call_with_values;
+static SCM scm_sym_call_with_current_continuation;
+
+SCM
+scm_vm_builtin_name_to_index (SCM name)
+#define FUNC_NAME "builtin-name->index"
+{
+ SCM_VALIDATE_SYMBOL (1, name);
+
+#define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
+ if (scm_is_eq (name, scm_sym_##builtin)) \
+ return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
+ FOR_EACH_VM_BUILTIN(NAME_TO_INDEX)
+#undef NAME_TO_INDEX
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM
+scm_vm_builtin_index_to_name (SCM index)
+#define FUNC_NAME "builtin-index->name"
+{
+ unsigned idx;
+
+ SCM_VALIDATE_UINT_COPY (1, index, idx);
+
+ switch (idx)
+ {
+#define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
+ case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
+ FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
+#undef INDEX_TO_NAME
+ default: return SCM_BOOL_F;
+ }
+}
+#undef FUNC_NAME
+
+static void
+scm_init_vm_builtins (void)
+{
+ scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
+ scm_vm_builtin_name_to_index);
+ scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
+ scm_vm_builtin_index_to_name);
+}
+
+SCM
+scm_i_call_with_current_continuation (SCM proc)
+{
+ return scm_call_1 (vm_builtin_call_with_current_continuation, proc);
+}
/*
@@ -659,7 +757,7 @@ resolve_variable (SCM what, SCM module)
}
#define VM_MIN_STACK_SIZE (1024)
-#define VM_DEFAULT_STACK_SIZE (64 * 1024)
+#define VM_DEFAULT_STACK_SIZE (256 * 1024)
static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
static void
@@ -781,10 +879,10 @@ scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
{
struct scm_vm *vp = SCM_VM_DATA (vm);
SCM_CHECK_STACK;
- if (SCM_RTL_PROGRAM_P (program))
- return rtl_vm_engines[vp->engine](vm, program, argv, nargs);
- else
+ if (SCM_PROGRAM_P (program))
return vm_engines[vp->engine](vm, program, argv, nargs);
+ else
+ return rtl_vm_engines[vp->engine](vm, program, argv, nargs);
}
/* Scheme interface */
@@ -1125,11 +1223,37 @@ make_boot_program (void)
}
void
+scm_init_vm_builtin_properties (void)
+{
+ /* FIXME: Seems hacky to do this here, but oh well :/ */
+ scm_sym_apply = scm_from_utf8_symbol ("apply");
+ scm_sym_values = scm_from_utf8_symbol ("values");
+ scm_sym_abort_to_prompt = scm_from_utf8_symbol ("abort-to-prompt");
+ scm_sym_call_with_values = scm_from_utf8_symbol ("call-with-values");
+ scm_sym_call_with_current_continuation =
+ scm_from_utf8_symbol ("call-with-current-continuation");
+
+#define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
+ scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
+ scm_sym_##builtin); \
+ scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
+ SCM_I_MAKINUM (req), \
+ SCM_I_MAKINUM (opt), \
+ scm_from_bool (rest));
+ FOR_EACH_VM_BUILTIN (INIT_BUILTIN);
+#undef INIT_BUILTIN
+}
+
+void
scm_bootstrap_vm (void)
{
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_vm",
(scm_t_extension_init_func)scm_init_vm, NULL);
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_vm_builtins",
+ (scm_t_extension_init_func)scm_init_vm_builtins,
+ NULL);
initialize_default_stack_size ();
@@ -1145,8 +1269,11 @@ scm_bootstrap_vm (void)
SCM_SET_CELL_WORD_0 (rtl_boot_continuation,
(SCM_CELL_WORD_0 (rtl_boot_continuation)
| SCM_F_PROGRAM_IS_BOOT));
- rtl_apply = scm_i_make_rtl_program (rtl_apply_code);
- rtl_values = scm_i_make_rtl_program (rtl_values_code);
+
+#define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
+ vm_builtin_##builtin = scm_i_make_rtl_program (vm_builtin_##builtin##_code);
+ FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
+#undef DEFINE_BUILTIN
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
vm_stack_gc_kind =
diff --git a/libguile/vm.h b/libguile/vm.h
index c45d17f..80423ec 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -107,6 +107,7 @@ SCM_INTERNAL SCM scm_c_vm_run (SCM vm, SCM program, SCM
*argv, int nargs);
SCM_INTERNAL void scm_i_vm_print (SCM x, SCM port,
scm_print_state *pstate);
+SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);
SCM_INTERNAL SCM scm_i_capture_current_stack (void);
SCM_INTERNAL SCM scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp,
scm_t_uint8 *ra, scm_t_uint8 *mvra,
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 87c38af..83e5480 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -274,10 +274,20 @@ x
a-cont
@result{} special-binding
@end lisp"
- (if (thunk? out)
- (in)
- (scm-error 'wrong-type-arg "dynamic-wind" "Not a thunk: ~S"
- (list out) #f))
+ ;; FIXME: Here we don't check that the out procedure is a thunk before
+ ;; calling the in-guard, as dynamic-wind is called as part of loading
+ ;; modules, but thunk? requires loading (system vm debug). This is in
+ ;; contrast to the open-coded version of dynamic-wind, which does
+ ;; currently insert an eager thunk? check (but often optimizes it
+ ;; out). Not sure what the right thing to do is here -- make thunk?
+ ;; callable before modules are loaded, live with this inconsistency,
+ ;; or remove the thunk? check from the compiler? Questions,
+ ;; questions.
+ #;
+ (unless (thunk? out)
+ (scm-error 'wrong-type-arg "dynamic-wind" "Not a thunk: ~S"
+ (list out) #f))
+ (in)
((@@ primitive wind) in out)
(call-with-values thunk
(lambda vals
diff --git a/module/ice-9/eval-string.scm b/module/ice-9/eval-string.scm
index 649551d..ae6792e 100644
--- a/module/ice-9/eval-string.scm
+++ b/module/ice-9/eval-string.scm
@@ -22,6 +22,7 @@
#:use-module (system base compile)
#:use-module (system base language)
#:use-module (system vm program)
+ #:use-module (system vm objcode)
#:replace (eval-string))
(define (ensure-language x)
@@ -84,5 +85,6 @@
(set-port-column! port line))
(if (or compile? (not (language-evaluator lang)))
- ((make-program (read-and-compile port #:from lang #:to
'objcode)))
+ ((load-thunk-from-memory
+ (read-and-compile port #:from lang #:to 'rtl)))
(read-and-eval port #:lang lang))))))))
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index ed51039..f95bbe9 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -43,20 +43,6 @@
(eval-when (compile)
- (define-syntax capture-env
- (syntax-rules ()
- ((_ (exp ...))
- (let ((env (exp ...)))
- (capture-env env)))
- ((_ env)
- (if (null? env)
- (current-module)
- (if (not env)
- ;; the and current-module checks that modules are booted,
- ;; and thus the-root-module is defined
- (and (current-module) the-root-module)
- env)))))
-
(define-syntax env-toplevel
(syntax-rules ()
((_ env)
@@ -93,6 +79,48 @@
(vector-set! e (1+ width) val)
(lp (vector-ref e 0) (1- d)))))))
+ ;; For evaluating the initializers in a "let" expression. We have to
+ ;; evaluate the initializers before creating the environment rib, to
+ ;; prevent continuation-related shenanigans; see
+ ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time for a
+ ;; deeper discussion.
+ ;;
+ ;; This macro will inline evaluation of the first N initializers.
+ ;; That number N is indicated by the number of template arguments
+ ;; passed to the macro. It's a bit nasty but it's flexible and
+ ;; optimizes well.
+ (define-syntax let-env-evaluator
+ (syntax-rules ()
+ ((eval-and-make-env eval env (template ...))
+ (let ()
+ (define-syntax eval-and-make-env
+ (syntax-rules ()
+ ((eval-and-make-env inits width (template ...) k)
+ (let lp ((n (length '(template ...))) (vals '()))
+ (if (eqv? n width)
+ (let ((env (make-env n #f env)))
+ (let lp ((n (1- n)) (vals vals))
+ (if (null? vals)
+ (k env)
+ (begin
+ (env-set! env 0 n (car vals))
+ (lp (1- n) (cdr vals))))))
+ (lp (1+ n)
+ (cons (eval (vector-ref inits n) env) vals)))))
+ ((eval-and-make-env inits width (var (... ...)) k)
+ (let ((n (length '(var (... ...)))))
+ (if (eqv? n width)
+ (k (make-env n #f env))
+ (let* ((x (eval (vector-ref inits n) env))
+ (k (lambda (env)
+ (env-set! env 0 n x)
+ (k env))))
+ (eval-and-make-env inits width (x var (... ...)) k)))))))
+ (lambda (inits)
+ (let ((width (vector-length inits))
+ (k (lambda (env) env)))
+ (eval-and-make-env inits width () k)))))))
+
;; Fast case for procedures with fixed arities.
(define-syntax make-fixed-closure
(lambda (x)
@@ -356,7 +384,7 @@
(cond
((or (< nargs nreq)
(and (not kw) (not rest?) (> nargs (+ nreq nopt)))
- (and kw (not rest?) (> (npositional %args) (+ nreq nopt))))
+ (and alt kw (not rest?) (> (npositional %args) (+ nreq
nopt))))
(if alt
(apply alt-proc %args)
((scm-error 'wrong-number-of-args
@@ -459,8 +487,7 @@
(variable-ref
(if (variable? var-or-sym)
var-or-sym
- (memoize-variable-access! exp
- (capture-env (env-toplevel env))))))
+ (memoize-variable-access! exp (env-toplevel env)))))
(('if (test consequent . alternate))
(if (eval test env)
@@ -471,22 +498,15 @@
x)
(('let (inits . body))
- (let* ((width (vector-length inits))
- (new-env (make-env width #f (capture-env env))))
- (let lp ((i 0))
- (when (< i width)
- (env-set! new-env 0 i (eval (vector-ref inits i) env))
- (lp (1+ i))))
- (eval body new-env)))
+ (eval body ((let-env-evaluator eval env (_ _ _ _)) inits)))
(('lambda (body meta nreq . tail))
(let ((proc
(if (null? tail)
- (make-fixed-closure eval nreq body (capture-env env))
+ (make-fixed-closure eval nreq body env)
(if (null? (cdr tail))
- (make-rest-closure eval nreq body (capture-env env))
- (apply make-general-closure (capture-env env)
- body nreq tail)))))
+ (make-rest-closure eval nreq body env)
+ (apply make-general-closure env body nreq tail)))))
(let lp ((meta meta))
(unless (null? meta)
(set-procedure-property! proc (caar meta) (cdar meta))
@@ -518,13 +538,15 @@
(begin
(define! name (eval x env))
(if #f #f)))
-
+
+ (('capture-module x)
+ (eval x (current-module)))
+
(('toplevel-set! (var-or-sym . x))
(variable-set!
(if (variable? var-or-sym)
var-or-sym
- (memoize-variable-access! exp
- (capture-env (env-toplevel env))))
+ (memoize-variable-access! exp (env-toplevel env)))
(eval x env)))
(('call-with-prompt (tag thunk . handler))
@@ -551,4 +573,4 @@
(if (macroexpanded? exp)
exp
((module-transformer (current-module)) exp)))
- '()))))
+ #f))))
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index 4609883..e32ba85 100644
--- a/module/ice-9/match.upstream.scm
+++ b/module/ice-9/match.upstream.scm
@@ -280,14 +280,19 @@
;; clauses. `g+s' is a list of two elements, the get! and set!
;; expressions respectively.
+(define (match-error v)
+ (error 'match "no matching pattern" v))
+
(define-syntax match-next
(syntax-rules (=>)
;; no more clauses, the match failed
((match-next v g+s)
- ;; Here we wrap error within a double set of parentheses, so that
- ;; the call to 'error' won't be in tail position. This allows the
- ;; backtrace to show the source location of the failing match form.
- ((error 'match "no matching pattern" v)))
+ ;; Here we call match-error in non-tail context, so that the
+ ;; backtrace can show the source location of the failing match
+ ;; form.
+ (begin
+ (match-error v)
+ #f))
;; named failure continuation
((match-next v g+s (pat (=> failure) . body) . rest)
(let ((failure (lambda () (match-next v g+s . rest))))
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index ce1bcac..ff11147 100644
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -1,5 +1,5 @@
;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010, 2011,
-;;;; 2012 Free Software Foundation, Inc.
+;;;; 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -522,7 +522,8 @@ The alist keys that are currently defined are `required',
`optional',
(rest . ,rest)))))
((procedure-source proc)
=> cadr)
- (((@ (system vm program) program?) proc)
+ ((or ((@ (system vm program) program?) proc)
+ ((@ (system vm program) rtl-program?) proc))
((@ (system vm program) program-arguments-alist) proc))
(else #f)))
diff --git a/module/language/cps.scm b/module/language/cps.scm
index ac5642a..4dc88eb 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -25,15 +25,15 @@
;;; and terms that call continuations.
;;;
;;; $letk binds a set of mutually recursive continuations, each one an
-;;; instance of $cont. A $cont declares the name and source of a
-;;; continuation, and then contains as a subterm the particular
-;;; continuation instance: $kif for test continuations, $kargs for
-;;; continuations that bind values, etc.
+;;; instance of $cont. A $cont declares the name of a continuation, and
+;;; then contains as a subterm the particular continuation instance:
+;;; $kif for test continuations, $kargs for continuations that bind
+;;; values, etc.
;;;
;;; $continue nodes call continuations. The expression contained in the
;;; $continue node determines the value or values that are passed to the
;;; target continuation: $const to pass a constant value, $values to
-;;; pass multiple named values, etc.
+;;; pass multiple named values, etc. $continue nodes also record the source
at which
;;;
;;; Additionally there is $letrec, a term that binds mutually recursive
;;; functions. The contification pass will turn $letrec into $letk if
@@ -71,8 +71,8 @@
;;; That's to say that a $fun can be matched like this:
;;;
;;; (match f
-;;; (($ $fun meta free
-;;; ($ $cont kentry src
+;;; (($ $fun src meta free
+;;; ($ $cont kentry
;;; ($ $kentry self ($ $cont ktail _ ($ $ktail))
;;; (($ $kclause arity
;;; ($ $cont kbody _ ($ $kargs names syms body)))
@@ -85,7 +85,8 @@
;;; - $prompt continues to the body of the prompt, having pushed on a
;;; prompt whose handler will continue at its "handler"
;;; continuation. The continuation of the prompt is responsible for
-;;; popping the prompt.
+;;; popping the prompt. A $prompt also records the continuation
+;;; that pops the prompt, to make various static analyses easier.
;;;
;;; In summary:
;;;
@@ -164,11 +165,11 @@
;; Terms.
(define-cps-type $letk conts body)
-(define-cps-type $continue k exp)
+(define-cps-type $continue k src exp)
(define-cps-type $letrec names syms funs body)
;; Continuations
-(define-cps-type $cont k src cont)
+(define-cps-type $cont k cont)
(define-cps-type $kif kt kf)
(define-cps-type $ktrunc arity k)
(define-cps-type $kargs names syms body)
@@ -181,11 +182,11 @@
(define-cps-type $void)
(define-cps-type $const val)
(define-cps-type $prim name)
-(define-cps-type $fun meta free body)
+(define-cps-type $fun src meta free body)
(define-cps-type $call proc args)
(define-cps-type $primcall name args)
(define-cps-type $values args)
-(define-cps-type $prompt escape? tag handler)
+(define-cps-type $prompt escape? tag handler pop)
(define-syntax let-gensyms
(syntax-rules ()
@@ -223,7 +224,7 @@
(define-syntax build-cps-cont
(syntax-rules (unquote)
((_ (unquote exp)) exp)
- ((_ (k src cont)) (make-$cont k src (build-cont-body cont)))))
+ ((_ (k cont)) (make-$cont k (build-cont-body cont)))))
(define-syntax build-cps-exp
(syntax-rules (unquote
@@ -233,14 +234,16 @@
((_ ($void)) (make-$void))
((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name))
- ((_ ($fun meta free body)) (make-$fun meta free (build-cps-cont body)))
+ ((_ ($fun src meta free body))
+ (make-$fun src meta free (build-cps-cont body)))
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
((_ ($call proc args)) (make-$call proc args))
((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
((_ ($primcall name args)) (make-$primcall name args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args))
- ((_ ($prompt escape? tag handler)) (make-$prompt escape? tag handler))))
+ ((_ ($prompt escape? tag handler pop))
+ (make-$prompt escape? tag handler pop))))
(define-syntax build-cps-term
(syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
@@ -260,12 +263,14 @@
((_ ($letconst ((name sym val) tail ...) body))
(let-gensyms (kconst)
(build-cps-term
- ($letk ((kconst #f ($kargs (name) (sym) ($letconst (tail ...) body))))
- ($continue kconst ($const val))))))
+ ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
+ ($continue kconst (let ((props (source-properties val)))
+ (and (pair? props) props))
+ ($const val))))))
((_ ($letrec names gensyms funs body))
(make-$letrec names gensyms funs (build-cps-term body)))
- ((_ ($continue k exp))
- (make-$continue k (build-cps-exp exp)))))
+ ((_ ($continue k src exp))
+ (make-$continue k src (build-cps-exp exp)))))
(define-syntax-rule (rewrite-cps-term x (pat body) ...)
(match x
@@ -285,20 +290,20 @@
;; Continuations.
(('letconst k (name sym c) body)
(build-cps-term
- ($letk ((k (src exp) ($kargs (name) (sym)
- ,(parse-cps body))))
- ($continue k ($const c)))))
+ ($letk ((k ($kargs (name) (sym)
+ ,(parse-cps body))))
+ ($continue k (src exp) ($const c)))))
(('let k (name sym val) body)
(build-cps-term
- ($letk ((k (src exp) ($kargs (name) (sym)
- ,(parse-cps body))))
+ ($letk ((k ($kargs (name) (sym)
+ ,(parse-cps body))))
,(parse-cps val))))
(('letk (cont ...) body)
(build-cps-term
($letk ,(map parse-cps cont) ,(parse-cps body))))
(('k sym body)
(build-cps-cont
- (sym (src exp) ,(parse-cps body))))
+ (sym ,(parse-cps body))))
(('kif kt kf)
(build-cont-body ($kif kt kf)))
(('ktrunc req rest k)
@@ -320,7 +325,7 @@
;; Calls.
(('continue k exp)
- (build-cps-term ($continue k ,(parse-cps exp))))
+ (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
(('var sym)
(build-cps-exp ($var sym)))
(('void)
@@ -330,7 +335,7 @@
(('prim name)
(build-cps-exp ($prim name)))
(('fun meta free body)
- (build-cps-exp ($fun meta free ,(parse-cps body))))
+ (build-cps-exp ($fun (src exp) meta free ,(parse-cps body))))
(('letrec ((name sym fun) ...) body)
(build-cps-term
($letrec name sym (map parse-cps fun) ,(parse-cps body))))
@@ -340,24 +345,24 @@
(build-cps-exp ($primcall name arg)))
(('values arg ...)
(build-cps-exp ($values arg)))
- (('prompt escape? tag handler)
- (build-cps-exp ($prompt escape? tag handler)))
+ (('prompt escape? tag handler pop)
+ (build-cps-exp ($prompt escape? tag handler pop)))
(_
(error "unexpected cps" exp))))
(define (unparse-cps exp)
(match exp
;; Continuations.
- (($ $letk (($ $cont k src ($ $kargs (name) (sym) body)))
- ($ $continue k ($ $const c)))
+ (($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
+ ($ $continue k src ($ $const c)))
`(letconst ,k (,name ,sym ,c)
,(unparse-cps body)))
- (($ $letk (($ $cont k src ($ $kargs (name) (sym) body))) val)
+ (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val)
`(let ,k (,name ,sym ,(unparse-cps val))
,(unparse-cps body)))
(($ $letk conts body)
`(letk ,(map unparse-cps conts) ,(unparse-cps body)))
- (($ $cont sym src body)
+ (($ $cont sym body)
`(k ,sym ,(unparse-cps body)))
(($ $kif kt kf)
`(kif ,kt ,kf))
@@ -375,7 +380,7 @@
`(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)))
;; Calls.
- (($ $continue k exp)
+ (($ $continue k src exp)
`(continue ,k ,(unparse-cps exp)))
(($ $var sym)
`(var ,sym))
@@ -385,7 +390,7 @@
`(const ,val))
(($ $prim name)
`(prim ,name))
- (($ $fun meta free body)
+ (($ $fun src meta free body)
`(fun ,meta ,free ,(unparse-cps body)))
(($ $letrec names syms funs body)
`(letrec ,(map (lambda (name sym fun)
@@ -398,16 +403,16 @@
`(primcall ,name ,@args))
(($ $values args)
`(values ,@args))
- (($ $prompt escape? tag handler)
- `(prompt ,escape? ,tag ,handler))
+ (($ $prompt escape? tag handler pop)
+ `(prompt ,escape? ,tag ,handler ,pop))
(_
(error "unexpected cps" exp))))
(define (fold-conts proc seed fun)
(define (cont-folder cont seed)
(match cont
- (($ $cont k src cont)
- (let ((seed (proc k src cont seed)))
+ (($ $cont k cont)
+ (let ((seed (proc k cont seed)))
(match cont
(($ $kargs names syms body)
(term-folder body seed))
@@ -422,7 +427,7 @@
(define (fun-folder fun seed)
(match fun
- (($ $fun meta free body)
+ (($ $fun src meta free body)
(cont-folder body seed))))
(define (term-folder term seed)
@@ -430,7 +435,7 @@
(($ $letk conts body)
(fold cont-folder (term-folder body seed) conts))
- (($ $continue k exp)
+ (($ $continue k src exp)
(match exp
(($ $fun) (fun-folder exp seed))
(_ seed)))
@@ -443,8 +448,8 @@
(define (fold-local-conts proc seed cont)
(define (cont-folder cont seed)
(match cont
- (($ $cont k src cont)
- (let ((seed (proc k src cont seed)))
+ (($ $cont k cont)
+ (let ((seed (proc k cont seed)))
(match cont
(($ $kargs names syms body)
(term-folder body seed))
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 8777502..430d697 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -35,136 +35,170 @@
(define (fix-clause-arities clause)
(let ((conts (build-local-cont-table clause))
(ktail (match clause
- (($ $cont _ _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
+ (($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $letrec names syms funs body)
($letrec names syms (map fix-arities funs) ,(visit-term body)))
- (($ $continue k exp)
- ,(visit-exp k exp))))
+ (($ $continue k src exp)
+ ,(visit-exp k src exp))))
- (define (adapt-exp nvals k exp)
+ (define (adapt-exp nvals k src exp)
(match nvals
(0
(rewrite-cps-term (lookup-cont k conts)
(($ $ktail)
,(let-gensyms (kvoid kunspec unspec)
(build-cps-term
- ($letk* ((kunspec #f ($kargs (unspec) (unspec)
- ($continue k
- ($primcall 'return (unspec)))))
- (kvoid #f ($kargs () ()
- ($continue kunspec ($void)))))
- ($continue kvoid ,exp)))))
+ ($letk* ((kunspec ($kargs (unspec) (unspec)
+ ($continue k src
+ ($primcall 'return (unspec)))))
+ (kvoid ($kargs () ()
+ ($continue kunspec src ($void)))))
+ ($continue kvoid src ,exp)))))
(($ $ktrunc arity kargs)
,(rewrite-cps-term arity
(($ $arity () () #f () #f)
- ($continue kargs ,exp))
+ ($continue kargs src ,exp))
(_
,(let-gensyms (kvoid kvalues void)
(build-cps-term
- ($letk* ((kvalues #f ($kargs ('void) (void)
- ($continue k
- ($primcall 'values (void)))))
- (kvoid #f ($kargs () ()
- ($continue kvalues
- ($void)))))
- ($continue kvoid ,exp)))))))
+ ($letk* ((kvalues ($kargs ('void) (void)
+ ($continue k src
+ ($primcall 'values (void)))))
+ (kvoid ($kargs () ()
+ ($continue kvalues src
+ ($void)))))
+ ($continue kvoid src ,exp)))))))
(($ $kargs () () _)
- ($continue k ,exp))
+ ($continue k src ,exp))
(_
,(let-gensyms (k*)
(build-cps-term
- ($letk ((k* #f ($kargs () () ($continue k ($void)))))
- ($continue k* ,exp)))))))
+ ($letk ((k* ($kargs () () ($continue k src ($void)))))
+ ($continue k* src ,exp)))))))
(1
(rewrite-cps-term (lookup-cont k conts)
(($ $ktail)
,(rewrite-cps-term exp
(($var sym)
- ($continue ktail ($primcall 'return (sym))))
+ ($continue ktail src ($primcall 'return (sym))))
(_
,(let-gensyms (k* v)
(build-cps-term
- ($letk ((k* #f ($kargs (v) (v)
- ($continue k
- ($primcall 'return (v))))))
- ($continue k* ,exp)))))))
+ ($letk ((k* ($kargs (v) (v)
+ ($continue k src
+ ($primcall 'return (v))))))
+ ($continue k* src ,exp)))))))
(($ $ktrunc arity kargs)
,(rewrite-cps-term arity
(($ $arity (_) () #f () #f)
- ($continue kargs ,exp))
+ ($continue kargs src ,exp))
(_
,(let-gensyms (kvalues value)
(build-cps-term
- ($letk ((kvalues #f ($kargs ('value) (value)
- ($continue k
- ($primcall 'values (value))))))
- ($continue kvalues ,exp)))))))
+ ($letk ((kvalues ($kargs ('value) (value)
+ ($continue k src
+ ($primcall 'values (value))))))
+ ($continue kvalues src ,exp)))))))
(($ $kargs () () _)
,(let-gensyms (k* drop)
(build-cps-term
- ($letk ((k* #f ($kargs ('drop) (drop)
- ($continue k ($values ())))))
- ($continue k* ,exp)))))
+ ($letk ((k* ($kargs ('drop) (drop)
+ ($continue k src ($values ())))))
+ ($continue k* src ,exp)))))
(_
- ($continue k ,exp))))))
+ ($continue k src ,exp))))))
- (define (visit-exp k exp)
+ (define (visit-exp k src exp)
(rewrite-cps-term exp
((or ($ $void)
($ $const)
($ $prim)
($ $var))
- ,(adapt-exp 1 k exp))
+ ,(adapt-exp 1 k src exp))
(($ $fun)
- ,(adapt-exp 1 k (fix-arities exp)))
+ ,(adapt-exp 1 k src (fix-arities exp)))
(($ $call)
;; 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.
- ($continue k ,exp))
+ ($continue k src ,exp))
(($ $primcall 'return (arg))
;; Primcalls to return are in tail position.
- ($continue ktail ,exp))
+ ($continue ktail src ,exp))
(($ $primcall (? (lambda (name)
(and (not (prim-rtl-instruction name))
(not (branching-primitive? name))))))
- ($continue k ,exp))
+ ($continue k src ,exp))
+ (($ $primcall 'struct-set! (obj pos val))
+ ;; Unhappily, and undocumentedly, struct-set! returns the value
+ ;; that was set. There is code that relies on this. Hackety
+ ;; hack...
+ ,(rewrite-cps-term (lookup-cont k conts)
+ (($ $ktail)
+ ,(let-gensyms (kvoid)
+ (build-cps-term
+ ($letk* ((kvoid ($kargs () ()
+ ($continue ktail src
+ ($primcall 'return (val))))))
+ ($continue kvoid src ,exp)))))
+ (($ $ktrunc arity kargs)
+ ,(rewrite-cps-term arity
+ (($ $arity () () #f () #f)
+ ($continue kargs src ,exp))
+ (_
+ ,(let-gensyms (kvoid)
+ (build-cps-term
+ ($letk* ((kvoid ($kargs () ()
+ ($continue k src
+ ($primcall 'values (val))))))
+ ($continue kvoid src ,exp)))))))
+ (($ $kargs () () _)
+ ($continue k src ,exp))
+ (_
+ ,(let-gensyms (k*)
+ (build-cps-term
+ ($letk ((k* ($kargs () () ($continue k src ($var val)))))
+ ($continue k* src ,exp)))))))
(($ $primcall name args)
,(match (prim-arity name)
((out . in)
(if (= in (length args))
- (adapt-exp out k exp)
+ (adapt-exp out k src
+ (let ((inst (prim-rtl-instruction name)))
+ (if (and inst (not (eq? inst name)))
+ (build-cps-exp ($primcall inst args))
+ exp)))
(let-gensyms (k* p*)
(build-cps-term
- ($letk ((k* #f ($kargs ('prim) (p*)
- ($continue k ($call p* args)))))
- ($continue k* ($prim name)))))))))
+ ($letk ((k* ($kargs ('prim) (p*)
+ ($continue k src ($call p* args)))))
+ ($continue k* src ($prim name)))))))))
(($ $values)
;; Values nodes are inserted by CPS optimization passes, so
;; we assume they are correct.
- ($continue k ,exp))
+ ($continue k src ,exp))
(($ $prompt)
- ($continue k ,exp))))
+ ($continue k src ,exp))))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont)
,cont)))
(rewrite-cps-cont clause
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses)))))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
(define (fix-arities fun)
(rewrite-cps-exp fun
- (($ $fun meta free body)
- ($fun meta free ,(fix-clause-arities body)))))
+ (($ $fun src meta free body)
+ ($fun src meta free ,(fix-clause-arities body)))))
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 9a9738b..3cea53a 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -63,8 +63,8 @@ values in the term."
(let-gensyms (k* sym*)
(receive (exp free) (k sym*)
(values (build-cps-term
- ($letk ((k* #f ($kargs (sym*) (sym*) ,exp)))
- ($continue k* ($primcall 'free-ref (self sym)))))
+ ($letk ((k* ($kargs (sym*) (sym*) ,exp)))
+ ($continue k* #f ($primcall 'free-ref (self sym)))))
(cons sym free))))))
(define (convert-free-vars syms self bound k)
@@ -88,13 +88,13 @@ performed, and @var{outer-bound} is the list of bound
variables there."
(fold (lambda (free idx body)
(let-gensyms (k idxsym)
(build-cps-term
- ($letk ((k src ($kargs () () ,body)))
+ ($letk ((k ($kargs () () ,body)))
,(convert-free-var
free outer-self outer-bound
(lambda (free)
(values (build-cps-term
($letconst (('idx idxsym idx))
- ($continue k
+ ($continue k src
($primcall 'free-set! (v idxsym free)))))
'())))))))
body
@@ -123,19 +123,19 @@ convert functions to flat closures."
(values (build-cps-term ($letk ,conts ,body))
(union free free*)))))
- (($ $cont sym src ($ $kargs names syms body))
+ (($ $cont sym ($ $kargs names syms body))
(receive (body free) (cc body self (append syms bound))
- (values (build-cps-cont (sym src ($kargs names syms ,body)))
+ (values (build-cps-cont (sym ($kargs names syms ,body)))
free)))
- (($ $cont sym src ($ $kentry self tail clauses))
+ (($ $cont sym ($ $kentry self tail clauses))
(receive (clauses free) (cc* clauses self (list self))
- (values (build-cps-cont (sym src ($kentry self ,tail ,clauses)))
+ (values (build-cps-cont (sym ($kentry self ,tail ,clauses)))
free)))
- (($ $cont sym src ($ $kclause arity body))
+ (($ $cont sym ($ $kclause arity body))
(receive (body free) (cc body self bound)
- (values (build-cps-cont (sym src ($kclause ,arity ,body)))
+ (values (build-cps-cont (sym ($kclause ,arity ,body)))
free)))
(($ $cont)
@@ -153,76 +153,76 @@ convert functions to flat closures."
(free free))
(match in
(() (values (bindings body) free))
- (((name sym ($ $fun meta () fun-body)) . in)
+ (((name sym ($ $fun src meta () fun-body)) . in)
(receive (fun-body fun-free) (cc fun-body #f '())
(lp in
(lambda (body)
(let-gensyms (k)
(build-cps-term
- ($letk ((k #f ($kargs (name) (sym) ,(bindings
body))))
- ($continue k
- ($fun meta fun-free ,fun-body))))))
- (init-closure #f sym fun-free self bound body)
+ ($letk ((k ($kargs (name) (sym) ,(bindings body))))
+ ($continue k src
+ ($fun src meta fun-free ,fun-body))))))
+ (init-closure src sym fun-free self bound body)
(union free (difference fun-free bound))))))))))
- (($ $continue k ($ $var sym))
+ (($ $continue k src ($ $var sym))
(convert-free-var sym self bound
(lambda (sym)
- (values (build-cps-term ($continue k ($var sym)))
+ (values (build-cps-term ($continue k src ($var sym)))
'()))))
- (($ $continue k
+ (($ $continue k src
(or ($ $void)
($ $const)
($ $prim)))
(values exp '()))
- (($ $continue k ($ $fun meta () body))
+ (($ $continue k src ($ $fun src* meta () body))
(receive (body free) (cc body #f '())
(match free
(()
(values (build-cps-term
- ($continue k ($fun meta free ,body)))
+ ($continue k src ($fun src* meta free ,body)))
free))
(_
(values
(let-gensyms (kinit v)
(build-cps-term
- ($letk ((kinit #f ($kargs (v) (v)
- ,(init-closure #f v free self bound
- (build-cps-term
- ($continue k ($var v)))))))
- ($continue kinit ($fun meta free ,body)))))
+ ($letk ((kinit ($kargs (v) (v)
+ ,(init-closure src v free self bound
+ (build-cps-term
+ ($continue k src ($var
v)))))))
+ ($continue kinit src ($fun src* meta free ,body)))))
(difference free bound))))))
- (($ $continue k ($ $call proc args))
+ (($ $continue k src ($ $call proc args))
(convert-free-vars (cons proc args) self bound
(match-lambda
((proc . args)
(values (build-cps-term
- ($continue k ($call proc args)))
+ ($continue k src ($call proc args)))
'())))))
- (($ $continue k ($ $primcall name args))
+ (($ $continue k src ($ $primcall name args))
(convert-free-vars args self bound
(lambda (args)
(values (build-cps-term
- ($continue k ($primcall name args)))
+ ($continue k src ($primcall name args)))
'()))))
- (($ $continue k ($ $values args))
+ (($ $continue k src ($ $values args))
(convert-free-vars args self bound
(lambda (args)
(values (build-cps-term
- ($continue k ($values args)))
+ ($continue k src ($values args)))
'()))))
- (($ $continue k ($ $prompt escape? tag handler))
+ (($ $continue k src ($ $prompt escape? tag handler pop))
(convert-free-var
tag self bound
(lambda (tag)
(values (build-cps-term
- ($continue k ($prompt escape? tag handler)))
+ ($continue k src ($prompt escape? tag handler pop)))
'()))))
(_ (error "what" exp))))
@@ -237,37 +237,38 @@ convert functions to flat closures."
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
- (($ $continue k ($ $primcall 'free-ref (closure sym)))
+ (($ $continue k src ($ $primcall 'free-ref (closure sym)))
,(let-gensyms (idx)
(build-cps-term
($letconst (('idx idx (free-index sym)))
- ($continue k ($primcall 'free-ref (closure idx)))))))
- (($ $continue k ($ $fun meta free body))
- ($continue k ($fun meta free ,(convert-to-indices body free))))
+ ($continue k src ($primcall 'free-ref (closure idx)))))))
+ (($ $continue k src ($ $fun src* meta free body))
+ ($continue k src
+ ($fun src* meta free ,(convert-to-indices body free))))
(($ $continue)
,term)))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
;; Other kinds of continuations don't bind values and don't have
;; bodies.
(($ $cont)
,cont)))
(rewrite-cps-cont body
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses))))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))))
(define (convert-closures exp)
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
and allocate and initialize flat closures."
(match exp
- (($ $fun meta () body)
+ (($ $fun src meta () body)
(receive (body free) (cc body #f '())
(unless (null? free)
(error "Expected no free vars in toplevel thunk" exp body free))
(build-cps-exp
- ($fun meta free ,(convert-to-indices body free)))))))
+ ($fun src meta free ,(convert-to-indices body free)))))))
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index 341b715..a3bef46 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -39,8 +39,7 @@
#:use-module (system vm assembler)
#:export (compile-rtl))
-;; TODO: Source info, local var names. Needs work in the linker and the
-;; debugger.
+;; TODO: Local var names.
(define (kw-arg-ref args kw default)
(match (memq kw args)
@@ -76,55 +75,46 @@
exp))
-(define (visit-funs proc exp)
- (match exp
- (($ $continue _ exp)
- (visit-funs proc exp))
+(define (collect-conts f cfa)
+ (let ((contv (make-vector (cfa-k-count cfa) #f)))
+ (fold-local-conts
+ (lambda (k cont tail)
+ (let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
+ (when idx
+ (vector-set! contv idx cont))))
+ '()
+ (match f
+ (($ $fun src meta free entry)
+ entry)))
+ contv))
- (($ $fun meta free body)
- (proc exp)
- (visit-funs proc body))
-
- (($ $letk conts body)
- (visit-funs proc body)
- (for-each (lambda (cont) (visit-funs proc cont)) conts))
-
- (($ $cont sym src ($ $kargs names syms body))
- (visit-funs proc body))
-
- (($ $cont sym src ($ $kclause arity body))
- (visit-funs proc body))
-
- (($ $cont sym src ($ $kentry self tail clauses))
- (for-each (lambda (clause) (visit-funs proc clause)) clauses))
-
- (_ (values))))
+(define (compile-fun f asm)
+ (let* ((dfg (compute-dfg f #:global? #f))
+ (cfa (analyze-control-flow f dfg))
+ (allocation (allocate-slots f dfg))
+ (contv (collect-conts f cfa)))
+ (define (lookup-cont k)
+ (vector-ref contv (cfa-k-idx cfa k)))
-(define (emit-rtl-sequence asm exp allocation nlocals cont-table)
- (define (immediate-u8? val)
- (and (integer? val) (exact? val) (<= 0 val 255)))
+ (define (immediate-u8? val)
+ (and (integer? val) (exact? val) (<= 0 val 255)))
- (define (maybe-immediate-u8 sym)
- (call-with-values (lambda ()
- (lookup-maybe-constant-value sym allocation))
- (lambda (has-const? val)
- (and has-const? (immediate-u8? val) val))))
+ (define (maybe-immediate-u8 sym)
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value sym allocation))
+ (lambda (has-const? val)
+ (and has-const? (immediate-u8? val) val))))
- (define (slot sym)
- (lookup-slot sym allocation))
+ (define (slot sym)
+ (lookup-slot sym allocation))
- (define (constant sym)
- (lookup-constant-value sym allocation))
+ (define (constant sym)
+ (lookup-constant-value sym allocation))
- (define (emit-rtl label k exp next-label)
(define (maybe-mov dst src)
(unless (= dst src)
(emit-mov asm dst src)))
- (define (maybe-jump label)
- (unless (eq? label next-label)
- (emit-br asm label)))
-
(define (maybe-load-constant slot src)
(call-with-values (lambda ()
(lookup-maybe-constant-value src allocation))
@@ -134,7 +124,94 @@
(emit-load-constant asm slot val)
#t)))))
- (define (emit-tail)
+ (define (compile-entry meta)
+ (match (vector-ref contv 0)
+ (($ $kentry self tail clauses)
+ (emit-begin-program asm (cfa-k-sym cfa 0) meta)
+ (let lp ((n 1)
+ (ks (map (match-lambda (($ $cont k) k)) clauses)))
+ (match ks
+ (()
+ (unless (= n (vector-length contv))
+ (error "unexpected end of clauses"))
+ (emit-end-program asm))
+ ((k . ks)
+ (unless (eq? (cfa-k-sym cfa n) k)
+ (error "unexpected k" k))
+ (lp (compile-clause n (and (pair? ks) (car ks)))
+ ks)))))))
+
+ (define (compile-clause n alternate)
+ (match (vector-ref contv n)
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
+ (let* ((kw-indices (map (match-lambda
+ ((key name sym)
+ (cons key (lookup-slot sym allocation))))
+ kw))
+ (k (cfa-k-sym cfa n))
+ (nlocals (lookup-nlocals k allocation)))
+ (emit-label asm k)
+ (emit-begin-kw-arity asm req opt rest kw-indices
+ allow-other-keys? nlocals alternate)
+ (let ((next (compile-body (1+ n) nlocals)))
+ (emit-end-arity asm)
+ next)))))
+
+ (define (compile-body n nlocals)
+ (let compile-cont ((n n))
+ (if (= n (vector-length contv))
+ n
+ (match (vector-ref contv n)
+ (($ $kclause) n)
+ (($ $kargs _ _ term)
+ (emit-label asm (cfa-k-sym cfa n))
+ (let find-exp ((term term))
+ (match term
+ (($ $letk conts term)
+ (find-exp term))
+ (($ $continue k src exp)
+ (when src
+ (emit-source asm src))
+ (compile-expression n k exp nlocals)
+ (compile-cont (1+ n))))))
+ (_
+ (emit-label asm (cfa-k-sym cfa n))
+ (compile-cont (1+ n)))))))
+
+ (define (compile-expression n k exp nlocals)
+ (let* ((label (cfa-k-sym cfa n))
+ (k-idx (cfa-k-idx cfa k))
+ (fallthrough? (= k-idx (1+ n))))
+ (define (maybe-emit-jump)
+ (unless (= k-idx (1+ n))
+ (emit-br asm k)))
+ (match (vector-ref contv k-idx)
+ (($ $ktail)
+ (compile-tail label exp))
+ (($ $kargs (name) (sym))
+ (let ((dst (slot sym)))
+ (when dst
+ (compile-value label exp dst nlocals)))
+ (maybe-emit-jump))
+ (($ $kargs () ())
+ (compile-effect label exp k nlocals)
+ (maybe-emit-jump))
+ (($ $kargs names syms)
+ (compile-values label exp syms)
+ (maybe-emit-jump))
+ (($ $kif kt kf)
+ (compile-test label exp kt kf
+ (and (= k-idx (1+ n))
+ (< (+ n 2) (cfa-k-count cfa))
+ (cfa-k-sym cfa (+ n 2)))))
+ (($ $ktrunc ($ $arity req () rest () #f) k)
+ (compile-trunc label exp (length req) (and rest #t) nlocals)
+ (unless (and (= k-idx (1+ n))
+ (< (+ n 2) (cfa-k-count cfa))
+ (eq? (cfa-k-sym cfa (+ n 2)) k))
+ (emit-br asm k))))))
+
+ (define (compile-tail label exp)
;; There are only three kinds of expressions in tail position:
;; tail calls, multiple-value returns, and single-value returns.
(match exp
@@ -156,83 +233,107 @@
(($ $primcall 'return (arg))
(emit-return asm (slot arg)))))
- (define (emit-val sym)
- (let ((dst (slot sym)))
- (match exp
- (($ $var sym)
- (maybe-mov dst (slot sym)))
- (($ $void)
- (when dst
- (emit-load-constant asm dst *unspecified*)))
- (($ $const exp)
- (when dst
- (emit-load-constant asm dst exp)))
- (($ $fun meta () ($ $cont k))
- (emit-load-static-procedure asm dst k))
- (($ $fun meta free ($ $cont k))
- (emit-make-closure asm dst k (length free)))
- (($ $call proc args)
- (let ((proc-slot (lookup-call-proc-slot label allocation))
- (nargs (length args)))
- (or (maybe-load-constant proc-slot proc)
- (maybe-mov proc-slot (slot proc)))
- (let lp ((n (1+ proc-slot)) (args args))
- (match args
- (()
- (emit-call asm proc-slot (+ nargs 1))
- (emit-receive asm dst proc-slot nlocals))
- ((arg . args)
- (or (maybe-load-constant n arg)
- (maybe-mov n (slot arg)))
- (lp (1+ n) args))))))
- (($ $primcall 'current-module)
- (emit-current-module asm dst))
- (($ $primcall 'cached-toplevel-box (scope name bound?))
- (emit-cached-toplevel-box asm dst (constant scope) (constant name)
- (constant bound?)))
- (($ $primcall 'cached-module-box (mod name public? bound?))
- (emit-cached-module-box asm dst (constant mod) (constant name)
- (constant public?) (constant bound?)))
- (($ $primcall 'resolve (name bound?))
- (emit-resolve asm dst (constant bound?) (slot name)))
- (($ $primcall 'free-ref (closure idx))
- (emit-free-ref asm dst (slot closure) (constant idx)))
- (($ $primcall 'make-vector (length init))
- (cond
- ((maybe-immediate-u8 length)
- => (lambda (length)
- (emit-constant-make-vector asm dst length (slot init))))
- (else
- (emit-make-vector asm dst (slot length) (slot init)))))
- (($ $primcall 'vector-ref (vector index))
- (cond
- ((maybe-immediate-u8 index)
- => (lambda (index)
- (emit-constant-vector-ref asm dst (slot vector) index)))
- (else
- (emit-vector-ref asm dst (slot vector) (slot index)))))
- (($ $primcall name args)
- ;; FIXME: Inline all the cases.
- (let ((inst (prim-rtl-instruction name)))
- (emit-text asm `((,inst ,dst ,@(map slot args))))))
- (($ $values (arg))
- (or (maybe-load-constant dst arg)
- (maybe-mov dst (slot arg)))))
- (maybe-jump k)))
-
- (define (emit-vals syms)
+ (define (compile-value label exp dst nlocals)
(match exp
+ (($ $var sym)
+ (maybe-mov dst (slot sym)))
+ ;; FIXME: Remove ($var sym), replace with ($values (sym))
+ (($ $values (arg))
+ (or (maybe-load-constant dst arg)
+ (maybe-mov dst (slot arg))))
+ (($ $void)
+ (emit-load-constant asm dst *unspecified*))
+ (($ $const exp)
+ (emit-load-constant asm dst exp))
+ (($ $fun src meta () ($ $cont k))
+ (emit-load-static-procedure asm dst k))
+ (($ $fun src meta free ($ $cont k))
+ (emit-make-closure asm dst k (length free)))
+ (($ $call proc args)
+ (let ((proc-slot (lookup-call-proc-slot label allocation))
+ (nargs (length args)))
+ (or (maybe-load-constant proc-slot proc)
+ (maybe-mov proc-slot (slot proc)))
+ (let lp ((n (1+ proc-slot)) (args args))
+ (match args
+ (()
+ (emit-call asm proc-slot (+ nargs 1))
+ (emit-receive asm dst proc-slot nlocals))
+ ((arg . args)
+ (or (maybe-load-constant n arg)
+ (maybe-mov n (slot arg)))
+ (lp (1+ n) args))))))
+ (($ $primcall 'current-module)
+ (emit-current-module asm dst))
+ (($ $primcall 'cached-toplevel-box (scope name bound?))
+ (emit-cached-toplevel-box asm dst (constant scope) (constant name)
+ (constant bound?)))
+ (($ $primcall 'cached-module-box (mod name public? bound?))
+ (emit-cached-module-box asm dst (constant mod) (constant name)
+ (constant public?) (constant bound?)))
+ (($ $primcall 'resolve (name bound?))
+ (emit-resolve asm dst (constant bound?) (slot name)))
+ (($ $primcall 'free-ref (closure idx))
+ (emit-free-ref asm dst (slot closure) (constant idx)))
+ (($ $primcall 'make-vector (length init))
+ (cond
+ ((maybe-immediate-u8 length)
+ => (lambda (length)
+ (emit-constant-make-vector asm dst length (slot init))))
+ (else
+ (emit-make-vector asm dst (slot length) (slot init)))))
+ (($ $primcall 'vector-ref (vector index))
+ (cond
+ ((maybe-immediate-u8 index)
+ => (lambda (index)
+ (emit-constant-vector-ref asm dst (slot vector) index)))
+ (else
+ (emit-vector-ref asm dst (slot vector) (slot index)))))
+ (($ $primcall 'builtin-ref (name))
+ (emit-builtin-ref asm dst (constant name)))
+ (($ $primcall 'bv-u8-ref (bv idx))
+ (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-u16-ref (bv idx))
+ (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-s16-ref (bv idx))
+ (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-u32-ref (bv idx val))
+ (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-s32-ref (bv idx val))
+ (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-u64-ref (bv idx val))
+ (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-s64-ref (bv idx val))
+ (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-f32-ref (bv idx val))
+ (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-f64-ref (bv idx val))
+ (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
(($ $primcall name args)
- (error "unimplemented primcall in values context" name))
- (($ $values args)
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (for-each maybe-load-constant (map slot syms) args)))
- (maybe-jump k))
+ ;; FIXME: Inline all the cases.
+ (let ((inst (prim-rtl-instruction name)))
+ (emit-text asm `((,inst ,dst ,@(map slot args))))))))
- (define (emit-seq)
+ (define (compile-effect label exp k nlocals)
(match exp
+ (($ $values ()) #f)
+ (($ $prompt escape? tag handler pop)
+ (match (lookup-cont handler)
+ (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
+ (let ((receive-args (gensym "handler"))
+ (nreq (length req))
+ (proc-slot (lookup-call-proc-slot label allocation)))
+ (emit-prompt asm (slot tag) escape? proc-slot receive-args)
+ (emit-br asm k)
+ (emit-label asm receive-args)
+ (emit-receive-values asm proc-slot (->bool rest) nreq)
+ (when rest
+ (emit-bind-rest asm (+ proc-slot 1 nreq)))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves handler allocation))
+ (emit-reset-frame asm nlocals)
+ (emit-br asm khandler-body)))))
(($ $primcall 'cache-current-module! (sym scope))
(emit-cache-current-module! asm (slot sym) (constant scope)))
(($ $primcall 'free-set! (closure idx value))
@@ -258,52 +359,59 @@
(($ $primcall 'set-cdr! (pair value))
(emit-set-cdr! asm (slot pair) (slot value)))
(($ $primcall 'define! (sym value))
- (emit-define asm (slot sym) (slot value)))
+ (emit-define! asm (slot sym) (slot value)))
(($ $primcall 'push-fluid (fluid val))
(emit-push-fluid asm (slot fluid) (slot val)))
(($ $primcall 'pop-fluid ())
(emit-pop-fluid asm))
(($ $primcall 'wind (winder unwinder))
(emit-wind asm (slot winder) (slot unwinder)))
+ (($ $primcall 'bv-u8-set! (bv idx val))
+ (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-u16-set! (bv idx val))
+ (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-s16-set! (bv idx val))
+ (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-u32-set! (bv idx val))
+ (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-s32-set! (bv idx val))
+ (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-u64-set! (bv idx val))
+ (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-s64-set! (bv idx val))
+ (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-f32-set! (bv idx val))
+ (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-f64-set! (bv idx val))
+ (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'unwind ())
- (emit-unwind asm))
- (($ $primcall name args)
- (error "unhandled primcall in seq context" name))
- (($ $values ()) #f)
- (($ $prompt escape? tag handler)
- (match (lookup-cont handler cont-table)
- (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
- (let ((receive-args (gensym "handler"))
- (nreq (length req))
- (proc-slot (lookup-call-proc-slot label allocation)))
- (emit-prompt asm (slot tag) escape? proc-slot receive-args)
- (emit-br asm k)
- (emit-label asm receive-args)
- (emit-receive-values asm proc-slot (->bool rest) nreq)
- (when rest
- (emit-bind-rest asm (+ proc-slot 1 nreq)))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves handler allocation))
- (emit-reset-frame asm nlocals)
- (emit-br asm khandler-body))))))
- (maybe-jump k))
+ (emit-unwind asm))))
+
+ (define (compile-values label exp syms)
+ (match exp
+ (($ $values args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (for-each maybe-load-constant (map slot syms) args))))
- (define (emit-test kt kf)
+ (define (compile-test label exp kt kf next-label)
(define (unary op sym)
(cond
((eq? kt next-label)
(op asm (slot sym) #t kf))
(else
(op asm (slot sym) #f kt)
- (maybe-jump kf))))
+ (unless (eq? kf next-label)
+ (emit-br asm kf)))))
(define (binary op a b)
(cond
((eq? kt next-label)
(op asm (slot a) (slot b) #t kf))
(else
(op asm (slot a) (slot b) #f kt)
- (maybe-jump kf))))
+ (unless (eq? kf next-label)
+ (emit-br asm kf)))))
(match exp
(($ $var sym) (unary emit-br-if-true sym))
(($ $primcall 'null? (a)) (unary emit-br-if-null a))
@@ -315,6 +423,7 @@
(($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
(($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
(($ $primcall 'string? (a)) (unary emit-br-if-string a))
+ (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
;; Add more TC7 tests here. Keep in sync with
;; *branching-primcall-arities* in (language cps primitives) and
;; the set of macro-instructions in assembly.scm.
@@ -327,7 +436,7 @@
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
(($ $primcall '> (a b)) (binary emit-br-if-< b a))))
- (define (emit-trunc nreq rest? k)
+ (define (compile-trunc label exp nreq rest? nlocals)
(match exp
(($ $call proc args)
(let ((proc-slot (lookup-call-proc-slot label allocation))
@@ -351,84 +460,38 @@
((arg . args)
(or (maybe-load-constant n arg)
(maybe-mov n (slot arg)))
- (lp (1+ n) args)))))))
- (maybe-jump k))
-
- (match (lookup-cont k cont-table)
- (($ $ktail) (emit-tail))
- (($ $kargs (name) (sym)) (emit-val sym))
- (($ $kargs () ()) (emit-seq))
- (($ $kargs names syms) (emit-vals syms))
- (($ $kargs (name) (sym)) (emit-val sym))
- (($ $kif kt kf) (emit-test kt kf))
- (($ $ktrunc ($ $arity req () rest () #f) k)
- (emit-trunc (length req) (and rest #t) k))))
-
- (define (collect-exps k src cont tail)
- (define (find-exp k src term)
- (match term
- (($ $continue exp-k exp)
- (cons (list k src exp-k exp) tail))
- (($ $letk conts body)
- (find-exp k src body))))
- (match cont
- (($ $kargs names syms body)
- (find-exp k src body))
- (_ tail)))
-
- (let lp ((exps (reverse (fold-local-conts collect-exps '() exp))))
- (match exps
- (() #t)
- (((k src exp-k exp) . exps)
- (let ((next-label (match exps
- (((k . _) . _) k)
- (() #f))))
- (emit-label asm k)
- (when src
- (emit-source asm src))
- (emit-rtl k exp-k exp next-label)
- (lp exps))))))
-
-(define (compile-fun f asm)
- (let ((allocation (allocate-slots f))
- (cont-table (match f
- (($ $fun meta free body)
- (build-local-cont-table body)))))
- (define (emit-fun-clause clause alternate)
- (match clause
- (($ $cont k src
- ($ $kclause ($ $arity req opt rest kw allow-other-keys?)
- body))
- (let ((kw-indices (map (match-lambda
- ((key name sym)
- (cons key (lookup-slot sym allocation))))
- kw))
- (nlocals (lookup-nlocals k allocation)))
- (emit-label asm k)
- (when src
- (emit-source asm src))
- (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
- nlocals alternate)
- (emit-rtl-sequence asm body allocation nlocals cont-table)
- (emit-end-arity asm)))))
-
- (define (emit-fun-clauses clauses)
- (match clauses
- ((clause . clauses)
- (let ((kalternate (match clauses
- (() #f)
- ((($ $cont k) . _) k))))
- (emit-fun-clause clause kalternate)
- (when kalternate
- (emit-fun-clauses clauses))))))
+ (lp (1+ n) args))))))))
(match f
- (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
- (emit-begin-program asm k (or meta '()))
+ (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
+ ;; FIXME: src on kentry instead?
(when src
(emit-source asm src))
- (emit-fun-clauses clauses)
- (emit-end-program asm)))))
+ (compile-entry (or meta '()))))))
+
+(define (visit-funs proc exp)
+ (match exp
+ (($ $continue _ _ exp)
+ (visit-funs proc exp))
+
+ (($ $fun src meta free body)
+ (proc exp)
+ (visit-funs proc body))
+
+ (($ $letk conts body)
+ (visit-funs proc body)
+ (for-each (lambda (cont) (visit-funs proc cont)) conts))
+
+ (($ $cont sym ($ $kargs names syms body))
+ (visit-funs proc body))
+
+ (($ $cont sym ($ $kclause arity body))
+ (visit-funs proc body))
+
+ (($ $cont sym ($ $kentry self tail clauses))
+ (for-each (lambda (clause) (visit-funs proc clause)) clauses))
+
+ (_ (values))))
(define (compile-rtl exp env opts)
(let* ((exp (fix-arities exp))
diff --git a/module/language/cps/constructors.scm
b/module/language/cps/constructors.scm
index b8d4e96..d7ff0ab 100644
--- a/module/language/cps/constructors.scm
+++ b/module/language/cps/constructors.scm
@@ -32,12 +32,12 @@
(define (inline-constructors fun)
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body))))
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont)
,cont)))
(define (visit-term term)
@@ -48,51 +48,51 @@
(($ $letrec names syms funs body)
($letrec names syms (map inline-constructors funs)
,(visit-term body)))
- (($ $continue k ($ $primcall 'list args))
+ (($ $continue k src ($ $primcall 'list args))
,(let-gensyms (kvalues val)
(build-cps-term
- ($letk ((kvalues #f ($kargs ('val) (val)
- ($continue k
- ($primcall 'values (val))))))
+ ($letk ((kvalues ($kargs ('val) (val)
+ ($continue k src
+ ($primcall 'values (val))))))
,(let lp ((args args) (k kvalues))
(match args
(()
(build-cps-term
- ($continue k ($const '()))))
+ ($continue k src ($const '()))))
((arg . args)
(let-gensyms (ktail tail)
(build-cps-term
- ($letk ((ktail #f ($kargs ('tail) (tail)
- ($continue k
- ($primcall 'cons (arg tail))))))
+ ($letk ((ktail ($kargs ('tail) (tail)
+ ($continue k src
+ ($primcall 'cons (arg tail))))))
,(lp args ktail)))))))))))
- (($ $continue k ($ $primcall 'vector args))
+ (($ $continue k src ($ $primcall 'vector args))
,(let-gensyms (kalloc vec len init)
(define (initialize args n)
(match args
(()
(build-cps-term
- ($continue k ($primcall 'values (vec)))))
+ ($continue k src ($primcall 'values (vec)))))
((arg . args)
(let-gensyms (knext idx)
(build-cps-term
- ($letk ((knext #f ($kargs () ()
- ,(initialize args (1+ n)))))
+ ($letk ((knext ($kargs () ()
+ ,(initialize args (1+ n)))))
($letconst (('idx idx n))
- ($continue knext
+ ($continue knext src
($primcall 'vector-set! (vec idx arg))))))))))
(build-cps-term
- ($letk ((kalloc #f ($kargs ('vec) (vec)
- ,(initialize args 0))))
+ ($letk ((kalloc ($kargs ('vec) (vec)
+ ,(initialize args 0))))
($letconst (('len len (length args))
('init init #f))
- ($continue kalloc
+ ($continue kalloc src
($primcall 'make-vector (len init))))))))
- (($ $continue k (and fun ($ $fun)))
- ($continue k ,(inline-constructors fun)))
+ (($ $continue k src (and fun ($ $fun)))
+ ($continue k src ,(inline-constructors fun)))
(($ $continue)
,term)))
(rewrite-cps-exp fun
- (($ $fun meta free body)
- ($fun meta free ,(visit-cont body)))))
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body)))))
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index 00a5a57..7a9252e 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -30,7 +30,7 @@
(define-module (language cps contification)
#:use-module (ice-9 match)
- #:use-module ((srfi srfi-1) #:select (concatenate))
+ #:use-module ((srfi srfi-1) #:select (concatenate filter-map))
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps dfg)
@@ -49,8 +49,8 @@
(set! call-substs (acons sym (map cons arities body-ks) call-substs)))
(define (subst-return! old-tail new-tail)
(set! cont-substs (acons old-tail new-tail cont-substs)))
- (define (elide-function! k)
- (set! fun-elisions (cons k fun-elisions)))
+ (define (elide-function! k cont)
+ (set! fun-elisions (acons k cont fun-elisions)))
(define (splice-conts! scope conts)
(hashq-set! cont-splices scope
(append conts (hashq-ref cont-splices scope '()))))
@@ -84,18 +84,22 @@
;; Are the given args compatible with any of the arities?
(define (applicable? proc args)
- (or-map (match-lambda
- (($ $arity req () #f () #f)
- (= (length args) (length req)))
- (_ #f))
- (assq-ref (map cons syms arities) proc)))
+ (let lp ((arities (assq-ref (map cons syms arities) proc)))
+ (match arities
+ ((($ $arity req () #f () #f) . arities)
+ (or (= (length args) (length req))
+ (lp arities)))
+ ;; If we reached the end of the arities, fail. Also fail if
+ ;; the next arity in the list has optional, keyword, or rest
+ ;; arguments.
+ (_ #f))))
;; If the use of PROC in continuation USE is a call to PROC that
;; is compatible with one of the procedure's arities, return the
;; target continuation. Otherwise return #f.
(define (call-target use proc)
(match (find-call (lookup-cont use cont-table))
- (($ $continue k ($ $call proc* args))
+ (($ $continue k src ($ $call proc* args))
(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
k))
(_ #f)))
@@ -141,7 +145,7 @@
;; bail.
(($ $kentry self tail clauses)
(match clauses
- ((($ $cont _ _ ($ $kclause arity ($ $cont kargs))))
+ ((($ $cont _ ($ $kclause arity ($ $cont kargs))))
kargs)
(_ #f)))
(_ scope)))))
@@ -168,15 +172,15 @@
(define (visit-fun term)
(match term
- (($ $fun meta free body)
+ (($ $fun src meta free body)
(visit-cont body))))
(define (visit-cont cont)
(match cont
- (($ $cont sym src ($ $kargs _ _ body))
+ (($ $cont sym ($ $kargs _ _ body))
(visit-term body sym))
- (($ $cont sym src ($ $kentry self tail clauses))
+ (($ $cont sym ($ $kentry self tail clauses))
(for-each visit-cont clauses))
- (($ $cont sym src ($ $kclause arity body))
+ (($ $cont sym ($ $kclause arity body))
(visit-cont body))
(($ $cont)
#t)))
@@ -199,7 +203,7 @@
(if (null? rec)
'()
(list rec)))
- (((and elt (n s ($ $fun meta free ($ $cont kentry))))
+ (((and elt (n s ($ $fun src meta free ($ $cont kentry))))
. nsf)
(if (recursive? kentry)
(lp nsf (cons elt rec))
@@ -208,11 +212,11 @@
(match component
(((name sym fun) ...)
(match fun
- ((($ $fun meta free
- ($ $cont fun-k _
+ ((($ $fun src meta free
+ ($ $cont fun-k
($ $kentry self
- ($ $cont tail-k _ ($ $ktail))
- (($ $cont _ _ ($ $kclause arity body))
+ ($ $cont tail-k ($ $ktail))
+ (($ $cont _ ($ $kclause arity body))
...))))
...)
(unless (contify-funs term-k sym self tail-k arity body)
@@ -220,17 +224,17 @@
(visit-term body term-k)
(for-each visit-component
(split-components (map list names syms funs))))
- (($ $continue k exp)
+ (($ $continue k src exp)
(match exp
- (($ $fun meta free
- ($ $cont fun-k _
+ (($ $fun src meta free
+ ($ $cont fun-k
($ $kentry self
- ($ $cont tail-k _ ($ $ktail))
- (($ $cont _ _ ($ $kclause arity body)) ...))))
+ ($ $cont tail-k ($ $ktail))
+ (($ $cont _ ($ $kclause arity body)) ...))))
(if (and=> (bound-symbol k)
(lambda (sym)
(contify-fun term-k sym self tail-k arity body)))
- (elide-function! k)
+ (elide-function! k (lookup-cont k cont-table))
(visit-fun exp)))
(_ #t)))))
@@ -238,7 +242,7 @@
(values call-substs cont-substs fun-elisions cont-splices)))
(define (apply-contification fun call-substs cont-substs fun-elisions
cont-splices)
- (define (contify-call proc args)
+ (define (contify-call src proc args)
(and=> (assq-ref call-substs proc)
(lambda (clauses)
(let lp ((clauses clauses))
@@ -247,11 +251,11 @@
(((($ $arity req () #f () #f) . k) . clauses)
(if (= (length req) (length args))
(build-cps-term
- ($continue k
+ ($continue k src
($values args)))
(lp clauses)))
((_ . clauses) (lp clauses)))))))
- (define (continue k exp)
+ (define (continue k src exp)
(define (lookup-return-cont k)
(match (assq-ref cont-substs k)
(#f k)
@@ -260,13 +264,13 @@
;; We are contifying this return. It must be a call or a
;; primcall to values, return, or return-values.
(if (eq? k k*)
- (build-cps-term ($continue k ,exp))
+ (build-cps-term ($continue k src ,exp))
(rewrite-cps-term exp
(($ $primcall 'return (val))
- ($continue k* ($primcall 'values (val))))
+ ($continue k* src ($primcall 'values (val))))
(($ $values vals)
- ($continue k* ($primcall 'values vals)))
- (_ ($continue k* ,exp))))))
+ ($continue k* src ($primcall 'values vals)))
+ (_ ($continue k* src ,exp))))))
(define (splice-continuations term-k term)
(match (hashq-ref cont-splices term-k)
(#f term)
@@ -276,26 +280,26 @@
(($ $letrec names syms funs body)
($letrec names syms funs ,(lp body)))
(($ $letk conts* body)
- ($letk ,(append conts* (map visit-cont cont))
+ ($letk ,(append conts* (filter-map visit-cont cont))
,body))
(body
- ($letk ,(map visit-cont cont)
+ ($letk ,(filter-map visit-cont cont)
,body)))))))
(define (visit-fun term)
(rewrite-cps-exp term
- (($ $fun meta free body)
- ($fun meta free ,(visit-cont body)))))
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont (and k (? (cut memq <> fun-elisions))) src
- ($ $kargs (_) (_) body))
- (k src ($kargs () () ,(visit-term body k))))
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body sym))))
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont (? (cut assq <> fun-elisions)))
+ ;; This cont gets inlined in place of the $fun.
+ ,#f)
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body sym))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont)
,cont)))
(define (visit-term term term-k)
@@ -312,10 +316,10 @@
(($ $letrec names syms funs body)
($letrec names syms funs ,(lp body)))
(($ $letk conts* body)
- ($letk ,(append conts* (map visit-cont conts))
+ ($letk ,(append conts* (filter-map visit-cont conts))
,body))
(body
- ($letk ,(map visit-cont conts)
+ ($letk ,(filter-map visit-cont conts)
,body)))))
(($ $letrec names syms funs body)
(rewrite-cps-term (filter (match-lambda
@@ -324,19 +328,22 @@
(((names syms funs) ...)
($letrec names syms (map visit-fun funs)
,(visit-term body term-k)))))
- (($ $continue k exp)
+ (($ $continue k src exp)
(splice-continuations
term-k
(match exp
(($ $fun)
- (if (memq k fun-elisions)
- (build-cps-term
- ($continue k ($values ())))
- (continue k (visit-fun exp))))
+ (cond
+ ((assq-ref fun-elisions k)
+ => (match-lambda
+ (($ $kargs (_) (_) body)
+ (visit-term body k))))
+ (else
+ (continue k src (visit-fun exp)))))
(($ $call proc args)
- (or (contify-call proc args)
- (continue k exp)))
- (_ (continue k exp)))))))
+ (or (contify-call src proc args)
+ (continue k src exp)))
+ (_ (continue k src exp)))))))
(visit-fun fun))
(define (contify fun)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index ec558e9..4d38d52 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -62,6 +62,10 @@
control-point?
lookup-bound-syms
+ ;; Control flow analysis.
+ analyze-control-flow
+ cfa-k-idx cfa-k-count cfa-k-sym cfa-predecessors
+
;; Data flow analysis.
compute-live-variables
dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
@@ -69,14 +73,14 @@
print-dfa))
(define (build-cont-table fun)
- (fold-conts (lambda (k src cont table)
+ (fold-conts (lambda (k cont table)
(hashq-set! table k cont)
table)
(make-hash-table)
fun))
(define (build-local-cont-table cont)
- (fold-local-conts (lambda (k src cont table)
+ (fold-local-conts (lambda (k cont table)
(hashq-set! table k cont)
table)
(make-hash-table)
@@ -108,33 +112,23 @@
(uses use-map-uses set-use-map-uses!))
(define-record-type $block
- (%make-block scope scope-level preds succs
- idom dom-level
- pdom pdom-level
- loop-header irreducible)
+ (%make-block scope scope-level preds succs)
block?
(scope block-scope set-block-scope!)
(scope-level block-scope-level set-block-scope-level!)
(preds block-preds set-block-preds!)
- (succs block-succs set-block-succs!)
- (idom block-idom set-block-idom!)
- (dom-level block-dom-level set-block-dom-level!)
-
- (pdom block-pdom set-block-pdom!)
- (pdom-level block-pdom-level set-block-pdom-level!)
-
- ;; The loop header of this block, if this block is part of a reducible
- ;; loop. Otherwise #f.
- (loop-header block-loop-header set-block-loop-header!)
-
- ;; Some sort of marker that this block is part of an irreducible
- ;; (multi-entry) loop. Otherwise #f.
- (irreducible block-irreducible set-block-irreducible!))
+ (succs block-succs set-block-succs!))
(define (make-block scope scope-level)
- (%make-block scope scope-level '() '() #f #f #f #f #f #f))
-
-(define (reverse-post-order k0 blocks accessor)
+ (%make-block scope scope-level '() '()))
+
+;; Some analyses assume that the only relevant set of nodes is the set
+;; that is reachable from some start node. Others need to include nodes
+;; that are reachable from an end node as well, or all nodes in a
+;; function. In that case pass an appropriate implementation of
+;; fold-all-conts, as compute-live-variables does.
+(define* (reverse-post-order k0 get-successors #:optional
+ (fold-all-conts (lambda (f seed) seed)))
(let ((order '())
(visited? (make-hash-table)))
(let visit ((k k0))
@@ -142,28 +136,99 @@
(for-each (lambda (k)
(unless (hashq-ref visited? k)
(visit k)))
- (accessor (lookup-block k blocks)))
+ (get-successors k))
(set! order (cons k order)))
- (list->vector order)))
-
-(define (convert-predecessors order blocks accessor)
- (let* ((mapping (make-hash-table))
- (preds-vec (make-vector (vector-length order) #f)))
+ (list->vector (fold-all-conts
+ (lambda (k seed)
+ (if (hashq-ref visited? k)
+ seed
+ (begin
+ (hashq-set! visited? k #t)
+ (cons k seed))))
+ order))))
+
+(define (make-block-mapping order)
+ (let ((mapping (make-hash-table)))
(let lp ((n 0))
(when (< n (vector-length order))
(hashq-set! mapping (vector-ref order n) n)
(lp (1+ n))))
+ mapping))
+
+(define (convert-predecessors order get-predecessors)
+ (let ((preds-vec (make-vector (vector-length order) #f)))
(let lp ((n 0))
(when (< n (vector-length order))
- (let ((preds (accessor (lookup-block (vector-ref order n) blocks))))
- (vector-set! preds-vec n
- ;; It's possible for a predecessor to not be in
- ;; the mapping, if the predecessor is not
- ;; reachable from the entry node.
- (filter-map (cut hashq-ref mapping <>) preds))
- (lp (1+ n)))))
+ (vector-set! preds-vec n (get-predecessors (vector-ref order n)))
+ (lp (1+ n))))
preds-vec))
+;; Control-flow analysis.
+(define-record-type $cfa
+ (make-cfa k-map order preds)
+ cfa?
+ ;; Hash table mapping k-sym -> k-idx
+ (k-map cfa-k-map)
+ ;; Vector of k-idx -> k-sym, in reverse post order
+ (order cfa-order)
+ ;; Vector of k-idx -> list of k-idx
+ (preds cfa-preds))
+
+(define* (cfa-k-idx cfa k
+ #:key (default (lambda (k)
+ (error "unknown k" k))))
+ (or (hashq-ref (cfa-k-map cfa) k)
+ (default k)))
+
+(define (cfa-k-count cfa)
+ (vector-length (cfa-order cfa)))
+
+(define (cfa-k-sym cfa n)
+ (vector-ref (cfa-order cfa) n))
+
+(define (cfa-predecessors cfa n)
+ (vector-ref (cfa-preds cfa) n))
+
+(define* (analyze-control-flow fun dfg #:key reverse?)
+ (define (build-cfa kentry block-succs block-preds)
+ (define (block-accessor accessor)
+ (lambda (k)
+ (accessor (lookup-block k (dfg-blocks dfg)))))
+ (define (reachable-preds mapping accessor)
+ ;; It's possible for a predecessor to not be in the mapping, if
+ ;; the predecessor is not reachable from the entry node.
+ (lambda (k)
+ (filter-map (cut hashq-ref mapping <>)
+ ((block-accessor accessor) k))))
+ (let* ((order (reverse-post-order kentry (block-accessor block-succs)))
+ (k-map (make-block-mapping order))
+ (preds (convert-predecessors order
+ (reachable-preds k-map block-preds))))
+ (make-cfa k-map order preds)))
+ (match fun
+ (($ $fun src meta free
+ ($ $cont kentry
+ (and entry
+ ($ $kentry self ($ $cont ktail tail) clauses))))
+ (if reverse?
+ (build-cfa ktail block-preds block-succs)
+ (build-cfa kentry block-succs block-preds)))))
+
+;; Dominator analysis.
+(define-record-type $dominator-analysis
+ (make-dominator-analysis cfa idoms dom-levels loop-header irreducible)
+ dominator-analysis?
+ ;; The corresponding $cfa
+ (cfa dominator-analysis-cfa)
+ ;; Vector of k-idx -> k-idx
+ (idoms dominator-analysis-idoms)
+ ;; Vector of k-idx -> dom-level
+ (dom-levels dominator-analysis-dom-levels)
+ ;; Vector of k-idx -> k-idx or -1
+ (loop-header dominator-analysis-loop-header)
+ ;; Vector of k-idx -> true or false value
+ (irreducible dominator-analysis-irreducible))
+
(define (compute-dom-levels idoms)
(let ((dom-levels (make-vector (vector-length idoms) #f)))
(define (compute-dom-level n)
@@ -375,40 +440,13 @@
(lp (1- level))))
loop-headers))
-(define (analyze-control-flow! kentry kexit blocks)
- ;; First go forward in the graph, computing dominators and loop
- ;; information.
- (let* ((order (reverse-post-order kentry blocks block-succs))
- (preds (convert-predecessors order blocks block-preds))
- (idoms (compute-idoms preds))
- (dom-levels (compute-dom-levels idoms))
- (loop-headers (identify-loops preds idoms dom-levels)))
- (let lp ((n 0))
- (when (< n (vector-length order))
- (let* ((k (vector-ref order n))
- (idom (vector-ref idoms n))
- (dom-level (vector-ref dom-levels n))
- (loop-header (vector-ref loop-headers n))
- (b (lookup-block k blocks)))
- (set-block-idom! b (vector-ref order idom))
- (set-block-dom-level! b dom-level)
- (set-block-loop-header! b (and loop-header
- (vector-ref order loop-header)))
- (lp (1+ n))))))
- ;; Then go backwards, computing post-dominators.
- (let* ((order (reverse-post-order kexit blocks block-preds))
- (preds (convert-predecessors order blocks block-succs))
- (idoms (compute-idoms preds))
- (dom-levels (compute-dom-levels idoms)))
- (let lp ((n 0))
- (when (< n (vector-length order))
- (let* ((k (vector-ref order n))
- (pdom (vector-ref idoms n))
- (pdom-level (vector-ref dom-levels n))
- (b (lookup-block k blocks)))
- (set-block-pdom! b (vector-ref order pdom))
- (set-block-pdom-level! b pdom-level)
- (lp (1+ n)))))))
+(define (analyze-dominators cfa)
+ (match cfa
+ (($ $cfa k-map order preds)
+ (let* ((idoms (compute-idoms preds))
+ (dom-levels (compute-dom-levels idoms))
+ (loop-headers (identify-loops preds idoms dom-levels)))
+ (make-dominator-analysis cfa idoms dom-levels loop-headers #f)))))
;; Compute the maximum fixed point of the data-flow constraint problem.
@@ -448,14 +486,14 @@
;; Data-flow analysis.
(define-record-type $dfa
- (make-dfa k->idx order var->idx names syms in out)
+ (make-dfa k-map order var-map names syms in out)
dfa?
- ;; Function mapping k-sym -> k-idx
- (k->idx dfa-k->idx)
+ ;; Hash table mapping k-sym -> k-idx
+ (k-map dfa-k-map)
;; Vector of k-idx -> k-sym
(order dfa-order)
- ;; Function mapping var-sym -> var-idx
- (var->idx dfa-var->idx)
+ ;; Hash table mapping var-sym -> var-idx
+ (var-map dfa-var-map)
;; Vector of var-idx -> name
(names dfa-names)
;; Vector of var-idx -> var-sym
@@ -466,7 +504,8 @@
(out dfa-out))
(define (dfa-k-idx dfa k)
- ((dfa-k->idx dfa) k))
+ (or (hashq-ref (dfa-k-map dfa) k)
+ (error "unknown k" k)))
(define (dfa-k-sym dfa idx)
(vector-ref (dfa-order dfa) idx))
@@ -475,7 +514,8 @@
(vector-length (dfa-order dfa)))
(define (dfa-var-idx dfa var)
- ((dfa-var->idx dfa) var))
+ (or (hashq-ref (dfa-var-map dfa) var)
+ (error "unknown var" var)))
(define (dfa-var-name dfa idx)
(vector-ref (dfa-names dfa) idx))
@@ -492,74 +532,83 @@
(define (dfa-k-out dfa idx)
(vector-ref (dfa-out dfa) idx))
-(define (compute-live-variables ktail dfg)
- (define (make-variable-mapper use-maps)
+(define (compute-live-variables fun dfg)
+ (define (make-variable-mapping use-maps)
(let ((mapping (make-hash-table))
(n 0))
(hash-for-each (lambda (sym use-map)
(hashq-set! mapping sym n)
(set! n (1+ n)))
use-maps)
- (values (lambda (sym)
- (or (hashq-ref mapping sym)
- (error "unknown sym" sym)))
- n)))
- (define (make-block-mapper order)
- (let ((mapping (make-hash-table)))
- (let lp ((n 0))
- (when (< n (vector-length order))
- (hashq-set! mapping (vector-ref order n) n)
- (lp (1+ n))))
- (lambda (k)
- (or (hashq-ref mapping k)
- (error "unknown k" k)))))
-
- (call-with-values (lambda () (make-variable-mapper (dfg-use-maps dfg)))
- (lambda (var->idx nvars)
- (let* ((blocks (dfg-blocks dfg))
- (order (reverse-post-order ktail blocks block-preds))
- (succs (convert-predecessors order blocks block-succs))
- (k->idx (make-block-mapper order))
- (syms (make-vector nvars #f))
- (names (make-vector nvars #f))
- (usev (make-vector (vector-length order) '()))
- (defv (make-vector (vector-length order) '()))
- (live-in (make-vector (vector-length order) #f))
- (live-out (make-vector (vector-length order) #f)))
- ;; Initialize syms, names, defv, and usev.
- (hash-for-each
- (lambda (sym use-map)
- (match use-map
- (($ $use-map name sym def uses)
- (let ((v (var->idx sym)))
- (vector-set! syms v sym)
- (vector-set! names v name)
- (for-each (lambda (def)
- (vector-push! defv (k->idx def) v))
- (block-preds (lookup-block def blocks)))
- (for-each (lambda (use)
- (vector-push! usev (k->idx use) v))
- uses)))))
- (dfg-use-maps dfg))
-
- ;; Initialize live-in and live-out sets.
- (let lp ((n 0))
- (when (< n (vector-length live-out))
- (vector-set! live-in n (make-bitvector nvars #f))
- (vector-set! live-out n (make-bitvector nvars #f))
- (lp (1+ n))))
-
- ;; Liveness is a reverse data-flow problem, so we give
- ;; compute-maximum-fixed-point a reversed graph, swapping in and
- ;; out, usev and defv, using successors instead of predecessors,
- ;; and starting with ktail instead of the entry.
- (compute-maximum-fixed-point succs live-out live-in defv usev #t)
-
- (make-dfa k->idx order var->idx names syms live-in live-out)))))
+ (values mapping n)))
+ (define (block-accessor blocks accessor)
+ (lambda (k)
+ (accessor (lookup-block k blocks))))
+ (define (renumbering-accessor mapping blocks accessor)
+ (lambda (k)
+ (map (cut hashq-ref mapping <>)
+ ((block-accessor blocks accessor) k))))
+ (match fun
+ (($ $fun src meta free
+ (and entry
+ ($ $cont kentry ($ $kentry self ($ $cont ktail tail)))))
+ (call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
+ (lambda (var-map nvars)
+ (define (fold-all-conts f seed)
+ (fold-local-conts (lambda (k cont seed) (f k seed))
+ seed entry))
+ (let* ((blocks (dfg-blocks dfg))
+ (order (reverse-post-order ktail
+ (block-accessor blocks block-preds)
+ fold-all-conts))
+ (k-map (make-block-mapping order))
+ (succs (convert-predecessors
+ order
+ (renumbering-accessor k-map blocks block-succs)))
+ (syms (make-vector nvars #f))
+ (names (make-vector nvars #f))
+ (usev (make-vector (vector-length order) '()))
+ (defv (make-vector (vector-length order) '()))
+ (live-in (make-vector (vector-length order) #f))
+ (live-out (make-vector (vector-length order) #f)))
+ (define (k->idx k)
+ (or (hashq-ref k-map k) (error "unknown k" k)))
+ ;; Initialize syms, names, defv, and usev.
+ (hash-for-each
+ (lambda (sym use-map)
+ (match use-map
+ (($ $use-map name sym def uses)
+ (let ((v (or (hashq-ref var-map sym)
+ (error "unknown var" sym))))
+ (vector-set! syms v sym)
+ (vector-set! names v name)
+ (for-each (lambda (def)
+ (vector-push! defv (k->idx def) v))
+ ((block-accessor blocks block-preds) def))
+ (for-each (lambda (use)
+ (vector-push! usev (k->idx use) v))
+ uses)))))
+ (dfg-use-maps dfg))
+
+ ;; Initialize live-in and live-out sets.
+ (let lp ((n 0))
+ (when (< n (vector-length live-out))
+ (vector-set! live-in n (make-bitvector nvars #f))
+ (vector-set! live-out n (make-bitvector nvars #f))
+ (lp (1+ n))))
+
+ ;; Liveness is a reverse data-flow problem, so we give
+ ;; compute-maximum-fixed-point a reversed graph, swapping in
+ ;; and out, usev and defv, using successors instead of
+ ;; predecessors, and starting with ktail instead of the
+ ;; entry.
+ (compute-maximum-fixed-point succs live-out live-in defv usev #t)
+
+ (make-dfa k-map order var-map names syms live-in live-out)))))))
(define (print-dfa dfa)
(match dfa
- (($ $dfa k->idx order var->idx names syms in out)
+ (($ $dfa k-map order var-map names syms in out)
(define (print-var-set bv)
(let lp ((n 0))
(let ((n (bit-position #t bv n)))
@@ -613,7 +662,7 @@
(define (recur exp)
(visit exp exp-k))
(match exp
- (($ $letk (($ $cont k src cont) ...) body)
+ (($ $letk (($ $cont k cont) ...) body)
;; Set up recursive environment before visiting cont bodies.
(for-each (lambda (cont k)
(declare-block! k cont exp-k))
@@ -639,7 +688,7 @@
(for-each (cut visit-fun <> conts blocks use-maps global?) funs)
(visit body exp-k))
- (($ $continue k exp)
+ (($ $continue k src exp)
(use-k! k)
(match exp
(($ $var sym)
@@ -655,9 +704,20 @@
(($ $values args)
(for-each use! args))
- (($ $prompt escape? tag handler)
+ (($ $prompt escape? tag handler pop)
(use! tag)
- (use-k! handler))
+ (use-k! handler)
+ ;; Any continuation in the prompt body could cause an abort to
+ ;; the handler, so in theory we could register the handler as
+ ;; a successor of any block in the prompt body. That would be
+ ;; inefficient, though, besides being a hack. Instead we take
+ ;; advantage of the fact that pop continuation post-dominates
+ ;; the prompt body, so we add a link from there to the
+ ;; handler. This creates a primcall node with multiple
+ ;; successors, which is not quite correct, but it does reflect
+ ;; control flow. It is necessary to ensure that the live
+ ;; variables in the handler are seen as live in the body.
+ (link-blocks! pop handler))
(($ $fun)
(when global?
@@ -666,10 +726,10 @@
(_ #f)))))
(match fun
- (($ $fun meta free
- ($ $cont kentry src
+ (($ $fun src meta free
+ ($ $cont kentry
(and entry
- ($ $kentry self ($ $cont ktail _ tail) clauses))))
+ ($ $kentry self ($ $cont ktail tail) clauses))))
(declare-block! kentry entry #f 0)
(add-def! #f self kentry)
@@ -677,8 +737,8 @@
(for-each
(match-lambda
- (($ $cont kclause _
- (and clause ($ $kclause arity ($ $cont kbody _ body))))
+ (($ $cont kclause
+ (and clause ($ $kclause arity ($ $cont kbody body))))
(declare-block! kclause clause kentry)
(link-blocks! kentry kclause)
@@ -686,9 +746,7 @@
(link-blocks! kclause kbody)
(visit body kbody)))
- clauses)
-
- (analyze-control-flow! kentry ktail blocks))))
+ clauses))))
(define* (compute-dfg fun #:key (global? #t))
(let* ((conts (make-hash-table))
@@ -753,7 +811,7 @@
(define (call-expression call)
(match call
- (($ $continue k exp) exp)))
+ (($ $continue k src exp) exp)))
(define (find-expression term)
(call-expression (find-call term)))
@@ -769,7 +827,7 @@
(match (find-defining-expression sym dfg)
(($ $const val)
(values #t val))
- (($ $continue k ($ $void))
+ (($ $continue k src ($ $void))
(values #t *unspecified*))
(else
(values #f #f))))
@@ -810,6 +868,8 @@
(not (and (eq? sym i) (immediate-u8? val))))
(($ $primcall 'vector-set! (v i x))
(not (and (eq? sym i) (immediate-u8? val))))
+ (($ $primcall 'builtin-ref (idx))
+ #f)
(_ #t)))
uses))))))
@@ -838,31 +898,6 @@
(($ $use-map name sym def uses)
uses))))))
-;; Does k1 dominate k2?
-(define (dominates? k1 k2 blocks)
- (let ((b1 (lookup-block k1 blocks))
- (b2 (lookup-block k2 blocks)))
- (let ((k1-level (block-dom-level b1))
- (k2-level (block-dom-level b2)))
- (cond
- ((> k1-level k2-level) #f)
- ((< k1-level k2-level) (dominates? k1 (block-idom b2) blocks))
- ((= k1-level k2-level) (eqv? k1 k2))))))
-
-;; Does k1 post-dominate k2?
-(define (post-dominates? k1 k2 blocks)
- (let ((b1 (lookup-block k1 blocks))
- (b2 (lookup-block k2 blocks)))
- (let ((k1-level (block-pdom-level b1))
- (k2-level (block-pdom-level b2)))
- (cond
- ((> k1-level k2-level) #f)
- ((< k1-level k2-level) (post-dominates? k1 (block-pdom b2) blocks))
- ((= k1-level k2-level) (eqv? k1 k2))))))
-
-(define (lookup-loop-header k blocks)
- (block-loop-header (lookup-block k blocks)))
-
;; A continuation is a control point if it has multiple predecessors, or
;; if its single predecessor has multiple successors.
(define (control-point? k dfg)
diff --git a/module/language/cps/elide-values.scm
b/module/language/cps/elide-values.scm
index b738b1c..0168ab8 100644
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -37,15 +37,15 @@
(define (elide-values fun)
(let ((conts (build-local-cont-table
- (match fun (($ $fun meta free body) body)))))
+ (match fun (($ $fun src meta free body) body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body))))
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont)
,cont)))
(define (visit-term term)
@@ -56,27 +56,27 @@
(($ $letrec names syms funs body)
($letrec names syms (map elide-values funs)
,(visit-term body)))
- (($ $continue k ($ $primcall 'values vals))
+ (($ $continue k src ($ $primcall 'values vals))
,(rewrite-cps-term (lookup-cont k conts)
(($ $ktail)
- ($continue k ($values vals)))
+ ($continue k src ($values vals)))
(($ $ktrunc ($ $arity req () rest () #f) kargs)
,(if (or rest (< (length vals) (length req)))
term
(let ((vals (list-head vals (length req))))
(build-cps-term
- ($continue kargs ($values vals))))))
+ ($continue kargs src ($values vals))))))
(($ $kargs args)
,(if (< (length vals) (length args))
term
(let ((vals (list-head vals (length args))))
(build-cps-term
- ($continue k ($values vals))))))))
- (($ $continue k (and fun ($ $fun)))
- ($continue k ,(elide-values fun)))
+ ($continue k src ($values vals))))))))
+ (($ $continue k src (and fun ($ $fun)))
+ ($continue k src ,(elide-values fun)))
(($ $continue)
,term)))
(rewrite-cps-exp fun
- (($ $fun meta free body)
- ($fun meta free ,(visit-cont body))))))
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body))))))
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index c258553..323f623 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -38,9 +38,28 @@
(* . mul) (/ . div)
(quotient . quo) (remainder . rem)
(modulo . mod)
- (define! . define)
(variable-ref . box-ref)
- (variable-set! . box-set!)))
+ (variable-set! . box-set!)
+ (bytevector-u8-native-ref . bv-u8-ref)
+ (bytevector-u16-native-ref . bv-u16-ref)
+ (bytevector-u32-native-ref . bv-u32-ref)
+ (bytevector-u64-native-ref . bv-u64-ref)
+ (bytevector-s8-native-ref . bv-s8-ref)
+ (bytevector-s16-native-ref . bv-s16-ref)
+ (bytevector-s32-native-ref . bv-s32-ref)
+ (bytevector-s64-native-ref . bv-s64-ref)
+ (bytevector-f32-native-ref . bv-f32-ref)
+ (bytevector-f64-native-ref . bv-f64-ref)
+ (bytevector-u8-native-set! . bv-u8-set!)
+ (bytevector-u16-native-set! . bv-u16-set!)
+ (bytevector-u32-native-set! . bv-u32-set!)
+ (bytevector-u64-native-set! . bv-u64-set!)
+ (bytevector-s8-native-set! . bv-s8-set!)
+ (bytevector-s16-native-set! . bv-s16-set!)
+ (bytevector-s32-native-set! . bv-s32-set!)
+ (bytevector-s64-native-set! . bv-s64-set!)
+ (bytevector-f32-native-set! . bv-f32-set!)
+ (bytevector-f64-native-set! . bv-f64-set!)))
(define *macro-instruction-arities*
'((cache-current-module! . (0 . 2))
@@ -56,6 +75,8 @@
(vector? . (1 . 1))
(symbol? . (1 . 1))
(variable? . (1 . 1))
+ (bitvector? . (1 . 1))
+ (bytevector? . (1 . 1))
(char? . (1 . 1))
(eq? . (1 . 2))
(eqv? . (1 . 2))
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index 34700b1..68de294 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -39,71 +39,109 @@
('name name-sym name)
('public? public?-sym public?)
('bound? bound?-sym bound?))
- ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
- ($continue kbox
+ ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
+ ($continue kbox src
($primcall 'cached-module-box
(module-sym name-sym public?-sym bound?-sym))))))))
-(define (primitive-ref name k)
- (module-box #f '(guile) name #f #t
+(define (primitive-module name)
+ (case name
+ ((bytevector-u8-ref bytevector-u8-set!
+ bytevector-s8-ref bytevector-s8-set!
+
+ bytevector-u16-ref bytevector-u16-set!
+ bytevector-u16-native-ref bytevector-u16-native-set!
+ bytevector-s16-ref bytevector-s16-set!
+ bytevector-s16-native-ref bytevector-s16-native-set!
+
+ bytevector-u32-ref bytevector-u32-set!
+ bytevector-u32-native-ref bytevector-u32-native-set!
+ bytevector-s32-ref bytevector-s32-set!
+ bytevector-s32-native-ref bytevector-s32-native-set!
+
+ bytevector-u64-ref bytevector-u64-set!
+ bytevector-u64-native-ref bytevector-u64-native-set!
+ bytevector-s64-ref bytevector-s64-set!
+ bytevector-s64-native-ref bytevector-s64-native-set!
+
+ bytevector-ieee-single-ref bytevector-ieee-single-set!
+ bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
+ bytevector-ieee-double-ref bytevector-ieee-double-set!
+ bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)
+ '(rnrs bytevectors))
+ ((class-of @slot-ref @slot-set!) '(oop goops))
+ (else '(guile))))
+
+(define (primitive-ref name k src)
+ (module-box #f (primitive-module name) name #f #t
(lambda (box)
(build-cps-term
- ($continue k ($primcall 'box-ref (box)))))))
+ ($continue k src ($primcall 'box-ref (box)))))))
+
+(define (builtin-ref idx k src)
+ (let-gensyms (idx-sym)
+ (build-cps-term
+ ($letconst (('idx idx-sym idx))
+ ($continue k src
+ ($primcall 'builtin-ref (idx-sym)))))))
(define (reify-clause ktail)
(let-gensyms (kclause kbody wna false str eol kthrow throw)
(build-cps-cont
- (kclause #f ($kclause ('() '() #f '() #f)
- (kbody
- #f
- ($kargs () ()
- ($letconst (('wna wna 'wrong-number-of-args)
- ('false false #f)
- ('str str "Wrong number of arguments")
- ('eol eol '()))
- ($letk ((kthrow
- #f
- ($kargs ('throw) (throw)
- ($continue ktail
- ($call throw
- (wna false str eol false))))))
- ,(primitive-ref 'throw kthrow))))))))))
+ (kclause ($kclause ('() '() #f '() #f)
+ (kbody
+ ($kargs () ()
+ ($letconst (('wna wna 'wrong-number-of-args)
+ ('false false #f)
+ ('str str "Wrong number of arguments")
+ ('eol eol '()))
+ ($letk ((kthrow
+ ($kargs ('throw) (throw)
+ ($continue ktail #f
+ ($call throw
+ (wna false str eol false))))))
+ ,(primitive-ref 'throw kthrow #f))))))))))
;; FIXME: Operate on one function at a time, for efficiency.
(define (reify-primitives fun)
(let ((conts (build-cont-table fun)))
(define (visit-fun term)
(rewrite-cps-exp term
- (($ $fun meta free body)
- ($fun meta free ,(visit-cont body)))))
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body))))
- (($ $cont sym src ($ $kentry self (and tail ($ $cont ktail)) ()))
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kentry self (and tail ($ $cont ktail)) ()))
;; A case-lambda with no clauses. Reify a clause.
- (sym src ($kentry self ,tail (,(reify-clause ktail)))))
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (sym ($kentry self ,tail (,(reify-clause ktail)))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont)
,cont)))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
- (($ $continue k exp)
+ (($ $continue k src exp)
,(match exp
(($ $prim name)
(match (lookup-cont k conts)
- (($ $kargs (_)) (primitive-ref name k))
- (_ (build-cps-term ($continue k ($void))))))
+ (($ $kargs (_))
+ (cond
+ ((builtin-name->index name)
+ => (lambda (idx)
+ (builtin-ref idx k src)))
+ (else (primitive-ref name k src))))
+ (_ (build-cps-term ($continue k src ($void))))))
(($ $fun)
- (build-cps-term ($continue k ,(visit-fun exp))))
+ (build-cps-term ($continue k src ,(visit-fun exp))))
(($ $primcall 'call-thunk/no-inline (proc))
(build-cps-term
- ($continue k ($call proc ()))))
+ ($continue k src ($call proc ()))))
(($ $primcall name args)
(cond
((or (prim-rtl-instruction name) (branching-primitive? name))
@@ -112,9 +150,13 @@
(else
(let-gensyms (k* v)
(build-cps-term
- ($letk ((k* #f ($kargs (v) (v)
- ($continue k ($call v args)))))
- ,(primitive-ref name k*)))))))
+ ($letk ((k* ($kargs (v) (v)
+ ($continue k src ($call v args)))))
+ ,(cond
+ ((builtin-name->index name)
+ => (lambda (idx)
+ (builtin-ref idx k* src)))
+ (else (primitive-ref name k* src)))))))))
(_ term)))))
(visit-fun fun)))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 07f6e27..580d0f9 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -198,7 +198,7 @@ are comparable with eqv?. A tmp slot may be used."
(let ((l (dfa-k-idx dfa use-k)))
(not (bitvector-ref (dfa-k-out dfa l) v-idx))))
-(define (allocate-slots fun)
+(define (allocate-slots fun dfg)
(define (empty-live-slots)
#b0)
@@ -231,11 +231,11 @@ are comparable with eqv?. A tmp slot may be used."
live-slots)))
live-slots)))))
- (define (visit-clause clause dfg dfa allocation slots live-slots)
+ (define (visit-clause clause dfa allocation slots live-slots)
(define nlocals (compute-slot live-slots #f))
(define nargs
(match clause
- (($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms))))
+ (($ $cont _ ($ $kclause _ ($ $cont _ ($ $kargs names syms))))
(length syms))))
(define (allocate! sym k hint live-slots)
@@ -310,7 +310,7 @@ are comparable with eqv?. A tmp slot may be used."
live-slots))
(match cont
- (($ $kclause arity ($ $cont k src body))
+ (($ $kclause arity ($ $cont k body))
(visit-cont body k live-slots))
(($ $kargs names syms body)
@@ -328,12 +328,12 @@ are comparable with eqv?. A tmp slot may be used."
(($ $letk conts body)
(let ((live-slots (visit-term body label live-slots)))
(for-each (match-lambda
- (($ $cont k src cont)
+ (($ $cont k cont)
(visit-cont cont k live-slots)))
conts))
live-slots)
- (($ $continue k exp)
+ (($ $continue k src exp)
(visit-exp exp label k live-slots))))
(define (visit-exp exp label k live-slots)
@@ -402,7 +402,7 @@ are comparable with eqv?. A tmp slot may be used."
live-slots live-slots*
(compute-dst-slots))))
- (($ $prompt escape? tag handler)
+ (($ $prompt escape? tag handler pop)
(match (lookup-cont handler (dfg-cont-table dfg))
(($ $ktrunc arity kargs)
(let* ((live-slots (allocate-prompt-handler! label live-slots))
@@ -420,21 +420,18 @@ are comparable with eqv?. A tmp slot may be used."
(_ live-slots)))
(match clause
- (($ $cont k _ body)
+ (($ $cont k body)
(visit-cont body k live-slots)
(hashq-set! allocation k nlocals))))
(match fun
- (($ $fun meta free ($ $cont k _ ($ $kentry self
- ($ $cont ktail _ ($ $ktail))
- clauses)))
- (let* ((dfg (compute-dfg fun #:global? #f))
- (dfa (compute-live-variables ktail dfg))
+ (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
+ (let* ((dfa (compute-live-variables fun dfg))
(allocation (make-hash-table))
(slots (make-vector (dfa-var-count dfa) #f))
(live-slots (add-live-slot 0 (empty-live-slots))))
(vector-set! slots (dfa-var-idx dfa self) 0)
(hashq-set! allocation self (make-allocation 0 #f #f))
- (for-each (cut visit-clause <> dfg dfa allocation slots live-slots)
+ (for-each (cut visit-clause <> dfa allocation slots live-slots)
clauses)
allocation))))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index bb2e857..3772f21 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -71,7 +71,7 @@
(define (visit-clause clause k-env v-env)
(match clause
- (($ $cont kclause src*
+ (($ $cont kclause
($ $kclause
($ $arity
((? symbol? req) ...)
@@ -79,9 +79,7 @@
(and rest (or #f (? symbol?)))
(((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...)
(or #f #t))
- ($ $cont kbody src (and body ($ $kargs names syms _)))))
- (check-src src*)
- (check-src src)
+ ($ $cont kbody (and body ($ $kargs names syms _)))))
(for-each (lambda (sym)
(unless (memq sym syms)
(error "bad keyword sym" sym)))
@@ -98,9 +96,9 @@
(define (visit-fun fun k-env v-env)
(match fun
- (($ $fun meta ((? symbol? free) ...)
- ($ $cont kbody src
- ($ $kentry (? symbol? self) ($ $cont ktail _ ($ $ktail))
clauses)))
+ (($ $fun src meta ((? symbol? free) ...)
+ ($ $cont kbody
+ ($ $kentry (? symbol? self) ($ $cont ktail ($ $ktail)) clauses)))
(when (and meta (not (and (list? meta) (and-map pair? meta))))
(error "meta should be alist" meta))
(for-each (cut check-var <> v-env) free)
@@ -132,18 +130,18 @@
(for-each (cut check-var <> v-env) arg))
(($ $values ((? symbol? arg) ...))
(for-each (cut check-var <> v-env) arg))
- (($ $prompt escape? tag handler)
+ (($ $prompt escape? tag handler pop)
(unless (boolean? escape?) (error "escape? should be boolean" escape?))
(check-var tag v-env)
- (check-var handler k-env))
+ (check-var handler k-env)
+ (check-var pop k-env))
(_
(error "unexpected expression" exp))))
(define (visit-term term k-env v-env)
(match term
- (($ $letk (($ $cont (? symbol? k) src cont) ...) body)
+ (($ $letk (($ $cont (? symbol? k) cont) ...) body)
(let ((k-env (add-env k k-env)))
- (for-each check-src src)
(for-each (cut visit-cont-body <> k-env v-env) cont)
(visit-term body k-env v-env)))
@@ -154,8 +152,9 @@
(for-each (cut visit-fun <> k-env v-env) fun)
(visit-term body k-env v-env)))
- (($ $continue k exp)
+ (($ $continue k src exp)
(check-var k k-env)
+ (check-src src)
(visit-expression exp k-env v-env))
(_
diff --git a/module/language/elisp/lexer.scm b/module/language/elisp/lexer.scm
index 1933ff3..5a0e6b3 100644
--- a/module/language/elisp/lexer.scm
+++ b/module/language/elisp/lexer.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010, 2013 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -261,20 +261,20 @@
(and=> (regexp-exec lexical-binding-regexp string)
(lambda (match)
(not (member (match:substring match 2) '("nil" "()"))))))
- (let ((return (let ((file (if (file-port? port)
- (port-filename port)
- #f))
- (line (1+ (port-line port)))
- (column (1+ (port-column port))))
- (lambda (token value)
- (let ((obj (cons token value)))
- (set-source-property! obj 'filename file)
- (set-source-property! obj 'line line)
- (set-source-property! obj 'column column)
- obj))))
- ;; Read afterwards so the source-properties are correct above
- ;; and actually point to the very character to be read.
- (c (read-char port)))
+ (let* ((return (let ((file (if (file-port? port)
+ (port-filename port)
+ #f))
+ (line (1+ (port-line port)))
+ (column (1+ (port-column port))))
+ (lambda (token value)
+ (let ((obj (cons token value)))
+ (set-source-property! obj 'filename file)
+ (set-source-property! obj 'line line)
+ (set-source-property! obj 'column column)
+ obj))))
+ ;; Read afterwards so the source-properties are correct above
+ ;; and actually point to the very character to be read.
+ (c (read-char port)))
(cond
;; End of input must be specially marked to the parser.
((eof-object? c) (return 'eof c))
diff --git a/module/language/rtl.scm b/module/language/rtl.scm
index d217517..8ec9fe2 100644
--- a/module/language/rtl.scm
+++ b/module/language/rtl.scm
@@ -23,7 +23,12 @@
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (system vm instruction)
#:re-export (rtl-instruction-list)
- #:export (rtl-instruction-arity))
+ #:export (rtl-instruction-arity
+ builtin-name->index
+ builtin-index->name))
+
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_vm_builtins")
(define (compute-rtl-instruction-arity name args)
(define (first-word-arity word)
diff --git a/module/language/rtl/spec.scm b/module/language/rtl/spec.scm
index 0a8c4ee..0dabf94 100644
--- a/module/language/rtl/spec.scm
+++ b/module/language/rtl/spec.scm
@@ -20,12 +20,23 @@
(define-module (language rtl spec)
#:use-module (system base language)
+ #:use-module (system vm objcode)
#:use-module (ice-9 binary-ports)
#:export (rtl))
+(define (rtl->value x e opts)
+ (let ((thunk (load-thunk-from-memory x)))
+ (if (eq? e (current-module))
+ ;; save a cons in this case
+ (values (thunk) e e)
+ (save-module-excursion
+ (lambda ()
+ (set-current-module e)
+ (values (thunk) e e))))))
+
(define-language rtl
#:title "Register Transfer Language"
- #:compilers '()
+ #:compilers `((value . ,rtl->value))
#:printer (lambda (rtl port) (put-bytevector port rtl))
#:reader get-bytevector-all
#:for-humans? #f)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index f26b188..c705694 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -81,18 +81,18 @@
(build-cps-term
($letconst (('name name-sym name)
('bound? bound?-sym bound?))
- ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+ ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
,(match (current-topbox-scope)
(#f
(build-cps-term
- ($continue kbox
+ ($continue kbox src
($primcall 'resolve
(name-sym bound?-sym)))))
(scope
(let-gensyms (scope-sym)
(build-cps-term
($letconst (('scope scope-sym scope))
- ($continue kbox
+ ($continue kbox src
($primcall 'cached-toplevel-box
(scope-sym name-sym bound?-sym)))))))))))))
@@ -103,8 +103,8 @@
('name name-sym name)
('public? public?-sym public?)
('bound? bound?-sym bound?))
- ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
- ($continue kbox
+ ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
+ ($continue kbox src
($primcall 'cached-module-box
(module-sym name-sym public?-sym bound?-sym))))))))
@@ -112,11 +112,11 @@
(let-gensyms (module scope-sym kmodule)
(build-cps-term
($letconst (('scope scope-sym scope))
- ($letk ((kmodule src ($kargs ('module) (module)
- ($continue k
- ($primcall 'cache-current-module!
- (module scope-sym))))))
- ($continue kmodule
+ ($letk ((kmodule ($kargs ('module) (module)
+ ($continue k src
+ ($primcall 'cache-current-module!
+ (module scope-sym))))))
+ ($continue kmodule src
($primcall 'current-module ())))))))
(define (fold-formals proc seed arity gensyms inits)
@@ -162,8 +162,8 @@
(let-gensyms (unbound ktest)
(build-cps-term
($letconst (('unbound unbound (pointer->scm (make-pointer
unbound-bits))))
- ($letk ((ktest src ($kif kt kf)))
- ($continue ktest
+ ($letk ((ktest ($kif kt kf)))
+ ($continue ktest src
($primcall 'eq? (sym unbound))))))))
(define (init-default-value name sym subst init body)
@@ -174,19 +174,19 @@
(if box?
(let-gensyms (kbox phi)
(build-cps-term
- ($letk ((kbox src ($kargs (name) (phi)
- ($continue k ($primcall 'box (phi))))))
+ ($letk ((kbox ($kargs (name) (phi)
+ ($continue k src ($primcall 'box (phi))))))
,(make-body kbox))))
(make-body k)))
(let-gensyms (knext kbound kunbound)
(build-cps-term
- ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
+ ($letk ((knext ($kargs (name) (subst-sym) ,body)))
,(maybe-box
knext
(lambda (k)
(build-cps-term
- ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
- (kunbound src ($kargs () () ,(convert init k
subst))))
+ ($letk ((kbound ($kargs () () ($continue k src ($var sym))))
+ (kunbound ($kargs () () ,(convert init k subst))))
,(unbound? src sym kunbound kbound))))))))))))
;; exp k-name alist -> term
@@ -199,16 +199,15 @@
((box #t)
(let-gensyms (kunboxed unboxed)
(build-cps-term
- ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k
unboxed))))
- ($continue kunboxed ($primcall 'box-ref (box)))))))
+ ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
+ ($continue kunboxed src ($primcall 'box-ref (box)))))))
((subst #f) (k subst))
(#f (k sym))))
(else
- (let ((src (tree-il-src exp)))
- (let-gensyms (karg arg)
- (build-cps-term
- ($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
- ,(convert exp karg subst))))))))
+ (let-gensyms (karg arg)
+ (build-cps-term
+ ($letk ((karg ($kargs ('arg) (arg) ,(k arg))))
+ ,(convert exp karg subst)))))))
;; (exp ...) ((v-name ...) -> term) -> term
(define (convert-args exps k)
(match exps
@@ -224,25 +223,25 @@
((box #t)
(let-gensyms (k)
(build-cps-term
- ($letk ((k #f ($kargs (name) (box) ,body)))
- ($continue k ($primcall 'box (sym)))))))
+ ($letk ((k ($kargs (name) (box) ,body)))
+ ($continue k #f ($primcall 'box (sym)))))))
(else body)))
(match exp
(($ <lexical-ref> src name sym)
(match (assq-ref subst sym)
- ((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box)))))
- ((subst #f) (build-cps-term ($continue k ($var subst))))
- (#f (build-cps-term ($continue k ($var sym))))))
+ ((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box)))))
+ ((subst #f) (build-cps-term ($continue k src ($var subst))))
+ (#f (build-cps-term ($continue k src ($var sym))))))
(($ <void> src)
- (build-cps-term ($continue k ($void))))
+ (build-cps-term ($continue k src ($void))))
(($ <const> src exp)
- (build-cps-term ($continue k ($const exp))))
+ (build-cps-term ($continue k src ($const exp))))
(($ <primitive-ref> src name)
- (build-cps-term ($continue k ($prim name))))
+ (build-cps-term ($continue k src ($prim name))))
(($ <lambda> fun-src meta body)
(let ()
@@ -260,10 +259,8 @@
(let-gensyms (kclause kargs)
(build-cps-cont
(kclause
- src
($kclause ,arity
(kargs
- src
($kargs names gensyms
,(fold-formals
(lambda (name sym init body)
@@ -276,15 +273,13 @@
(if (current-topbox-scope)
(let-gensyms (kentry self ktail)
(build-cps-term
- ($continue k
- ($fun meta '()
- (kentry fun-src
- ($kentry self (ktail #f ($ktail))
- ,(convert-clauses body ktail)))))))
+ ($continue k fun-src
+ ($fun fun-src meta '()
+ (kentry ($kentry self (ktail ($ktail))
+ ,(convert-clauses body ktail)))))))
(let-gensyms (scope kscope)
(build-cps-term
- ($letk ((kscope fun-src
- ($kargs () ()
+ ($letk ((kscope ($kargs () ()
,(parameterize ((current-topbox-scope scope))
(convert exp k subst)))))
,(capture-toplevel-scope fun-src scope kscope)))))))
@@ -293,7 +288,7 @@
(module-box
src mod name public? #t
(lambda (box)
- (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
+ (build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
(($ <module-set> src mod name public? exp)
(convert-arg exp
@@ -301,13 +296,14 @@
(module-box
src mod name public? #f
(lambda (box)
- (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
+ (build-cps-term
+ ($continue k src ($primcall 'box-set! (box val)))))))))
(($ <toplevel-ref> src name)
(toplevel-box
src name #t
(lambda (box)
- (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
+ (build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
(($ <toplevel-set> src name exp)
(convert-arg exp
@@ -315,7 +311,8 @@
(toplevel-box
src name #f
(lambda (box)
- (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
+ (build-cps-term
+ ($continue k src ($primcall 'box-set! (box val)))))))))
(($ <toplevel-define> src name exp)
(convert-arg exp
@@ -323,22 +320,87 @@
(let-gensyms (kname name-sym)
(build-cps-term
($letconst (('name name-sym name))
- ($continue k ($primcall 'define! (name-sym val)))))))))
+ ($continue k src ($primcall 'define! (name-sym val)))))))))
(($ <call> src proc args)
(convert-args (cons proc args)
(match-lambda
((proc . args)
- (build-cps-term ($continue k ($call proc args)))))))
+ (build-cps-term ($continue k src ($call proc args)))))))
(($ <primcall> src name args)
- (if (branching-primitive? name)
- (convert (make-conditional src exp (make-const #f #t)
- (make-const #f #f))
- k subst)
- (convert-args args
- (lambda (args)
- (build-cps-term ($continue k ($primcall name args)))))))
+ (cond
+ ((branching-primitive? name)
+ (convert (make-conditional src exp (make-const #f #t)
+ (make-const #f #f))
+ k subst))
+ ((and (eq? name 'vector)
+ (and-map (match-lambda
+ ((or ($ <const>)
+ ($ <void>)
+ ($ <lambda>)
+ ($ <lexical-ref>)) #t)
+ (_ #f))
+ args))
+ ;; Some macros generate calls to "vector" with like 300
+ ;; arguments. Since we eventually compile to make-vector and
+ ;; vector-set!, it reduces live variable pressure to allocate the
+ ;; vector first, then set values as they are produced, if we can
+ ;; prove that no value can capture the continuation. (More on
+ ;; that caveat here:
+ ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
+ ;;
+ ;; Normally we would do this transformation in the compiler, but
+ ;; it's quite tricky there and quite easy here, so hold your nose
+ ;; while we drop some smelly code.
+ (convert (let ((len (length args)))
+ (let-gensyms (v)
+ (make-let src
+ (list 'v)
+ (list v)
+ (list (make-primcall src 'make-vector
+ (list (make-const #f len)
+ (make-const #f #f))))
+ (fold (lambda (arg n tail)
+ (make-seq
+ src
+ (make-primcall
+ src 'vector-set!
+ (list (make-lexical-ref src 'v v)
+ (make-const #f n)
+ arg))
+ tail))
+ (make-lexical-ref src 'v v)
+ (reverse args) (reverse (iota len))))))
+ k subst))
+ ((and (eq? name 'list)
+ (and-map (match-lambda
+ ((or ($ <const>)
+ ($ <void>)
+ ($ <lambda>)
+ ($ <lexical-ref>)) #t)
+ (_ #f))
+ args))
+ ;; The same situation occurs with "list".
+ (let lp ((args args) (k k))
+ (match args
+ (()
+ (build-cps-term
+ ($continue k src ($const '()))))
+ ((arg . args)
+ (let-gensyms (ktail tail)
+ (build-cps-term
+ ($letk ((ktail ($kargs ('tail) (tail)
+ ,(convert-arg arg
+ (lambda (head)
+ (build-cps-term
+ ($continue k src
+ ($primcall 'cons (head tail)))))))))
+ ,(lp args ktail))))))))
+ (else
+ (convert-args args
+ (lambda (args)
+ (build-cps-term ($continue k src ($primcall name args))))))))
;; Prompts with inline handlers.
(($ <prompt> src escape-only? tag body
@@ -361,43 +423,39 @@
(let ((hnames (append hreq (if hrest (list hrest) '()))))
(let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
(build-cps-term
- ($letk* ((khbody hsrc ($kargs hnames hsyms
- ,(fold box-bound-var
- (convert hbody k subst)
- hnames hsyms)))
- (khargs hsrc ($ktrunc hreq hrest khbody))
- (kpop src
- ($kargs ('rest) (vals)
+ ;; FIXME: Attach hsrc to $ktrunc.
+ ($letk* ((khbody ($kargs hnames hsyms
+ ,(fold box-bound-var
+ (convert hbody k subst)
+ hnames hsyms)))
+ (khargs ($ktrunc hreq hrest khbody))
+ (kpop ($kargs ('rest) (vals)
($letk ((kret
- src
($kargs () ()
($letk ((kprim
- src
($kargs ('prim) (prim)
- ($continue k
+ ($continue k src
($primcall 'apply
(prim
vals))))))
- ($continue kprim
+ ($continue kprim src
($prim 'values))))))
- ($continue kret
+ ($continue kret src
($primcall 'unwind ())))))
- (krest src ($ktrunc '() 'rest kpop)))
+ (krest ($ktrunc '() 'rest kpop)))
,(if escape-only?
(build-cps-term
- ($letk ((kbody (tree-il-src body)
- ($kargs () ()
+ ($letk ((kbody ($kargs () ()
,(convert body krest subst))))
- ($continue kbody ($prompt #t tag khargs))))
+ ($continue kbody src ($prompt #t tag khargs kpop))))
(convert-arg body
(lambda (thunk)
(build-cps-term
- ($letk ((kbody (tree-il-src body)
- ($kargs () ()
- ($continue krest
+ ($letk ((kbody ($kargs () ()
+ ($continue krest (tree-il-src
body)
($primcall 'call-thunk/no-inline
(thunk))))))
- ($continue kbody
- ($prompt #f tag khargs))))))))))))))
+ ($continue kbody (tree-il-src body)
+ ($prompt #f tag khargs kpop))))))))))))))
;; Eta-convert prompts without inline handlers.
(($ <prompt> src escape-only? tag body handler)
@@ -433,27 +491,38 @@
k
subst)))
+ (($ <abort> src tag args ($ <const> _ ()))
+ (convert-args (cons tag args)
+ (lambda (args*)
+ (build-cps-term
+ ($continue k src
+ ($primcall 'abort-to-prompt args*))))))
+
(($ <abort> src tag args tail)
- (convert-args (append (list tag) args (list tail))
+ (convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
+ tag)
+ args
+ (list tail))
(lambda (args*)
- (build-cps-term ($continue k ($primcall 'abort args*))))))
+ (build-cps-term
+ ($continue k src ($primcall 'apply args*))))))
(($ <conditional> src test consequent alternate)
(let-gensyms (kif kt kf)
(build-cps-term
- ($letk* ((kt (tree-il-src consequent) ($kargs () ()
- ,(convert consequent k
subst)))
- (kf (tree-il-src alternate) ($kargs () ()
- ,(convert alternate k subst)))
- (kif src ($kif kt kf)))
+ ($letk* ((kt ($kargs () () ,(convert consequent k subst)))
+ (kf ($kargs () () ,(convert alternate k subst)))
+ (kif ($kif kt kf)))
,(match test
(($ <primcall> src (? branching-primitive? name) args)
(convert-args args
(lambda (args)
- (build-cps-term ($continue kif ($primcall name args))))))
+ (build-cps-term
+ ($continue kif src ($primcall name args))))))
(_ (convert-arg test
(lambda (test)
- (build-cps-term ($continue kif ($var test)))))))))))
+ (build-cps-term
+ ($continue kif src ($var test)))))))))))
(($ <lexical-set> src name gensym exp)
(convert-arg exp
@@ -461,14 +530,14 @@
(match (assq-ref subst gensym)
((box #t)
(build-cps-term
- ($continue k ($primcall 'box-set! (box exp)))))))))
+ ($continue k src ($primcall 'box-set! (box exp)))))))))
(($ <seq> src head tail)
(let-gensyms (ktrunc kseq)
(build-cps-term
- ($letk* ((kseq (tree-il-src tail) ($kargs () ()
- ,(convert tail k subst)))
- (ktrunc src ($ktrunc '() #f kseq)))
+ ($letk* ((kseq ($kargs () ()
+ ,(convert tail k subst)))
+ (ktrunc ($ktrunc '() #f kseq)))
,(convert head ktrunc subst)))))
(($ <let> src names syms vals body)
@@ -478,9 +547,9 @@
(((name . names) (sym . syms) (val . vals))
(let-gensyms (klet)
(build-cps-term
- ($letk ((klet src ($kargs (name) (sym)
- ,(box-bound-var name sym
- (lp names syms vals)))))
+ ($letk ((klet ($kargs (name) (sym)
+ ,(box-bound-var name sym
+ (lp names syms vals)))))
,(convert val klet subst))))))))
(($ <fix> src names gensyms funs body)
@@ -492,15 +561,15 @@
gensyms
(map (lambda (fun)
(match (convert fun k subst)
- (($ $continue _ (and fun ($ $fun)))
+ (($ $continue _ _ (and fun ($ $fun)))
fun)))
funs)
,(convert body k subst))))
(let-gensyms (scope kscope)
(build-cps-term
- ($letk ((kscope src ($kargs () ()
- ,(parameterize ((current-topbox-scope
scope))
- (convert exp k subst)))))
+ ($letk ((kscope ($kargs () ()
+ ,(parameterize ((current-topbox-scope scope))
+ (convert exp k subst)))))
,(capture-toplevel-scope src scope kscope))))))
(($ <let-values> src exp
@@ -508,11 +577,11 @@
(let ((names (append req (if rest (list rest) '()))))
(let-gensyms (ktrunc kargs)
(build-cps-term
- ($letk* ((kargs src ($kargs names syms
- ,(fold box-bound-var
- (convert body k subst)
- names syms)))
- (ktrunc src ($ktrunc req rest kargs)))
+ ($letk* ((kargs ($kargs names syms
+ ,(fold box-bound-var
+ (convert body k subst)
+ names syms)))
+ (ktrunc ($ktrunc req rest kargs)))
,(convert exp ktrunc subst))))))))
(define (build-subst exp)
@@ -552,16 +621,14 @@ indicates that the replacement variable is in a box."
(let ((src (tree-il-src exp)))
(let-gensyms (kinit init ktail kclause kbody)
(build-cps-exp
- ($fun '() '()
- (kinit src
- ($kentry init
- (ktail #f ($ktail))
- ((kclause src
- ($kclause ('() '() #f '() #f)
- (kbody src
- ($kargs () ()
- ,(convert exp ktail
- (build-subst exp))))))))))))))
+ ($fun src '() '()
+ (kinit ($kentry init
+ (ktail ($ktail))
+ ((kclause
+ ($kclause ('() '() #f '() #f)
+ (kbody ($kargs () ()
+ ,(convert exp ktail
+ (build-subst exp))))))))))))))
(define *comp-module* (make-fluid))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index b56e54c..5e4f388 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -73,11 +73,13 @@
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ length
+
make-vector vector-length vector-ref vector-set!
variable? variable-ref variable-set!
variable-bound?
- current-module
+ current-module define!
fluid-ref fluid-set! with-fluid*
@@ -165,7 +167,7 @@
char<? char<=? char>=? char>?
integer->char char->integer number->string string->number
struct-vtable
- string-length vector-length
+ length string-length vector-length
;; These all should get expanded out by expand-primitives.
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index a574eb2..a1018cb 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -44,7 +44,7 @@
#:printer write-tree-il
#:parser parse-tree-il
#:joiner join
- #:compilers `((glil . ,compile-glil)
- (cps . ,compile-cps))
+ #:compilers `((cps . ,compile-cps)
+ (glil . ,compile-glil))
#:for-humans? #f
)
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index 20db944..db58a33 100644
--- a/module/scripts/compile.scm
+++ b/module/scripts/compile.scm
@@ -1,6 +1,6 @@
;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*-
-;; Copyright 2005,2008,2009,2010,2011 Free Software Foundation, Inc.
+;; Copyright 2005,2008,2009,2010,2011,2013 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -139,7 +139,7 @@ There is NO WARRANTY, to the extent permitted by law.~%"))
(cons #:O o)
o)))
(from (or (assoc-ref options 'from) 'scheme))
- (to (or (assoc-ref options 'to) 'objcode))
+ (to (or (assoc-ref options 'to) 'rtl))
(target (or (assoc-ref options 'target) %host-type))
(input-files (assoc-ref options 'input-files))
(output-file (assoc-ref options 'output-file))
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 82d75c7..b932e64 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -133,7 +133,7 @@
(define* (compile-file file #:key
(output-file #f)
(from (current-language))
- (to 'objcode)
+ (to 'rtl)
(env (default-environment from))
(opts '())
(canonicalization 'relative))
@@ -207,7 +207,7 @@
(define* (read-and-compile port #:key
(from (current-language))
- (to 'objcode)
+ (to 'rtl)
(env (default-environment from))
(opts '()))
(let ((from (ensure-language from))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index e084cf1..1e6aaff 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -25,6 +25,7 @@
#:use-module (system base compile)
#:use-module (system repl common)
#:use-module (system repl debug)
+ #:use-module (system vm disassembler)
#:use-module (system vm objcode)
#:use-module (system vm program)
#:use-module (system vm trap-state)
@@ -39,6 +40,7 @@
#:use-module (ice-9 control)
#:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
#:use-module ((system vm inspect) #:select ((inspect . %inspect)))
+ #:use-module (rnrs bytevectors)
#:use-module (statprof)
#:export (meta-command define-meta-command))
@@ -455,11 +457,16 @@ Change languages."
;;; Compile commands
;;;
+(define (load-image x)
+ (let ((thunk (load-thunk-from-memory x)))
+ (find-mapped-elf-image (rtl-program-code thunk))))
+
(define-meta-command (compile repl (form))
"compile EXP
Generate compiled code."
(let ((x (repl-compile repl (repl-parse repl form))))
- (cond ((objcode? x) (guile:disassemble x))
+ (cond ((bytevector? x) (disassemble-image (load-image x)))
+ ((objcode? x) (guile:disassemble x))
(else (repl-print repl x)))))
(define-meta-command (compile-file repl file . opts)
@@ -484,12 +491,6 @@ Run the optimizer on a piece of code and print the result."
(define (guile:disassemble x)
((@ (language assembly disassemble) disassemble) x))
-(define (disassemble-program x)
- ((@ (system vm disassembler) disassemble-program) x))
-
-(define (disassemble-file x)
- ((@ (system vm disassembler) disassemble-file) x))
-
(define-meta-command (disassemble repl (form))
"disassemble EXP
Disassemble a compiled procedure."
@@ -497,6 +498,8 @@ Disassemble a compiled procedure."
(cond
((rtl-program? obj)
(disassemble-program obj))
+ ((bytevector? obj)
+ (disassemble-image (load-image obj)))
((or (program? obj) (objcode? obj))
(guile:disassemble obj))
(else
@@ -566,8 +569,6 @@ Trace execution."
(identifier-syntax (debug-frames debug)))
(#,(datum->syntax #'repl 'message)
(identifier-syntax (debug-error-message debug)))
- (#,(datum->syntax #'repl 'for-trap?)
- (identifier-syntax (debug-for-trap? debug)))
(#,(datum->syntax #'repl 'index)
(identifier-syntax
(id (debug-index debug))
@@ -589,8 +590,7 @@ If COUNT is negative, the last COUNT frames will be shown."
(print-frames frames
#:count count
#:width width
- #:full? full?
- #:for-trap? for-trap?))
+ #:full? full?))
(define-stack-command (up repl #:optional (count 1))
"up [COUNT]
@@ -607,12 +607,10 @@ An argument says how many frames up to go."
(format #t "Already at outermost frame.\n"))
(else
(set! index (1- (vector-length frames)))
- (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))))
+ (print-frame cur #:index index))))
(else
(set! index (+ count index))
- (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))))
+ (print-frame cur #:index index))))
(define-stack-command (down repl #:optional (count 1))
"down [COUNT]
@@ -629,11 +627,10 @@ An argument says how many frames down to go."
(format #t "Already at innermost frame.\n"))
(else
(set! index 0)
- (print-frame cur #:index index #:next-source? for-trap?))))
+ (print-frame cur #:index index))))
(else
(set! index (- index count))
- (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))))
+ (print-frame cur #:index index))))
(define-stack-command (frame repl #:optional idx)
"frame [IDX]
@@ -648,12 +645,10 @@ With an argument, select a frame by index, then show it."
(format #t "Invalid argument to `frame': expected a non-negative integer
for IDX.~%"))
((< idx (vector-length frames))
(set! index idx)
- (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))
+ (print-frame cur #:index index))
(else
(format #t "No such frame.~%"))))
- (else (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))))
+ (else (print-frame cur #:index index))))
(define-stack-command (procedure repl)
"procedure
@@ -719,7 +714,7 @@ Note that the given source location must be inside a
procedure."
(format #t "Return values:~%")
(for-each (lambda (x) (repl-print repl x)) values)))
((module-ref (resolve-interface '(system repl repl)) 'start-repl)
- #:debug (make-debug stack 0 msg #t))))))
+ #:debug (make-debug stack 0 msg))))))
(define-stack-command (finish repl)
"finish
@@ -743,7 +738,7 @@ Resume execution, breaking when the current frame finishes."
(k (frame->stack-vector frame)))))))
(format #t "~a~%" msg)
((module-ref (resolve-interface '(system repl repl)) 'start-repl)
- #:debug (make-debug stack 0 msg #t)))))
+ #:debug (make-debug stack 0 msg)))))
(define-stack-command (step repl)
"step
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 94b41ea..1da3669 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -25,6 +25,7 @@
#:use-module (system base language)
#:use-module (system base message)
#:use-module (system vm program)
+ #:use-module (system vm objcode)
#:autoload (language tree-il optimize) (optimize)
#:use-module (ice-9 control)
#:use-module (ice-9 history)
@@ -176,7 +177,7 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more
details.")
(define (repl-compile repl form)
(let ((from (repl-language repl))
(opts (repl-compile-options repl)))
- (compile form #:from from #:to 'objcode #:opts opts
+ (compile form #:from from #:to 'rtl #:opts opts
#:env (current-module))))
(define (repl-expand repl form)
@@ -205,7 +206,7 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more
details.")
(or (null? (language-compilers (repl-language repl)))
(repl-option-ref repl 'interp)))
(lambda () (eval form (current-module)))
- (make-program (repl-compile repl form)))))
+ (load-thunk-from-memory (repl-compile repl form)))))
(define (repl-eval repl form)
(let ((thunk (repl-prepare-eval-thunk repl form)))
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index cf40806..251cd89 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -1,6 +1,6 @@
;;; Guile VM debugging facilities
-;;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -31,7 +31,7 @@
#:use-module (system vm program)
#:export (<debug>
make-debug debug?
- debug-frames debug-index debug-error-message debug-for-trap?
+ debug-frames debug-index debug-error-message
terminal-width
print-registers print-locals print-frame print-frames frame->module
stack->vector narrow-stack->vector
@@ -55,7 +55,7 @@
;;; accessors, and provides some helper functions.
;;;
-(define-record <debug> frames index error-message for-trap?)
+(define-record <debug> frames index error-message)
@@ -94,7 +94,12 @@
(format port fmt val))
(format port "~aRegisters:~%" per-line-prefix)
- (print "ip = ~d\n" (frame-instruction-pointer frame))
+ (print "ip = #x~x" (frame-instruction-pointer frame))
+ (when (rtl-program? (frame-procedure frame))
+ (let ((code (rtl-program-code (frame-procedure frame))))
+ (format port " (address@hidden)" code
+ (- (frame-instruction-pointer frame) code))))
+ (newline port)
(print "sp = #x~x\n" (frame-stack-pointer frame))
(print "fp = #x~x\n" (frame-address frame)))
@@ -125,7 +130,7 @@
(if source
(or (source:file source) "current input")
"unknown file"))
- (let* ((source ((if next-source? frame-next-source frame-source) frame))
+ (let* ((source (frame-source frame))
(file (source:pretty-file source))
(line (and=> source source:line-for-user))
(col (and=> source source:column)))
@@ -141,7 +146,7 @@
(define* (print-frames frames
#:optional (port (current-output-port))
#:key (width (terminal-width)) (full? #f)
- (forward? #f) count for-trap?)
+ (forward? #f) count)
(let* ((len (vector-length frames))
(lower-idx (if (or (not count) (positive? count))
0
@@ -155,12 +160,9 @@
(if (<= lower-idx i upper-idx)
(let* ((frame (vector-ref frames i)))
(print-frame frame port #:index i #:width width #:full? full?
- #:last-source last-source
- #:next-source? (and (zero? i) for-trap?))
+ #:last-source last-source)
(lp (+ i inc)
- (if (and (zero? i) for-trap?)
- (frame-next-source frame)
- (frame-source frame))))))))
+ (frame-source frame)))))))
;; Ideally here we would have something much more syntactic, in that a set! to
a
;; local var that is not settable would raise an error, and export etc forms
diff --git a/module/system/repl/error-handling.scm
b/module/system/repl/error-handling.scm
index 0e31eb9..d0d7967 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -1,6 +1,6 @@
;;; Error handling in the REPL
-;; Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -72,7 +72,7 @@
(error-msg (if trap-idx
(format #f "Trap ~d: ~a" trap-idx trap-name)
trap-name))
- (debug (make-debug stack 0 error-msg #t)))
+ (debug (make-debug stack 0 error-msg)))
(with-saved-ports
(lambda ()
(if trap-idx
@@ -138,7 +138,7 @@
;; the start-stack thunk has its own frame too.
0 (and tag 1)))
(error-msg (error-string stack key args))
- (debug (make-debug stack 0 error-msg #f)))
+ (debug (make-debug stack 0 error-msg)))
(with-saved-ports
(lambda ()
(format #t "~a~%" error-msg)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 749b693..58c00ef 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -68,10 +68,14 @@
;;; RTL code consists of 32-bit units, often subdivided in some way.
;;; These helpers create one 32-bit unit from multiple components.
-(define-syntax-rule (pack-u8-u24 x y)
+(define-inlinable (pack-u8-u24 x y)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
(logior x (ash y 8)))
-(define-syntax-rule (pack-u8-s24 x y)
+(define-inlinable (pack-u8-s24 x y)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
(logior x (ash (cond
((< 0 (- y) #x800000)
(+ y #x1000000))
@@ -80,16 +84,34 @@
(else (error "out of range" y)))
8)))
-(define-syntax-rule (pack-u1-u7-u24 x y z)
+(define-inlinable (pack-u1-u7-u24 x y z)
+ (unless (<= 0 x 1)
+ (error "out of range" x))
+ (unless (<= 0 y 127)
+ (error "out of range" y))
(logior x (ash y 1) (ash z 8)))
-(define-syntax-rule (pack-u8-u12-u12 x y z)
+(define-inlinable (pack-u8-u12-u12 x y z)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (unless (<= 0 y 4095)
+ (error "out of range" y))
(logior x (ash y 8) (ash z 20)))
-(define-syntax-rule (pack-u8-u8-u16 x y z)
+(define-inlinable (pack-u8-u8-u16 x y z)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (unless (<= 0 y 255)
+ (error "out of range" y))
(logior x (ash y 8) (ash z 16)))
-(define-syntax-rule (pack-u8-u8-u8-u8 x y z w)
+(define-inlinable (pack-u8-u8-u8-u8 x y z w)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (unless (<= 0 y 255)
+ (error "out of range" y))
+ (unless (<= 0 z 255)
+ (error "out of range" z))
(logior x (ash y 8) (ash z 16) (ash w 24)))
(define-syntax pack-flags
@@ -256,7 +278,7 @@
@var{endianness}, falling back to appropriate values for the configured
target."
(make-asm (fresh-block) 0 0 '() 0
- '() '()
+ (make-hash-table) '()
word-size endianness
vlist-null '()
(make-string-table) 1
@@ -301,11 +323,6 @@ reference that needs to be fixed up by the linker."
"Reset the asm-start after writing the words for one instruction."
(set-asm-start! asm (asm-pos asm)))
-(define (emit-exported-label asm label)
- "Define a linker symbol associating @var{label} with the current
-asm-start."
- (set-asm-labels! asm (acons label (asm-start asm) (asm-labels asm))))
-
(define (record-label-reference asm label)
"Record an x8-s24 local label reference. This value will get patched
up later by the assembler."
@@ -508,17 +525,32 @@ list of lists. This procedure can be called many times
before calling
static-procedure?
(code static-procedure-code))
+(define-record-type <uniform-vector-backing-store>
+ (make-uniform-vector-backing-store bytes element-size)
+ uniform-vector-backing-store?
+ (bytes uniform-vector-backing-store-bytes)
+ (element-size uniform-vector-backing-store-element-size))
+
(define-record-type <cache-cell>
(make-cache-cell scope key)
cache-cell?
(scope cache-cell-scope)
(key cache-cell-key))
+(define (simple-vector? obj)
+ (and (vector? obj)
+ (equal? (array-shape obj) (list (list 0 (1- (vector-length obj)))))))
+
+(define (simple-uniform-vector? obj)
+ (and (array? obj)
+ (symbol? (array-type obj))
+ (equal? (array-shape obj) (list (list 0 (1- (array-length obj)))))))
+
(define (statically-allocatable? x)
"Return @code{#t} if a non-immediate constant can be allocated
statically, and @code{#f} if it would need some kind of runtime
allocation."
- (or (pair? x) (vector? x) (string? x) (stringbuf? x) (static-procedure? x)))
+ (or (pair? x) (string? x) (stringbuf? x) (static-procedure? x) (array? x)))
(define (intern-constant asm obj)
"Add an object to the constant table, and return a label that can be
@@ -529,17 +561,17 @@ table, its existing label is used directly."
(define (field dst n obj)
(let ((src (recur obj)))
(if src
- (list (if (statically-allocatable? obj)
- `(make-non-immediate 1 ,src)
- `(static-ref 1 ,src))
- `(static-set! 1 ,dst ,n))
+ (if (statically-allocatable? obj)
+ `((static-patch! ,dst ,n ,src))
+ `((static-ref 1 ,src)
+ (static-set! 1 ,dst ,n)))
'())))
(define (intern obj label)
(cond
((pair? obj)
(append (field label 0 (car obj))
(field label 1 (cdr obj))))
- ((vector? obj)
+ ((simple-vector? obj)
(let lp ((i 0) (inits '()))
(if (< i (vector-length obj))
(lp (1+ i)
@@ -548,16 +580,14 @@ table, its existing label is used directly."
(reverse inits))))
((stringbuf? obj) '())
((static-procedure? obj)
- `((make-non-immediate 1 ,label)
- (link-procedure! 1 ,(static-procedure-code obj))))
+ `((static-patch! ,label 1 ,(static-procedure-code obj))))
((cache-cell? obj) '())
((symbol? obj)
`((make-non-immediate 1 ,(recur (symbol->string obj)))
(string->symbol 1 1)
(static-set! 1 ,label 0)))
((string? obj)
- `((make-non-immediate 1 ,(recur (make-stringbuf obj)))
- (static-set! 1 ,label 1)))
+ `((static-patch! ,label 1 ,(recur (make-stringbuf obj)))))
((keyword? obj)
`((static-ref 1 ,(recur (keyword->symbol obj)))
(symbol->keyword 1 1)
@@ -566,6 +596,16 @@ table, its existing label is used directly."
`((make-non-immediate 1 ,(recur (number->string obj)))
(string->number 1 1)
(static-set! 1 ,label 0)))
+ ((uniform-vector-backing-store? obj) '())
+ ((simple-uniform-vector? obj)
+ `((static-patch! ,label 2
+ ,(recur (make-uniform-vector-backing-store
+ (uniform-array->bytevector obj)
+ (if (bitvector? obj)
+ ;; Bitvectors are addressed in
+ ;; 32-bit units.
+ 4
+ (uniform-vector-element-size obj)))))))
(else
(error "don't know how to intern" obj))))
(cond
@@ -643,7 +683,13 @@ returned instead."
(emit-br-if-tc7 asm slot invert? tc7 label)))
;; Keep in sync with tags.h. Part of Guile's ABI. Currently unused
-;; macro assemblers are commented out.
+;; macro assemblers are commented out. See also
+;; *branching-primcall-arities* in (language cps primitives), the set of
+;; macro-instructions in assembly.scm, and
+;; disassembler.scm:code-annotation.
+;;
+;; FIXME: Define all tc7 values in Scheme in one place, derived from
+;; tags.h.
(define-tc7-macro-assembler br-if-symbol 5)
(define-tc7-macro-assembler br-if-variable 7)
(define-tc7-macro-assembler br-if-vector 13)
@@ -651,7 +697,7 @@ returned instead."
(define-tc7-macro-assembler br-if-string 21)
;(define-tc7-macro-assembler br-if-heap-number 23)
;(define-tc7-macro-assembler br-if-stringbuf 39)
-;(define-tc7-macro-assembler br-if-bytevector 77)
+(define-tc7-macro-assembler br-if-bytevector 77)
;(define-tc7-macro-assembler br-if-pointer 31)
;(define-tc7-macro-assembler br-if-hashtable 29)
;(define-tc7-macro-assembler br-if-fluid 37)
@@ -665,7 +711,7 @@ returned instead."
;(define-tc7-macro-assembler br-if-weak-set 85)
;(define-tc7-macro-assembler br-if-weak-table 87)
;(define-tc7-macro-assembler br-if-array 93)
-;(define-tc7-macro-assembler br-if-bitvector 95)
+(define-tc7-macro-assembler br-if-bitvector 95)
;(define-tc7-macro-assembler br-if-port 125)
;(define-tc7-macro-assembler br-if-smob 127)
@@ -745,7 +791,10 @@ returned instead."
(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
allow-other-keys? nlocals alternate)
(if alternate
- (emit-br-if-nargs-lt asm nreq alternate)
+ (begin
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (unless rest?
+ (emit-br-if-npos-gt asm nreq (+ nreq nopt) alternate)))
(emit-assert-nargs-ge asm nreq))
(let ((ntotal (fold (lambda (kw ntotal)
(match kw
@@ -761,7 +810,7 @@ returned instead."
(emit-alloc-frame asm nlocals)))
(define-macro-assembler (label asm sym)
- (set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
+ (hashq-set! (asm-labels asm) sym (asm-start asm)))
(define-macro-assembler (source asm source)
(set-asm-sources! asm (acons (asm-start asm) source (asm-sources asm))))
@@ -856,6 +905,8 @@ should be .data or .rodata), and return the resulting
linker object.
(+ tc7-stringbuf stringbuf-shared-flag stringbuf-wide-flag))
(define tc7-ro-string (+ 21 #x200))
(define tc7-rtl-program 69)
+ (define tc7-bytevector 77)
+ (define tc7-bitvector 95)
(let ((word-size (asm-word-size asm))
(endianness (asm-endianness asm)))
@@ -874,8 +925,12 @@ should be .data or .rodata), and return the resulting
linker object.
(* 4 word-size))
((pair? x)
(* 2 word-size))
- ((vector? x)
+ ((simple-vector? x)
(* (1+ (vector-length x)) word-size))
+ ((simple-uniform-vector? x)
+ (* 4 word-size))
+ ((uniform-vector-backing-store? x)
+ (bytevector-length (uniform-vector-backing-store-bytes x)))
(else
word-size)))
@@ -950,7 +1005,7 @@ should be .data or .rodata), and return the resulting
linker object.
(write-constant-reference buf pos (car obj))
(write-constant-reference buf (+ pos word-size) (cdr obj)))
- ((vector? obj)
+ ((simple-vector? obj)
(let* ((len (vector-length obj))
(tag (logior tc7-vector (ash len 8))))
(case word-size
@@ -973,6 +1028,40 @@ should be .data or .rodata), and return the resulting
linker object.
((number? obj)
(write-immediate asm buf pos #f))
+ ((simple-uniform-vector? obj)
+ (let ((tag (if (bitvector? obj)
+ tc7-bitvector
+ (let ((type-code (uniform-vector-element-type-code
obj)))
+ (logior tc7-bytevector (ash type-code 7))))))
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tag endianness)
+ (bytevector-u32-set! buf (+ pos 4)
+ (if (bitvector? obj)
+ (bitvector-length obj)
+ (bytevector-length obj))
+ endianness) ; length
+ (bytevector-u32-set! buf (+ pos 8) 0 endianness) ; pointer
+ (write-immediate asm buf (+ pos 12) #f)) ; owner
+ ((8)
+ (bytevector-u64-set! buf pos tag endianness)
+ (bytevector-u64-set! buf (+ pos 8)
+ (if (bitvector? obj)
+ (bitvector-length obj)
+ (bytevector-length obj))
+ endianness) ; length
+ (bytevector-u64-set! buf (+ pos 16) 0 endianness) ; pointer
+ (write-immediate asm buf (+ pos 24) #f)) ; owner
+ (else (error "bad word size")))))
+
+ ((uniform-vector-backing-store? obj)
+ (let ((bv (uniform-vector-backing-store-bytes obj)))
+ (bytevector-copy! bv 0 buf pos (bytevector-length bv))
+ (unless (or (= 1 (uniform-vector-backing-store-element-size obj))
+ (eq? endianness (native-endianness)))
+ ;; Need to swap units of element-size bytes
+ (error "FIXME: Implement byte order swap"))))
+
(else
(error "unrecognized object" obj))))
@@ -983,7 +1072,7 @@ should be .data or .rodata), and return the resulting
linker object.
(+ (byte-length k) (align len 8)))
0 data))
(buf (make-bytevector byte-len 0)))
- (let lp ((i 0) (pos 0) (labels '()))
+ (let lp ((i 0) (pos 0) (symbols '()))
(if (< i (vlist-length data))
(let* ((pair (vlist-ref data i))
(obj (car pair))
@@ -991,8 +1080,8 @@ should be .data or .rodata), and return the resulting
linker object.
(write buf pos obj)
(lp (1+ i)
(align (+ (byte-length obj) pos) 8)
- (cons (make-linker-symbol obj-label pos) labels)))
- (make-object asm name buf '() labels
+ (cons (make-linker-symbol obj-label pos) symbols)))
+ (make-object asm name buf '() symbols
#:flags (match name
('.data (logior SHF_ALLOC SHF_WRITE))
('.rodata SHF_ALLOC))))))))))
@@ -1009,11 +1098,12 @@ these may be @code{#f}."
((stringbuf? x) #t)
((pair? x)
(and (immediate? (car x)) (immediate? (cdr x))))
- ((vector? x)
+ ((simple-vector? x)
(let lp ((i 0))
(or (= i (vector-length x))
(and (immediate? (vector-ref x i))
(lp (1+ i))))))
+ ((uniform-vector-backing-store? x) #t)
(else #f)))
(let* ((constants (asm-constants asm))
(len (vlist-length constants)))
@@ -1043,7 +1133,7 @@ relocations for references to symbols defined outside the
text section."
(lambda (reloc tail)
(match reloc
((type label base word)
- (let ((abs (assq-ref labels label))
+ (let ((abs (hashq-ref labels label))
(dst (+ base word)))
(case type
((s32)
@@ -1065,11 +1155,11 @@ relocations for references to symbols defined outside
the text section."
relocs))
(define (process-labels labels)
- "Define linker symbols for the label-offset pairs in @var{labels}.
+ "Define linker symbols for the label-offset map in @var{labels}.
The offsets are expected to be expressed in words."
- (map (lambda (pair)
- (make-linker-symbol (car pair) (* (cdr pair) 4)))
- labels))
+ (hash-map->list (lambda (label loc)
+ (make-linker-symbol label (* loc 4)))
+ labels))
(define (swap-bytes! buf)
"Patch up the text buffer @var{buf}, swapping the endianness of each
@@ -1293,8 +1383,8 @@ it will be added to the GC roots at runtime."
(define (write-arity-headers metas bv endianness)
(define (write-arity-header* pos low-pc high-pc flags nreq nopt)
- (bytevector-u32-set! bv pos low-pc endianness)
- (bytevector-u32-set! bv (+ pos 4) high-pc endianness)
+ (bytevector-u32-set! bv pos (* low-pc 4) endianness)
+ (bytevector-u32-set! bv (+ pos 4) (* high-pc 4) endianness)
(bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset
(bytevector-u32-set! bv (+ pos 12) flags endianness)
(bytevector-u32-set! bv (+ pos 16) nreq endianness)
@@ -1403,9 +1493,9 @@ it will be added to the GC roots at runtime."
;;; The .guile.docstrs section is a packed, sorted array of (pc, str)
;;; values. Pc and str are both 32 bits wide. (Either could change to
;;; 64 bits if appropriate in the future.) Pc is the address of the
-;;; entry to a program, relative to the start of the text section, and
-;;; str is an index into the associated .guile.docstrs.strtab string
-;;; table section.
+;;; entry to a program, relative to the start of the text section, in
+;;; bytes, and str is an index into the associated .guile.docstrs.strtab
+;;; string table section.
;;;
;; The size of a docstrs entry, in bytes.
@@ -1421,7 +1511,7 @@ it will be added to the GC roots at runtime."
(and tail
(not (find-tail is-documentation? (cdr tail)))
(string? (cdar tail))
- (cons (meta-low-pc meta) (cdar tail)))))
+ (cons (* 4 (meta-low-pc meta)) (cdar tail)))))
(reverse (asm-meta asm))))
(let* ((endianness (asm-endianness asm))
(docstrings (find-docstrings))
@@ -1551,7 +1641,7 @@ it will be added to the GC roots at runtime."
(define (put-sleb128 port val)
(let lp ((val val))
- (if (<= 0 (+ val 64) 128)
+ (if (<= 0 (+ val 64) 127)
(put-u8 port (logand val #x7f))
(begin
(put-u8 port (logior #x80 (logand val #x7f)))
@@ -1674,15 +1764,18 @@ it will be added to the GC roots at runtime."
;; uleb128 for each of directory the file was found in, the
;; modification time, and the file's size in bytes. We pass
;; zero for the latter three fields.
- (vlist-for-each (match-lambda
- ((file . code)
- (put-bytevector line-port (string->utf8 file))
- (put-u8 line-port 0)
- (put-uleb128 line-port 0) ; directory
- (put-uleb128 line-port 0) ; mtime
- (put-uleb128 line-port 0) ; size
- ))
- files)
+ (vlist-fold-right
+ (lambda (pair seed)
+ (match pair
+ ((file . code)
+ (put-bytevector line-port (string->utf8 file))
+ (put-u8 line-port 0)
+ (put-uleb128 line-port 0) ; directory
+ (put-uleb128 line-port 0) ; mtime
+ (put-uleb128 line-port 0))) ; size
+ seed)
+ #f
+ files)
(put-u8 line-port 0) ; 0 byte terminating file list.
;; Patch prologue length.
diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm
index 1ca8fee..4c9644e 100644
--- a/module/system/vm/coverage.scm
+++ b/module/system/vm/coverage.scm
@@ -20,10 +20,14 @@
#:use-module (system vm vm)
#:use-module (system vm frame)
#:use-module (system vm program)
+ #:use-module (system vm debug)
+ #:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
#:export (with-code-coverage
coverage-data?
instrumented-source-files
@@ -46,54 +50,20 @@
;;; Gathering coverage data.
;;;
-(define (hashq-proc proc n)
- ;; Return the hash of PROC's objcode.
- (if (rtl-program? proc)
- (hashq (rtl-program-code proc) n)
- (hashq (program-objcode proc) n)))
-
-(define (assq-proc proc alist)
- ;; Instead of really looking for PROC in ALIST, look for the objcode of PROC.
- ;; IOW the alist is indexed by procedures, not objcodes, but those procedures
- ;; are taken as an arbitrary representative of all the procedures (closures)
- ;; sharing that objcode. This can significantly reduce memory consumption.
- (if (rtl-program? proc)
- (let ((code (rtl-program-code proc)))
- (find (lambda (pair)
- (let ((proc (car pair)))
- (and (rtl-program? proc)
- (eqv? code (rtl-program-code proc)))))
- alist))
- (let ((code (program-objcode proc)))
- (find (lambda (pair)
- (let ((proc (car pair)))
- (and (program? proc)
- (eq? code (program-objcode proc)))))
- alist))))
-
(define (with-code-coverage vm thunk)
"Run THUNK, a zero-argument procedure, using VM; instrument VM to collect
code
coverage data. Return code coverage data and the values returned by THUNK."
- (define procedure->ip-counts
- ;; Mapping from procedures to hash tables; said hash tables map instruction
- ;; pointers to the number of times they were executed.
- (make-hash-table 500))
+ (define ip-counts
+ ;; A table mapping instruction pointers to the number of times they were
+ ;; executed.
+ (make-hash-table 5000))
(define (collect! frame)
- ;; Update PROCEDURE->IP-COUNTS with info from FRAME.
- (let* ((proc (frame-procedure frame))
- (ip (frame-instruction-pointer frame))
- (proc-entry (hashx-create-handle! hashq-proc assq-proc
- procedure->ip-counts proc #f)))
- (let loop ()
- (define ip-counts (cdr proc-entry))
- (if ip-counts
- (let ((ip-entry (hashv-create-handle! ip-counts ip 0)))
- (set-cdr! ip-entry (+ (cdr ip-entry) 1)))
- (begin
- (set-cdr! proc-entry (make-hash-table))
- (loop))))))
+ ;; Update IP-COUNTS with info from FRAME.
+ (let* ((ip (frame-instruction-pointer frame))
+ (ip-entry (hashv-create-handle! ip-counts ip 0)))
+ (set-cdr! ip-entry (+ (cdr ip-entry) 1))))
;; FIXME: It's unclear what the dynamic-wind is for, given that if the
;; VM is different from the current one, continuations will not be
@@ -111,7 +81,48 @@ coverage data. Return code coverage data and the values
returned by THUNK."
(set-vm-trace-level! vm level)
(remove-hook! hook collect!)))))
(lambda args
- (apply values (make-coverage-data procedure->ip-counts) args))))
+ (apply values (make-coverage-data ip-counts) args))))
+
+
+
+
+;;;
+;;; Source chunks.
+;;;
+
+(define-record-type <source-chunk>
+ (make-source-chunk base length sources)
+ source-chunk?
+ (base source-chunk-base)
+ (length source-chunk-length)
+ (sources source-chunk-sources))
+
+(set-record-type-printer!
+ <source-chunk>
+ (lambda (obj port)
+ (format port "<source-chunk #x~x-#x~x>"
+ (source-chunk-base obj)
+ (+ (source-chunk-base obj) (source-chunk-length obj)))))
+
+(define (compute-source-chunk ctx)
+ "Build a sorted vector of source information for a given debugging
+context (ELF image). The return value is a @code{<source-chunk>}, which also
+records the address range to which the source information applies."
+ (make-source-chunk
+ (debug-context-base ctx)
+ (debug-context-length ctx)
+ ;; The source locations are sorted already, but collected in reverse order.
+ (list->vector (reverse! (fold-source-locations cons '() ctx)))))
+
+(define (all-source-information)
+ "Build and return a vector of source information corresponding to all
+loaded code. The vector will be sorted by ascending address order."
+ (sort! (list->vector (fold-all-debug-contexts
+ (lambda (ctx seed)
+ (cons (compute-source-chunk ctx) seed))
+ '()))
+ (lambda (x y)
+ (< (source-chunk-base x) (source-chunk-base y)))))
;;;
@@ -119,124 +130,137 @@ coverage data. Return code coverage data and the
values returned by THUNK."
;;;
(define-record-type <coverage-data>
- (%make-coverage-data procedure->ip-counts
- procedure->sources
+ (%make-coverage-data ip-counts
+ sources
file->procedures
file->line-counts)
coverage-data?
- ;; Mapping from procedures to hash tables; said hash tables map instruction
- ;; pointers to the number of times they were executed.
- (procedure->ip-counts data-procedure->ip-counts)
+ ;; Mapping from instruction pointers to the number of times they were
+ ;; executed, as a sorted vector of IP-count pairs.
+ (ip-counts data-ip-counts)
- ;; Mapping from procedures to the result of `program-sources'.
- (procedure->sources data-procedure->sources)
+ ;; Complete source census at the time the coverage analysis was run, as a
+ ;; sorted vector of <source-chunk> values.
+ (sources data-sources)
;; Mapping from source file names to lists of procedures defined in the file.
+ ;; FIXME.
(file->procedures data-file->procedures)
;; Mapping from file names to hash tables, which in turn map from line
numbers
;; to execution counts.
(file->line-counts data-file->line-counts))
+(set-record-type-printer!
+ <coverage-data>
+ (lambda (obj port)
+ (format port "<coverage-data ~x>" (object-address obj))))
-(define (make-coverage-data procedure->ip-counts)
+(define (make-coverage-data ip-counts)
;; Return a `coverage-data' object based on the coverage data available in
- ;; PROCEDURE->IP-COUNTS. Precompute the other hash tables that make up
- ;; `coverage-data' objects.
- (let* ((procedure->sources (make-hash-table 500))
+ ;; IP-COUNTS. Precompute the other hash tables that make up `coverage-data'
+ ;; objects.
+ (let* ((all-sources (all-source-information))
+ (all-counts (sort! (list->vector (hash-fold acons '() ip-counts))
+ (lambda (x y)
+ (< (car x) (car y)))))
(file->procedures (make-hash-table 100))
(file->line-counts (make-hash-table 100))
- (data (%make-coverage-data procedure->ip-counts
- procedure->sources
+ (data (%make-coverage-data all-counts
+ all-sources
file->procedures
file->line-counts)))
- (define (increment-execution-count! file line count)
+
+ (define (observe-execution-count! file line count)
;; Make the execution count of FILE:LINE the maximum of its current value
;; and COUNT. This is so that LINE's execution count is correct when
;; several instruction pointers map to LINE.
- (let ((file-entry (hash-create-handle! file->line-counts file #f)))
- (if (not (cdr file-entry))
- (set-cdr! file-entry (make-hash-table 500)))
- (let ((line-entry (hashv-create-handle! (cdr file-entry) line 0)))
- (set-cdr! line-entry (max (cdr line-entry) count)))))
-
- ;; Update execution counts for procs that were executed.
- (hash-for-each (lambda (proc ip-counts)
- (let* ((sources (program-sources* data proc))
- (file (and (pair? sources)
- (source:file (car sources)))))
- (and file
- (begin
- ;; Add a zero count for all IPs in SOURCES and in
- ;; the sources of procedures closed over by PROC.
- (for-each
- (lambda (source)
- (let ((file (source:file source))
- (line (source:line source)))
- (increment-execution-count! file line 0)))
- (append-map (cut program-sources* data <>)
- (closed-over-procedures proc)))
-
- ;; Add the actual execution count collected.
- (hash-for-each
- (lambda (ip count)
- (let ((line (closest-source-line sources ip)))
- (increment-execution-count! file line
count)))
- ip-counts)))))
- procedure->ip-counts)
-
- ;; Set the execution count to zero for procedures loaded and not executed.
- ;; FIXME: Traversing thousands of procedures here is inefficient.
- (for-each (lambda (proc)
- (and (not (hashq-ref procedure->sources proc))
- (for-each (lambda (proc)
- (let* ((sources (program-sources* data proc))
- (file (and (pair? sources)
- (source:file (car
sources)))))
- (and file
- (for-each
- (lambda (ip)
- (let ((line (closest-source-line
sources ip)))
- (increment-execution-count! file
line 0)))
- (map source:addr sources)))))
- (closed-over-procedures proc))))
- (append-map module-procedures (loaded-modules)))
+ (when file
+ (let ((file-entry (hash-create-handle! file->line-counts file #f)))
+ (if (not (cdr file-entry))
+ (set-cdr! file-entry (make-hash-table 500)))
+ (let ((line-entry (hashv-create-handle! (cdr file-entry) line 0)))
+ (set-cdr! line-entry (max (cdr line-entry) count))))))
+
+ ;; First, visit every known source location and mark it as instrumented but
+ ;; unvisited.
+ ;;
+ ;; FIXME: This is not always necessary. It's important to have the ability
+ ;; to know when a source location is not reached, but sometimes all we need
+ ;; to know is that a particular site *was* reached. In that case we
+ ;; wouldn't need to load up all the DWARF sections. As it is, though, we
+ ;; use the complete source census as part of the later phase.
+ (let visit-chunk ((chunk-idx 0))
+ (when (< chunk-idx (vector-length all-sources))
+ (match (vector-ref all-sources chunk-idx)
+ (($ <source-chunk> base chunk-length chunk-sources)
+ (let visit-source ((source-idx 0))
+ (when (< source-idx (vector-length chunk-sources))
+ (let ((s (vector-ref chunk-sources source-idx)))
+ (observe-execution-count! (source-file s) (source-line s) 0)
+ (visit-source (1+ source-idx)))))))
+ (visit-chunk (1+ chunk-idx))))
+
+ ;; Then, visit the measured execution counts, walking the complete source
+ ;; census at the same time. This allows us to map observed addresses to
+ ;; source locations. Record observed execution counts.
+ (let visit-chunk ((chunk-idx 0) (count-idx 0))
+ (when (< chunk-idx (vector-length all-sources))
+ (match (vector-ref all-sources chunk-idx)
+ (($ <source-chunk> base chunk-length chunk-sources)
+ (let visit-count ((count-idx count-idx) (source-idx 0) (source #f))
+ (when (< count-idx (vector-length all-counts))
+ (match (vector-ref all-counts count-idx)
+ ((ip . count)
+ (cond
+ ((< ip base)
+ ;; Address before chunk base; no corresponding source.
+ (visit-count (1+ count-idx) source-idx source))
+ ((< ip (+ base chunk-length))
+ ;; Address in chunk; count it.
+ (let visit-source ((source-idx source-idx) (source source))
+ (define (finish)
+ (when source
+ (observe-execution-count! (source-file source)
+ (source-line source)
+ count))
+ (visit-count (1+ count-idx) source-idx source))
+ (cond
+ ((< source-idx (vector-length chunk-sources))
+ (let ((source* (vector-ref chunk-sources source-idx)))
+ (if (<= (source-pre-pc source*) ip)
+ (visit-source (1+ source-idx) source*)
+ (finish))))
+ (else
+ (finish)))))
+ (else
+ ;; Address past chunk; fetch the next chunk.
+ (visit-chunk (1+ chunk-idx) count-idx)))))))))))
data))
(define (procedure-execution-count data proc)
- "Return the number of times PROC's code was executed, according to DATA, or
#f
-if PROC was not executed. When PROC is a closure, the number of times its code
-was executed is returned, not the number of times this code associated with
this
-particular closure was executed."
- (let ((sources (program-sources* data proc)))
- (and (pair? sources)
- (and=> (hashx-ref hashq-proc assq-proc
- (data-procedure->ip-counts data) proc)
- (lambda (ip-counts)
- ;; FIXME: broken with lambda*
- (let ((entry-ip (source:addr (car sources))))
- (hashv-ref ip-counts entry-ip 0)))))))
-
-(define (program-sources* data proc)
- ;; A memoizing version of `program-sources'.
- (or (hashq-ref (data-procedure->sources data) proc)
- (and (or (program? proc) (rtl-program? proc))
- (let ((sources (program-sources proc))
- (p->s (data-procedure->sources data))
- (f->p (data-file->procedures data)))
- (if (pair? sources)
- (let* ((file (source:file (car sources)))
- (entry (hash-create-handle! f->p file '())))
- (hashq-set! p->s proc sources)
- (set-cdr! entry (cons proc (cdr entry)))
- sources)
- sources)))))
-
-(define (file-procedures data file)
- ;; Return the list of globally bound procedures defined in FILE.
- (hash-ref (data-file->procedures data) file '()))
+ "Return the number of times PROC's code was executed, according to DATA.
When
+PROC is a closure, the number of times its code was executed is returned, not
+the number of times this code associated with this particular closure was
+executed."
+ (define (binary-search v key val)
+ (let lp ((start 0) (end (vector-length v)))
+ (and (not (eqv? start end))
+ (let* ((idx (floor/ (+ start end) 2))
+ (elt (vector-ref v idx))
+ (val* (key elt)))
+ (cond
+ ((< val val*)
+ (lp start idx))
+ ((< val* val)
+ (lp (1+ idx) end))
+ (else elt))))))
+ (and (rtl-program? proc)
+ (match (binary-search (data-ip-counts data) car (rtl-program-code proc))
+ (#f 0)
+ ((ip . code) code))))
(define (instrumented/executed-lines data file)
"Return the number of instrumented and the number of executed source lines in
@@ -273,66 +297,6 @@ was loaded at the time DATA was collected."
;;;
-;;; Helpers.
-;;;
-
-(define (loaded-modules)
- ;; Return the list of all the modules currently loaded.
- (define seen (make-hash-table))
-
- (let loop ((modules (module-submodules (resolve-module '() #f)))
- (result '()))
- (hash-fold (lambda (name module result)
- (if (hashq-ref seen module)
- result
- (begin
- (hashq-set! seen module #t)
- (loop (module-submodules module)
- (cons module result)))))
- result
- modules)))
-
-(define (module-procedures module)
- ;; Return the list of procedures bound globally in MODULE.
- (hash-fold (lambda (binding var result)
- (if (variable-bound? var)
- (let ((value (variable-ref var)))
- (if (procedure? value)
- (cons value result)
- result))
- result))
- '()
- (module-obarray module)))
-
-(define (closest-source-line sources ip)
- ;; Given SOURCES, as returned by `program-sources' for a given procedure,
- ;; return the source line of code that is the closest to IP. This is similar
- ;; to what `program-source' does.
- (let loop ((sources sources)
- (line (and (pair? sources) (source:line (car sources)))))
- (if (null? sources)
- line
- (let ((source (car sources)))
- (if (> (source:addr source) ip)
- line
- (loop (cdr sources) (source:line source)))))))
-
-(define (closed-over-procedures proc)
- ;; Return the list of procedures PROC closes over, PROC included.
- (let loop ((proc proc)
- (result '()))
- (if (and (or (program? proc) (rtl-program? proc)) (not (memq proc result)))
- (fold loop (cons proc result)
- ;; FIXME: Include statically nested procedures for RTL
- ;; programs.
- (append (if (program? proc)
- (vector->list (or (program-objects proc) #()))
- '())
- (program-free-variables proc)))
- result)))
-
-
-;;;
;;; LCOV output.
;;;
@@ -342,6 +306,10 @@ was loaded at the time DATA was collected."
The report will include all the modules loaded at the time coverage data was
gathered, even if their code was not executed."
+ ;; FIXME: Re-enable this code, but using for-each-elf-symbol on each source
+ ;; chunk. Use that to build a map of file -> proc-addr + line + name. Then
+ ;; use something like procedure-execution-count to get the execution count.
+ #;
(define (dump-function proc)
;; Dump source location and basic coverage data for PROC.
(and (or (program? proc) (rtl-program? proc))
@@ -358,11 +326,11 @@ gathered, even if their code was not executed."
;; Output per-file coverage data.
(format port "TN:~%")
(for-each (lambda (file)
- (let ((procs (file-procedures data file))
- (path (search-path %load-path file)))
+ (let ((path (search-path %load-path file)))
(if (string? path)
(begin
(format port "SF:~A~%" path)
+ #;
(for-each dump-function procs)
(for-each (lambda (line+count)
(let ((line (car line+count))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 8eb4237..af99a54 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -31,9 +31,11 @@
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
#:use-module (srfi srfi-9)
#:export (debug-context-image
debug-context-base
+ debug-context-length
debug-context-text-base
program-debug-info-name
@@ -55,6 +57,7 @@
arity-is-case-lambda?
debug-context-from-image
+ fold-all-debug-contexts
for-each-elf-symbol
find-debug-context
find-program-debug-info
@@ -74,7 +77,8 @@
source-line-for-user
source-column
find-source-for-addr
- find-program-sources))
+ find-program-sources
+ fold-source-locations))
;;; A compiled procedure comes from a specific loaded ELF image. A
;;; debug context identifies that image.
@@ -93,6 +97,11 @@
@var{context}."
(elf-bytes (debug-context-elf context)))
+(define (debug-context-length context)
+ "Return the size of the mapped ELF image corresponding to
address@hidden, in bytes."
+ (bytevector-length (debug-context-image context)))
+
(define (for-each-elf-symbol context proc)
"Call @var{proc} on each symbol in the symbol table of @var{context}."
(let ((elf (debug-context-elf context)))
@@ -153,6 +162,15 @@ offset from the beginning of the ELF image in 32-bit
units."
(error "ELF object has no text section")))))
(make-debug-context elf base text-base)))
+(define (fold-all-debug-contexts proc seed)
+ "Fold @var{proc} over debug contexts corresponding to all images that
+are mapped at the time this procedure is called. Any images mapped
+during the fold are omitted."
+ (fold (lambda (image seed)
+ (proc (debug-context-from-image image) seed))
+ seed
+ (all-mapped-elf-images)))
+
(define (find-debug-context addr)
"Find and return the debugging context corresponding to the ELF image
containing the address @var{addr}. @var{addr} is an integer. If no ELF
@@ -254,12 +272,18 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3)))))
(define (arity-low-pc arity)
- (arity-low-pc* (elf-bytes (debug-context-elf (arity-context arity)))
- (arity-header-offset arity)))
+ (let ((ctx (arity-context arity)))
+ (+ (debug-context-base ctx)
+ (debug-context-text-base ctx)
+ (arity-low-pc* (elf-bytes (debug-context-elf ctx))
+ (arity-header-offset arity)))))
(define (arity-high-pc arity)
- (arity-high-pc* (elf-bytes (debug-context-elf (arity-context arity)))
- (arity-header-offset arity)))
+ (let ((ctx (arity-context arity)))
+ (+ (debug-context-base ctx)
+ (debug-context-text-base ctx)
+ (arity-high-pc* (elf-bytes (debug-context-elf ctx))
+ (arity-header-offset arity)))))
(define (arity-nreq arity)
(arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
@@ -316,12 +340,12 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(and (not (is-case-lambda? flags))
`((required . ,(load-symbols 0 nreq))
(optional . ,(load-symbols nreq nopt))
- (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))
(keyword . ,(if (has-keyword-args? flags)
(load-non-immediate
(+ nreq nopt (if (has-rest? flags) 1 0)))
'()))
- (allow-other-keys? . ,(allow-other-keys? flags))))))
+ (allow-other-keys? . ,(allow-other-keys? flags))
+ (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))))))
(define (find-first-arity context base addr)
(let* ((bv (elf-bytes (debug-context-elf context)))
@@ -334,9 +358,9 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(let lp ((pos headers-start))
(cond
((>= pos headers-end) #f)
- ((< text-offset (* (arity-low-pc* bv pos) 4))
+ ((< text-offset (arity-low-pc* bv pos))
#f)
- ((<= (* (arity-high-pc* bv pos) 4) text-offset)
+ ((<= (arity-high-pc* bv pos) text-offset)
(lp (+ pos arity-header-len)))
(else
(make-arity context base pos))))))
@@ -376,7 +400,17 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(let* ((base (elf-section-offset sec))
(first (find-first-arity context base addr)))
(if (arity-is-case-lambda? first)
- (list 0 0 #t) ;; FIXME: be more precise.
+ (let ((arities (read-sub-arities context base
+ (arity-header-offset first))))
+ (and (pair? arities)
+ (list (apply min (map arity-nreq arities))
+ 0
+ (or-map (lambda (arity)
+ (or (positive? (arity-nopt arity))
+ (arity-has-rest? arity)
+ (arity-has-keyword-args? arity)
+ (arity-allow-other-keys? arity)))
+ arities))))
(list (arity-nreq first)
(arity-nopt first)
(arity-has-rest? first)))))))
@@ -402,15 +436,14 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(let lp ((pos start))
(cond
((>= pos end) #f)
- ((< text-offset (bytevector-u32-native-ref bv pos))
+ ((< (bytevector-u32-native-ref bv pos) text-offset)
(lp (+ pos docstr-len)))
- ((> text-offset (bytevector-u32-native-ref bv pos))
- #f)
- (else
+ ((= text-offset (bytevector-u32-native-ref bv pos))
(let ((strtab (elf-section (debug-context-elf context)
(elf-section-link sec)))
(idx (bytevector-u32-native-ref bv (+ pos 4))))
- (string-table-ref bv (+ (elf-section-offset strtab) idx))))))))))
+ (string-table-ref bv (+ (elf-section-offset strtab) idx))))
+ (else #f)))))))
(define* (find-program-properties addr #:optional
(context (find-debug-context addr)))
@@ -531,8 +564,47 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(line-prog-advance prog)))
(lambda (pc file line col)
(if (and pc (< pc high-pc))
- (lp (cons (make-source/dwarf (+ pc base) file line col)
- sources))
+ ;; For the first source, it's probable that the
+ ;; address of the line program is before the
+ ;; low-pc, since the line program is for the
+ ;; entire compilation unit, and there are no
+ ;; redundant "rows" in the line program.
+ ;; Therefore in that case use the addr of low-pc
+ ;; instead of the one we got back.
+ (let ((addr (+ (if (null? sources) low-pc pc) base)))
+ (lp (cons (make-source/dwarf addr file line col)
+ sources)))
(reverse sources))))))
(else '())))))
(else '())))
+
+(define* (fold-source-locations proc seed context)
+ "Fold @var{proc} over all source locations in @var{context}.
address@hidden will be called with two arguments: the source object and the
+seed."
+ (cond
+ ((and context
+ (false-if-exception
+ (elf->dwarf-context (debug-context-elf context))))
+ =>
+ (lambda (dwarf-ctx)
+ (let ((base (debug-context-base context)))
+ (fold
+ (lambda (die seed)
+ (cond
+ ((die-line-prog die)
+ =>
+ (lambda (prog)
+ (let lp ((seed seed))
+ (call-with-values
+ (lambda () (line-prog-advance prog))
+ (lambda (pc* file line col)
+ (if pc*
+ (lp
+ (proc (make-source/dwarf (+ pc* base) file line col)
+ seed))
+ seed))))))
+ (else seed)))
+ seed
+ (read-die-roots dwarf-ctx)))))
+ (else seed)))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index a920923..1683b68 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -19,7 +19,7 @@
;;; Code:
(define-module (system vm disassembler)
- #:use-module (system vm instruction)
+ #:use-module (language rtl)
#:use-module (system vm elf)
#:use-module (system vm debug)
#:use-module (system vm program)
@@ -224,6 +224,8 @@ address of that offset."
((7) "variable?")
((13) "vector?")
((15) "string?")
+ ((77) "bytevector?")
+ ((95) "bitvector?")
(else (number->string tc7)))))
(if invert? (string-append "not " tag) tag))
(vector-ref labels (- (+ offset target) start))))
@@ -250,15 +252,10 @@ address of that offset."
nfree)))
(('make-non-immediate dst target)
(list "address@hidden" (reference-scm target)))
+ (('builtin-ref dst idx)
+ (list "~A" (builtin-index->name idx)))
(((or 'static-ref 'static-set!) _ target)
(list "address@hidden" (dereference-scm target)))
- (('link-procedure! src target)
- (let* ((addr (u32-offset->addr (+ offset target) context))
- (pdi (find-program-debug-info addr context)))
- (list "~A at 0x~X"
- (or (and pdi (program-debug-info-name pdi))
- "(anonymous procedure)")
- addr)))
(('resolve-module dst name public)
(list "~a" (if (zero? public) "private" "public")))
(('toplevel-box _ var-offset mod-offset sym-offset bound?)
diff --git a/module/system/vm/dwarf.scm b/module/system/vm/dwarf.scm
index da730a6..c545665 100644
--- a/module/system/vm/dwarf.scm
+++ b/module/system/vm/dwarf.scm
@@ -1525,8 +1525,7 @@
(values (cond ((zero? code) #f)
((vector-ref (ctx-abbrevs ctx) code))
(else (error "unknown abbrev" ctx code)))
- pos
- #f pos)))
+ pos)))
(define (read-die ctx offset)
(let*-values (((abbrev pos) (read-die-abbrev ctx offset)))
@@ -1725,7 +1724,7 @@
((addrsize pos) (read-u8 ctx pos))
((ctx) (make-compilation-unit-context ctx offset-size addrsize
av start len))
- ((die) (read-die ctx pos)))
+ ((die pos) (read-die ctx pos)))
(populate-context-tree! die)
(values die (ctx-end ctx))))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index ea2faaf..8aba837 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -26,7 +26,7 @@
#:export (frame-bindings
frame-lookup-binding
frame-binding-ref frame-binding-set!
- frame-next-source frame-call-representation
+ frame-call-representation
frame-environment
frame-object-binding frame-object-name))
@@ -71,15 +71,6 @@
;;; Pretty printing
;;;
-(define (frame-next-source frame)
- (let ((proc (frame-procedure frame)))
- (if (or (program? proc) (rtl-program? proc))
- (program-source proc
- (frame-instruction-pointer frame)
- (program-sources-pre-retire proc))
- '())))
-
-
;; Basically there are two cases to deal with here:
;;
;; 1. We've already parsed the arguments, and bound them to local
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
index e2a93d7..4a0e992 100644
--- a/module/system/vm/objcode.scm
+++ b/module/system/vm/objcode.scm
@@ -23,7 +23,7 @@
bytecode->objcode objcode->bytecode
load-thunk-from-file load-thunk-from-memory
word-size byte-order
- find-mapped-elf-image))
+ find-mapped-elf-image all-mapped-elf-images))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_objcodes")
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 2c8cd75..cf77c28 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -120,6 +120,15 @@
;; fixed length
(instruction-length inst))))))
+(define (source-for-addr addr)
+ (and=> (find-source-for-addr addr)
+ (lambda (source)
+ ;; FIXME: absolute or relative address?
+ (cons* 0
+ (source-file source)
+ (source-line source)
+ (source-column source)))))
+
(define (program-sources proc)
(cond
((rtl-program? proc)
@@ -305,13 +314,12 @@
prog
(list 0 0 nreq nopt rest? '(#f . ()))))))))
((rtl-program? prog)
- (let ((pc (and ip (+ (rtl-program-code prog) ip))))
- (or-map (lambda (arity)
- (and (or (not pc)
- (and (<= (arity-low-pc arity) pc)
- (< pc (arity-high-pc arity))))
- (arity-arguments-alist arity)))
- (or (find-program-arities (rtl-program-code prog)) '()))))
+ (or-map (lambda (arity)
+ (and (or (not ip)
+ (and (<= (arity-low-pc arity) ip)
+ (< ip (arity-high-pc arity))))
+ (arity-arguments-alist arity)))
+ (or (find-program-arities (rtl-program-code prog)) '())))
(else
(let ((arity (program-arity prog ip)))
(and arity
diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
index 82d4e0e..e334c01 100644
--- a/module/system/vm/trap-state.scm
+++ b/module/system/vm/trap-state.scm
@@ -1,6 +1,6 @@
;;; trap-state.scm: a set of traps
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2013 Free Software Foundation, Inc.
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -275,13 +275,13 @@
(and (<= (frame-address f) fp)
(predicate f))))))
- (let* ((source (frame-next-source frame))
+ (let* ((source (frame-source frame))
(idx (next-ephemeral-index! trap-state))
(trap (trap-matching-instructions
(wrap-predicate-according-to-into
(if instruction?
(lambda (f) #t)
- (lambda (f) (not (equal? (frame-next-source f) source)))))
+ (lambda (f) (not (equal? (frame-source f) source)))))
(ephemeral-handler-for-index trap-state idx handler))))
(add-trap-wrapper!
trap-state
diff --git a/test-suite/tests/bytevectors.test
b/test-suite/tests/bytevectors.test
index 28ccbf5..de20721 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -671,15 +671,23 @@
(pass-if "bitvector < 8"
(let ((bv (uniform-array->bytevector (make-bitvector 4 #t))))
- (= (bytevector-length bv) 1)))
+ (= (bytevector-length bv) 4)))
(pass-if "bitvector == 8"
(let ((bv (uniform-array->bytevector (make-bitvector 8 #t))))
- (= (bytevector-length bv) 1)))
+ (= (bytevector-length bv) 4)))
(pass-if "bitvector > 8"
(let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
- (= (bytevector-length bv) 2))))
+ (= (bytevector-length bv) 4)))
+
+ (pass-if "bitvector == 32"
+ (let ((bv (uniform-array->bytevector (make-bitvector 32 #t))))
+ (= (bytevector-length bv) 4)))
+
+ (pass-if "bitvector > 32"
+ (let ((bv (uniform-array->bytevector (make-bitvector 33 #t))))
+ (= (bytevector-length bv) 8))))
;;; Local Variables:
;;; eval: (put 'with-test-prefix/c&e 'scheme-indent-function 1)
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 619b167..ee202b6 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013 Free Software
Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -19,8 +19,8 @@
#:use-module (test-suite lib)
#:use-module (test-suite guile-test)
#:use-module (system base compile)
- #:use-module ((system vm program) #:select (make-program
- program-sources source:addr)))
+ #:use-module ((system vm objcode) #:select (load-thunk-from-memory))
+ #:use-module ((system vm program) #:select (program-sources source:addr)))
(define read-and-compile
(@@ (system base compile) read-and-compile))
@@ -97,7 +97,7 @@
#f)
(install-reader!)
this-should-be-ignored")))
- (and (eq? ((make-program (read-and-compile input)))
+ (and (eq? ((load-thunk-from-memory (read-and-compile input)))
'ok)
(eq? r (fluid-ref current-reader)))))
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index 336c87a..7a7a6c5 100644
--- a/test-suite/tests/coverage.test
+++ b/test-suite/tests/coverage.test
@@ -156,10 +156,9 @@
(let ((line (car line+count))
(count (cdr line+count)))
(case line
- ((0 1) (= count 1))
- ((2 3 4) (= count 0))
- ((5) (= count 1))
- (else #f))))
+ ((0 1) (= count 1))
+ ((2 3 4 5) (= count 0))
+ (else #f))))
counts))))))
(pass-if "case-lambda"
@@ -214,7 +213,7 @@
(lambda () (+ 1 2)))))
(and (coverage-data? data)
(= 3 result)
- (not (procedure-execution-count data proc))))))
+ (zero? (procedure-execution-count data proc))))))
(pass-if "applicable struct"
(let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw))
@@ -268,4 +267,4 @@
(let ((files (map basename (instrumented-source-files data))))
(and (member "boot-9.scm" files)
(member "chbouib.scm" files)
- (not (member "foo.scm" files))))))))
+ #t))))))
diff --git a/test-suite/tests/dwarf.test b/test-suite/tests/dwarf.test
index b999ab1..2d2a45e 100644
--- a/test-suite/tests/dwarf.test
+++ b/test-suite/tests/dwarf.test
@@ -62,19 +62,21 @@
(pass-if-equal 2 (source-column source)))
(match (find-program-sources (rtl-program-code qux))
- ((s1 s2)
+ ((s1 s2 s3)
(pass-if-equal "foo.scm" (source-file s1))
(pass-if-equal 0 (source-line s1))
(pass-if-equal 1 (source-line-for-user s1))
(pass-if-equal 0 (source-column s1))
- ;; FIXME: For some reason the source location for the + isn't
- ;; getting propagated.
-
(pass-if-equal "foo.scm" (source-file s2))
(pass-if-equal 1 (source-line s2))
(pass-if-equal 2 (source-line-for-user s2))
- (pass-if-equal 8 (source-column s2)))
+ (pass-if-equal 8 (source-column s2))
+
+ (pass-if-equal "foo.scm" (source-file s3))
+ (pass-if-equal 1 (source-line s3))
+ (pass-if-equal 2 (source-line-for-user s3))
+ (pass-if-equal 2 (source-column s3)))
(sources
(error "unexpected sources" sources)))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index a0221b8..8930cf2 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -349,9 +349,7 @@
(define tag (make-prompt-tag "foo"))
(with-test-prefix "stacks"
- ;; FIXME: Until we get one VM, a call to an RTL primitive from the
- ;; stack VM will result in the primitive being on the stack twice.
- (expect-fail "stack involving a primitive"
+ (pass-if "stack involving a primitive"
;; The primitive involving the error must appear exactly once on the
;; stack.
(let* ((stack (make-tagged-trimmed-stack tag '(#t)))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 0949ddf..730808b 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -582,7 +582,7 @@
(lambda (n)
(vector-set! v n n)))
(let (v) (_)
- ((call (toplevel make-vector) (const 6) (const #f)))
+ ((primcall make-vector (const 6) (const #f)))
(lambda ()
(lambda-case
(((n) #f #f #f () (_))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index a6467ea..84bb656 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -60,7 +60,11 @@
'(1 2 3 4)
#(1 2 3)
#("foo" "bar" 'baz)
- ;; FIXME: Add tests for arrays (uniform and otherwise)
+ #vu8()
+ #vu8(1 2 3 4 128 129 130)
+ #u32()
+ #u32(1 2 3 4 128 129 130 255 1000)
+ ;; FIXME: Add more tests for arrays (uniform and otherwise)
))
(with-test-prefix "static procedure"
diff --git a/test-suite/tests/session.test b/test-suite/tests/session.test
index c9aa4a0..f6fd389 100644
--- a/test-suite/tests/session.test
+++ b/test-suite/tests/session.test
@@ -77,17 +77,17 @@
(pass-if-valid-arguments "lambda* with keywords"
(lambda* (a b #:key (k 42) l) #f)
((required . (a b)) (optional)
- (keyword . ((#:k . 2) (#:l . 3))) (allow-other-keys? . #f)
+ (keyword . ((#:k . 3) (#:l . 4))) (allow-other-keys? . #f)
(rest . #f)))
(pass-if-valid-arguments "lambda* with keywords and a-o-k"
(lambda* (a b #:key (k 42) #:allow-other-keys) #f)
((required . (a b)) (optional)
- (keyword . ((#:k . 2))) (allow-other-keys? . #t)
+ (keyword . ((#:k . 3))) (allow-other-keys? . #t)
(rest . #f)))
(pass-if-valid-arguments "lambda* with optionals, keys, and rest"
(lambda* (a b #:optional o p #:key k l #:rest r) #f)
((required . (a b)) (optional . (o p))
- (keyword . ((#:k . 5) (#:l . 6))) (allow-other-keys? . #f)
+ (keyword . ((#:k . 6) (#:l . 7))) (allow-other-keys? . #f)
(rest . r)))
(pass-if "aok? is preserved"
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index edcbdc9..762fb59 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -208,7 +208,8 @@
(with-test-prefix "primitive-ref"
(assert-tree-il->glil
(primitive +)
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return
1)))
+ (program () (std-prelude 0 0 #f)
+ (label _) (module private ref (guile) +) (call return 1)))
(assert-tree-il->glil
(begin (primitive +) (const #f))
@@ -216,7 +217,8 @@
(assert-tree-il->glil
(primcall null? (primitive +))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
+ (program () (std-prelude 0 0 #f) (label _)
+ (module private ref (guile) +) (call null? 1)
(call return 1))))
(with-test-prefix "lexical refs"
@@ -658,7 +660,8 @@
(assert-tree-il->glil
(begin (primcall apply (toplevel foo) (toplevel bar)) (void))
(program () (std-prelude 0 0 #f) (label _)
- (call new-frame 0) (toplevel ref apply) (toplevel ref foo)
(toplevel ref bar) (mv-call 2 ,l1)
+ (call new-frame 0) (module private ref (guile) apply)
+ (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
(label ,l4)
(void) (call return 1))
@@ -677,7 +680,9 @@
(assert-tree-il->glil
(begin (primcall call-with-current-continuation (toplevel foo)) (void))
(program () (std-prelude 0 0 #f) (label _)
- (call new-frame 0) (toplevel ref call-with-current-continuation)
(toplevel ref foo) (mv-call 1 ,l1)
+ (call new-frame 0)
+ (module private ref (guile) call-with-current-continuation)
+ (toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
(label ,l4)
(void) (call return 1))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-358-g8734229,
Andy Wingo <=