[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-176-g2aeb
|
From: |
Noah Lavine |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-176-g2aeb4f8 |
|
Date: |
Sat, 16 Feb 2013 00:33:18 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=2aeb4f87c345c709e59f5fe402a9379d15587f1a
The branch, wip-rtl-cps has been updated
discards 6abdb93204b26340d299c4091ff8d137f4d7bcb9 (commit)
discards 4343aa4954bcf46983b7b47a2940615aef15a4cd (commit)
discards 5969a23c88c662f4f555d268303914880353f467 (commit)
discards 021aa8277a5937d444921401b9a8591f931d94c5 (commit)
discards 057bc49bc8d3e8970c33bc50dfb7843a048dbfab (commit)
discards a3e72d44b2565a79f138ef2e0f2bd4c2a6daf7db (commit)
discards 518f2ae63ee3ec08132c69307d1eace4b309888c (commit)
discards a011fb9d7c06c2264bb6d9ed1b08a1384ece4abc (commit)
discards 60a621b33c9d4083f2487ea0d66c9107b11282fc (commit)
discards 5bc51a993a134c1fa01a44a512c5280f9e0df439 (commit)
discards 7817a1f9d9e5f67467ebc08ca330c15afbdeb633 (commit)
discards ae087d7d8b411658f5529c0f81509afe4b14fdf2 (commit)
discards a3cac4add55c2653d275403f08a8903c74d6dc8c (commit)
discards 3a865174288ef8b20447b9947392edfa3826f74b (commit)
via 2aeb4f87c345c709e59f5fe402a9379d15587f1a (commit)
via 7e1bb2eabee8417a7d487db3fbf32f5c678e1093 (commit)
via f49400707ce911a6bcaa0d041fa0be131c15e59c (commit)
via d959dae4ee8daca7ee3353865473dc841833433b (commit)
via d01c9173735d87713f9eb66aec1f13d04f9aa32e (commit)
via 602113a3cf7f8cc739e3cd9db058d1b4a4b7bfd3 (commit)
via c417e582b6dd48a5704ec18348a05b5b1f2203e6 (commit)
via 38ad3632f861e0d8a62d83506ca8f7b8f21d3bf6 (commit)
via 58044df2b4309da8c86e32856733acbfbbe1cad5 (commit)
via a7a634a6eb116549268afe22015af16c72fa9f42 (commit)
via a73cfb0f0420e0bba309b1134ee4e6661be36fe6 (commit)
via 9b4150779820016deb434136b8ebe9b2fabbf39e (commit)
via 37383294d8fcb32cdab21b33b886175e6f018ce3 (commit)
via e2bb02e54fa6e98ab97f30863ccf09cd3fd7254e (commit)
via 8f46174e29551dc6755782732f0b11a0a3352a2a (commit)
via b411a8d7f918d9b89502928fdf37b18894ee7aff (commit)
via 9c4515c8651ce64ba91cf28da770e938c59a8808 (commit)
via 9cc45ec0cd4268d14db11ffd4840a6561fc43c35 (commit)
via d46dcbd600b62d6e57a8bb1ac4907f4443f62e37 (commit)
via ca159cd799998979463d95c16a7a2b3c6df6815d (commit)
via e08e3776d44305668cb882b25e6ee28e23da04b0 (commit)
via eef6081243532bec75c87d66cee09c3306183933 (commit)
via 103ccc996ff56d2464c4f643895a2057edbd7c63 (commit)
via bbb9cdd5382df79962ce4d3bb25771331d7890d6 (commit)
via bf51d129e7e557b629ea6568b581e43a261d5c7d (commit)
via 03cedbac1b77aae1c9df4f615d1f2dce07ac0bda (commit)
via dd02f3bd546f6a41d75785e8096b31b78e94167f (commit)
This update added new revisions after undoing existing revisions. That is
to say, the old revision is not a strict subset of the new revision. This
situation occurs when you --force push a change and generate a repository
containing something like this:
* -- * -- B -- O -- O -- O (6abdb93204b26340d299c4091ff8d137f4d7bcb9)
\
N -- N -- N (2aeb4f87c345c709e59f5fe402a9379d15587f1a)
When this happens we assume that you've already had alert emails for all
of the O revisions, and so we here report only the revisions in the N
branch from the common base, B.
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 2aeb4f87c345c709e59f5fe402a9379d15587f1a
Author: Noah Lavine <address@hidden>
Date: Fri Feb 15 19:16:58 2013 -0500
Rename 'name-value' to 'name-defn'
* module/language/cps/compile-rtl.scm: change 'name-value' to
'name-defn' for clarity.
commit 7e1bb2eabee8417a7d487db3fbf32f5c678e1093
Author: Noah Lavine <address@hidden>
Date: Fri Feb 15 19:07:39 2013 -0500
Test + Function
* test-suite/tests/cps.test: since we can now access top-level
variables, test that the + function works (instead of the CPS
primitive +).
commit f49400707ce911a6bcaa0d041fa0be131c15e59c
Author: Noah Lavine <address@hidden>
Date: Fri Feb 15 17:25:17 2013 -0500
Separate CPS and CPS-Data
* module/language/cps.scm: split 'cps' declaration into 'cps' and
'cps-data', to make the use of the cps-data types more clear. also add
a 'const' type for completeness.
* module/language/tree-il/compile-cps.scm: adjust.
* module/language/cps/compile-rtl.scm: adjust.
* test-suite/tests/cps.test: adjust.
commit d959dae4ee8daca7ee3353865473dc841833433b
Author: Noah Lavine <address@hidden>
Date: Fri Feb 15 16:10:07 2013 -0500
Toplevel Sets in CPS
* module/language/tree-il/compile-cps.scm: compile toplevel sets to
a new CPS primitive called 'set'.
* module/language/cps/compile-rtl.scm: compile 'set' to toplevel set
instructions.
* test-suite/tests/cps.test: test toplevel sets.
commit d01c9173735d87713f9eb66aec1f13d04f9aa32e
Author: Noah Lavine <address@hidden>
Date: Thu Feb 7 23:27:27 2013 -0500
Toplevel Refs in CPS
* module/language/cps.scm: new CPS forms to represent mutable variables.
* module/language/tree-il/compile-cps.scm: generate CPS for top-level
references.
* module/language/cps/compile-rtl.scm: generate RTL code for top-level
references.
* test-suite/tests/cps.test: test top-level references.
commit 602113a3cf7f8cc739e3cd9db058d1b4a4b7bfd3
Author: Noah Lavine <address@hidden>
Date: Fri Jan 25 09:52:36 2013 -0500
More CPS Primitives
* module/language/cps/primitives.scm: add more primitives to our
tables.
commit c417e582b6dd48a5704ec18348a05b5b1f2203e6
Author: Noah Lavine <address@hidden>
Date: Thu Jan 24 23:25:53 2013 -0500
Begin Tree-IL->CPS Compiler
* module/language/tree-il/compile-cps.scm: add (partial) Tree-IL->CPS
compiler.
* test-suite/tests/cps.test: test Tree-IL->CPS compiler by using it in
CPS tests.
commit 38ad3632f861e0d8a62d83506ca8f7b8f21d3bf6
Author: Noah Lavine <address@hidden>
Date: Thu Jan 24 23:23:03 2013 -0500
Simplify CPS If
* module/language/cps.scm: simplify CPS `if'.
* module/language/cps/compile-rtl.scm: compile simpler `if'.
* test-suite/tests/cps.test: test new, simpler form of `if'.
commit 58044df2b4309da8c86e32856733acbfbbe1cad5
Author: Noah Lavine <address@hidden>
Date: Sat Nov 17 09:35:15 2012 -0500
Bugfix in compiling CPS 'if'
* module/language/cps/compile-rtl.scm: generate a br instruction to skip
the alternate branch in an <if> if the test is true.
commit a7a634a6eb116549268afe22015af16c72fa9f42
Author: Noah Lavine <address@hidden>
Date: Fri Nov 16 23:00:01 2012 -0500
Compile CPS primitive '+'
* module/language/cps/primitives.scm: new files holds information on
primitives. currently only '+'.
* module/language/cps/compile-rtl.scm: compile simple primitives.
commit a73cfb0f0420e0bba309b1134ee4e6661be36fe6
Author: Noah Lavine <address@hidden>
Date: Fri Nov 16 22:03:21 2012 -0500
Compile CPS 'if'
* module/language/cps/compile-rtl.scm: compile the <if> form.
* test-suite/tests/cps.test: test that the <if> form compiles correctly.
commit 9b4150779820016deb434136b8ebe9b2fabbf39e
Author: Noah Lavine <address@hidden>
Date: Fri Nov 16 21:40:02 2012 -0500
Primitive and if in CPS
* module/language/cps.scm: add <primitive> and <if> CPS types.
commit 37383294d8fcb32cdab21b33b886175e6f018ce3
Author: Noah Lavine <address@hidden>
Date: Fri Nov 16 20:57:49 2012 -0500
Parser and unparser for CPS
* module/language/cps.scm: add parse-cps and unparse-cps.
* test-suite/tests/cps.test: use parse-cps.
commit e2bb02e54fa6e98ab97f30863ccf09cd3fd7254e
Author: Noah Lavine <address@hidden>
Date: Fri Nov 16 20:31:01 2012 -0500
Factor CPS Code
* module/language/cps.scm: remove RTL compilation functions and tests.
* module/language/cps/compile-rtl.scm: new location for CPS->RTL
compiler.
* test-suite/tests/cps.test: new location for CPS->RTL compiler tests.
commit 8f46174e29551dc6755782732f0b11a0a3352a2a
Author: Noah Lavine <address@hidden>
Date: Sun Nov 4 23:19:19 2012 -0500
Record-based CPS Representation
* module/language/cps.scm: use records to represent all CPS
constructs, instead of most of them. Make dispatches more
uniform by using record-case and match on the new records.
commit b411a8d7f918d9b89502928fdf37b18894ee7aff
Author: Noah Lavine <address@hidden>
Date: Fri Nov 2 21:30:53 2012 -0400
Add Identity Test
* module/language/cps.scm: make sure we can compile the identity
function.
commit 9c4515c8651ce64ba91cf28da770e938c59a8808
Author: Noah Lavine <address@hidden>
Date: Fri Nov 2 21:08:13 2012 -0400
Make Allocation Automatic
* module/language/cps.scm: cps->rtl automatically calls
allocate-registers-and-labels!
commit 9cc45ec0cd4268d14db11ffd4840a6561fc43c35
Author: Noah Lavine <address@hidden>
Date: Thu Nov 1 11:37:42 2012 -0400
Support Non-tail Calls
* module/language/cps.scm: add new test case 'compose'. Add support
for non-tail calls so it works correctly.
commit d46dcbd600b62d6e57a8bb1ac4907f4443f62e37
Author: Noah Lavine <address@hidden>
Date: Sat Oct 27 11:51:38 2012 -0400
Better register allocation
* module/language/cps.scm: finish register allocator. It should now
handle all cases.
commit ca159cd799998979463d95c16a7a2b3c6df6815d
Author: Noah Lavine <address@hidden>
Date: Sat Oct 27 11:36:57 2012 -0400
First work on CPS
* module/language/cps.scm: add bare-bones CPS. Can only compile a
few things.
-----------------------------------------------------------------------
Summary of changes:
libguile/vm-engine.c | 256 ++++++++++++++++++++++---------
module/language/cps.scm | 81 +++++++++-
module/language/cps/compile-rtl.scm | 203 +++++++++++++++++--------
module/language/cps/primitives.scm | 70 +++++++--
module/language/tree-il/compile-cps.scm | 94 +++++++++---
module/system/vm/rtl.scm | 60 +++++++-
module/system/vm/trace.scm | 2 +-
test-suite/tests/cps.test | 22 ++-
test-suite/tests/rtl.test | 92 +++++++++++-
9 files changed, 674 insertions(+), 206 deletions(-)
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index e31babd..44687e2 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -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
@@ -1112,7 +1112,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* with tail calls, we expect that the NVALUES values have already
* been shuffled down to a contiguous array starting ast slot 0.
*/
- VM_DEFINE_OP (6, return_values, "return/values", OP1 (U8_R24))
+ VM_DEFINE_OP (6, return_values, "return/values", OP1 (U8_U24))
{
SCM_UNPACK_RTL_24 (op, nargs);
RESET_FRAME(nargs);
@@ -2142,9 +2142,8 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
(lambda () (if (foo) a b))
- Although one can use resolve and box-ref, the toplevel-ref
- instruction is better for references. Sets have to use the more
- primitive instructions, though.
+ Although one can use resolve and box-ref, the toplevel-ref and
+ toplevel-set! instructions are better for references.
3. A reference to an identifier with respect to a particular
module. This can happen for primitive references, and
@@ -2158,11 +2157,27 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
interface, though there is also module-ref as a shortcut.
*/
+ /* current-module dst:24
+ *
+ * Store the current module in DST.
+ */
+ VM_DEFINE_OP (56, current_module, "current-module", OP1 (U8_U24) | OP_DST)
+ {
+ scm_t_uint32 dst;
+
+ SCM_UNPACK_RTL_24 (op, dst);
+
+ SYNC_IP ();
+ LOCAL_SET (dst, scm_current_module ());
+
+ NEXT (1);
+ }
+
/* resolve dst:8 mod:8 sym:8
*
* Resolve SYM in MOD, and place the resulting variable in DST.
*/
- VM_DEFINE_OP (56, resolve, "resolve", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (57, resolve, "resolve", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, mod, sym;
@@ -2180,7 +2195,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* nonzero, resolve the public interface, otherwise use the private
* interface.
*/
- VM_DEFINE_OP (57, resolve_module, "resolve-module", OP1 (U8_U8_U8_U8) |
OP_DST)
+ VM_DEFINE_OP (58, resolve_module, "resolve-module", OP1 (U8_U8_U8_U8) |
OP_DST)
{
scm_t_uint8 dst, name, public;
SCM mod;
@@ -2201,7 +2216,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* Look up a binding for SYM in the current module, creating it if
* necessary. Set its value to VAL.
*/
- VM_DEFINE_OP (58, 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);
@@ -2229,7 +2244,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* an error if it is unbound, unbox it into DST, and cache the
* resolved variable so that we will hit the cache next time.
*/
- VM_DEFINE_OP (59, toplevel_ref, "toplevel-ref", OP4 (U8_U24, S32, S32, N32)
| OP_DST)
+ VM_DEFINE_OP (60, toplevel_ref, "toplevel-ref", OP4 (U8_U24, S32, S32, N32)
| OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2270,13 +2285,57 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (4);
}
-
+ /* toplevel-set! src:24 var-offset:32 mod-offset:32 sym-offset:32
+ *
+ * Set a top-level variable from a variable cache cell. The variable
+ * is resolved as in toplevel-ref.
+ */
+ VM_DEFINE_OP (61, toplevel_set, "toplevel-set!", OP4 (U8_U24, S32, S32, N32))
+ {
+ scm_t_uint32 src;
+ scm_t_int32 var_offset;
+ scm_t_uint32* var_loc_u32;
+ SCM *var_loc;
+ SCM var;
+
+ SCM_UNPACK_RTL_24 (op, src);
+ var_offset = ip[1];
+ var_loc_u32 = ip + var_offset;
+ VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
+ var_loc = (SCM *) var_loc_u32;
+ var = *var_loc;
+
+ if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
+ {
+ SCM mod, sym;
+ scm_t_int32 mod_offset = ip[2]; /* signed */
+ scm_t_int32 sym_offset = ip[3]; /* signed */
+ scm_t_uint32 *mod_loc = ip + mod_offset;
+ scm_t_uint32 *sym_loc = ip + sym_offset;
+
+ SYNC_IP ();
+
+ VM_ASSERT (ALIGNED_P (mod_loc, SCM), abort());
+ VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
+
+ mod = *((SCM *) mod_loc);
+ sym = *((SCM *) sym_loc);
+
+ var = scm_module_lookup (mod, sym);
+
+ *var_loc = var;
+ }
+
+ VARIABLE_SET (var, LOCAL_REF (src));
+ NEXT (4);
+ }
+
/* module-ref dst:24 var-offset:32 mod-offset:32 sym-offset:32
*
* Like toplevel-ref, except MOD-OFFSET points at the name of a module
* instead of the module itself.
*/
- VM_DEFINE_OP (60, module_ref, "module-ref", OP4 (U8_U24, S32, N32, N32) |
OP_DST)
+ VM_DEFINE_OP (62, module_ref, "module-ref", OP4 (U8_U24, S32, N32, N32) |
OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
@@ -2321,8 +2380,53 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (4);
}
-
+ /* module-set! src:24 var-offset:32 mod-offset:32 sym-offset:32
+ *
+ * Like toplevel-set!, except MOD-OFFSET points at the name of a module
+ * instead of the module itself.
+ */
+ VM_DEFINE_OP (63, module_set, "module-set!", OP4 (U8_U24, S32, N32, N32))
+ {
+ scm_t_uint32 src;
+ scm_t_int32 var_offset;
+ scm_t_uint32* var_loc_u32;
+ SCM *var_loc;
+ SCM var;
+
+ SCM_UNPACK_RTL_24 (op, src);
+ var_offset = ip[1];
+ var_loc_u32 = ip + var_offset;
+ VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
+ var_loc = (SCM *) var_loc_u32;
+ var = *var_loc;
+ if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
+ {
+ SCM modname, sym;
+ scm_t_int32 modname_offset = ip[2]; /* signed */
+ scm_t_int32 sym_offset = ip[3]; /* signed */
+ scm_t_uint32 *modname_words = ip + modname_offset;
+ scm_t_uint32 *sym_loc = ip + sym_offset;
+
+ SYNC_IP ();
+
+ VM_ASSERT (!(((scm_t_uintptr) modname_words) & 0x7), abort());
+ VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
+
+ modname = SCM_PACK ((scm_t_bits) modname_words);
+ sym = *((SCM *) sym_loc);
+
+ if (scm_is_true (SCM_CAR (modname)))
+ var = scm_public_lookup (SCM_CDR (modname), sym);
+ else
+ var = scm_private_lookup (SCM_CDR (modname), sym);
+
+ *var_loc = var;
+ }
+
+ VARIABLE_SET (var, LOCAL_REF (src));
+ NEXT (4);
+ }
@@ -2336,7 +2440,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* handler at HANDLER-OFFSET words from the current IP. The handler
* will expect a multiple-value return.
*/
- VM_DEFINE_OP (61, prompt, "prompt", OP2 (U8_U24, U8_L24))
+ VM_DEFINE_OP (64, prompt, "prompt", OP2 (U8_U24, U8_L24))
#if 0
{
scm_t_uint32 tag;
@@ -2368,7 +2472,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 (62, wind, "wind", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (65, wind, "wind", OP1 (U8_U12_U12))
{
scm_t_uint16 winder, unwinder;
SCM_UNPACK_RTL_12_12 (op, winder, unwinder);
@@ -2383,7 +2487,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* VAL1, etc are 24-bit values, in the lower 24 bits of their words.
* The upper 8 bits are 0.
*/
- VM_DEFINE_OP (63, abort, "abort", OP2 (U8_U24, X8_R24))
+ VM_DEFINE_OP (66, abort, "abort", OP2 (U8_U24, X8_R24))
#if 0
{
scm_t_uint32 tag, nvalues;
@@ -2406,7 +2510,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* A normal exit from the dynamic extent of an expression. Pop the top
* entry off of the dynamic stack.
*/
- VM_DEFINE_OP (64, unwind, "unwind", OP1 (U8_X24))
+ VM_DEFINE_OP (67, unwind, "unwind", OP1 (U8_X24))
{
scm_dynstack_pop (¤t_thread->dynstack);
NEXT (1);
@@ -2418,7 +2522,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 (65, wind_fluids, "wind-fluids", OP2 (U8_U24, X8_R24))
+ VM_DEFINE_OP (68, wind_fluids, "wind-fluids", OP2 (U8_U24, X8_R24))
#if 0
{
scm_t_uint32 fluid_base, n;
@@ -2440,7 +2544,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 (66, unwind_fluids, "unwind-fluids", OP1 (U8_X24))
+ VM_DEFINE_OP (69, unwind_fluids, "unwind-fluids", OP1 (U8_X24))
{
/* This function must not allocate. */
scm_dynstack_unwind_fluids (¤t_thread->dynstack,
@@ -2452,7 +2556,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 (67, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (70, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
size_t num;
@@ -2485,7 +2589,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 (68, fluid_set, "fluid-set", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (71, fluid_set, "fluid-set", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
size_t num;
@@ -2518,7 +2622,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 (69, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (72, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (str);
if (SCM_LIKELY (scm_is_string (str)))
@@ -2535,7 +2639,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 (70, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (73, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (str, idx);
@@ -2557,7 +2661,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 (71, string_to_number, "string->number", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (74, string_to_number, "string->number", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
@@ -2573,7 +2677,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 (72, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (75, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
@@ -2587,7 +2691,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 (73, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (76, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) |
OP_DST)
{
scm_t_uint16 dst, src;
SCM_UNPACK_RTL_12_12 (op, dst, src);
@@ -2606,7 +2710,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 (74, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (77, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
RETURN (scm_cons (x, y));
@@ -2616,7 +2720,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the car of SRC in DST.
*/
- VM_DEFINE_OP (75, car, "car", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (78, car, "car", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "car");
@@ -2627,7 +2731,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Place the cdr of SRC in DST.
*/
- VM_DEFINE_OP (76, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (79, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "cdr");
@@ -2638,7 +2742,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the car of DST to SRC.
*/
- VM_DEFINE_OP (77, set_car, "set-car!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (80, set_car, "set-car!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2654,7 +2758,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Set the cdr of DST to SRC.
*/
- VM_DEFINE_OP (78, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (81, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
@@ -2677,7 +2781,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 (79, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (82, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (+, scm_sum);
}
@@ -2686,7 +2790,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 (80, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (83, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2712,7 +2816,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 (81, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (84, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (-, scm_difference);
}
@@ -2721,7 +2825,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 (82, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (85, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
@@ -2747,7 +2851,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 (83, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (86, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2758,7 +2862,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 (84, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (87, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2769,7 +2873,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 (85, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (88, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2780,7 +2884,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 (86, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (89, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2791,7 +2895,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 (87, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (90, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
@@ -2802,7 +2906,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 (88, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (91, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2835,7 +2939,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 (89, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (92, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2848,7 +2952,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 (90, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (93, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2861,7 +2965,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 (91, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (94, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -2874,7 +2978,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 (92, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (95, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
@@ -2891,7 +2995,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 (93, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (96, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
@@ -2912,7 +3016,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 (94, constant_vector_ref, "constant-vector-ref", OP1
(U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (97, constant_vector_ref, "constant-vector-ref", OP1
(U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM v;
@@ -2931,7 +3035,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 (95, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (98, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx_var, src;
SCM vect, idx, val;
@@ -2966,7 +3070,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");
@@ -2980,7 +3084,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
* the locals given by INIT0.... The format of INIT0... is as in the
* "call" opcode: unsigned 24-bit values, with 0 in the high byte.
*/
- VM_DEFINE_OP (97, make_struct, "make-struct", OP2 (U8_U12_U12, X8_R24))
+ VM_DEFINE_OP (100, make_struct, "make-struct", OP2 (U8_U12_U12, X8_R24))
#if 0
{
scm_t_uint16 dst, vtable_r;
@@ -3023,7 +3127,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);
@@ -3057,7 +3161,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;
@@ -3098,7 +3202,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))
@@ -3113,7 +3217,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);
@@ -3127,7 +3231,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);
@@ -3148,7 +3252,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;
@@ -3168,7 +3272,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Make a new array SRC into the vector DST at index IDX.
*/
- 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);
@@ -3266,42 +3370,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
@@ -3405,42 +3509,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/module/language/cps.scm b/module/language/cps.scm
index 1ddbda4..9802451 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -1,8 +1,10 @@
(define-module (language cps)
#:use-module (system base syntax) ;; for define-type
#:use-module (ice-9 match)
- #:export (<cps> cps?
- <letval> letval? make-letval letval-names letval-vals letval-body
+ #:export (<letval> letval? make-letval letval-names letval-vals letval-body
+ <const> const? make-const const-value
+ <var> var? make-var
+ <toplevel-var> toplevel-var? make-toplevel-var toplevel-var-name
<letrec> letrec? make-letrec letrec-names letrec-funcs letrec-body
<letcont> letcont? make-letcont letcont-names
letcont-conts letcont-body
@@ -35,6 +37,14 @@
;; forms represent some subset of the control flow graph in two parts,
;; and control only flows one direction between the parts.
+;; 3) all of the values named in the CPS representation are immutable,
+;; so we can always substitute the definition of a name for that
+;; name. we handle immutable values by putting them inside box objects
+;; (as it happens, this is how we have to handle them in the VM, too,
+;; in the general case). see below for more info.
+
+;; CPS Is Not About Continuations
+
;; Interestingly enough, we don't require that all continuations be
;; described by functions, even though that's the origin of CPS. the
;; reason is that we can't really convert all continuation captures to
@@ -47,9 +57,37 @@
;; them all. so we really are using the continuations as a way to
;; represent control flow, and not as real continuations!
+;; Mutable Variables
+
+;; The handling of mutable variables is interesting. We would eventually
+;; like to handle mutable variables and structs the same way - a
+;; container object that holds some number of mutable values, with a
+;; mutable variable being the special case of holding only one
+;; value. (Ideally we'd also model hash tables like that, but that's
+;; ambitious.) Kennedy's paper handles struct-like objects by having
+;; structure creation in the value part of a letval form, and
+;; introducing a 'let' form to pull the values out. However, the rewrite
+;; rules from his paper won't work if the structures are mutable,
+;; because then you can't just substitute - you have to check the entire
+;; control-flow graph up to that point to make sure the variable wasn't
+;; modified. So instead of having another form, we just have a special
+;; primitive function 'ref' that pulls the value out of a box, and a
+;; special primitive 'set' that sets the values in boxes.
+
+;; CPS and CPS-Data
+
+;; The data structure is a combination of <cps> and <cps-data>
+;; objects. The only reason to separate them is to be more clear about
+;; what things can go where - <cps-data> objects can only appear as the
+;; value part of a letval, and only <cps-data> objects can be there.
+
(define-type <cps>
- ;; <letval> actually handles multiple constant values, because why
- ;; not?
+ ;; <letval> values can be anything in the <cps-data> declaration
+ ;; below. I think it's an open question whether we need letvals - we
+ ;; could also imagine having some primitive functions that define
+ ;; constants and variable objects, and then replace letvals with
+ ;; letconts in which the body would have access to the variables or
+ ;; constants.
(<letval> names vals body)
;; Kennedy's paper calls this 'letfun', but 'letrec' is more standard
;; in Scheme
@@ -89,16 +127,35 @@
;; procedure and not a special form. that requires having a way for
;; primitive procedures to be inlined, but otherwise might be all
;; right.
- (<if> test consequent alternate)
- ;; we don't have the 'let' form from Kennedy's paper yet. We
- ;; eventually want to use something like it to compose record
- ;; constructors and accessors, and also describe mutable variables
+ (<if> test consequent alternate)
+ ;; we don't have the 'let' form from Kennedy's paper. see the comments
+ ;; about mutable variables above for the reason.
)
+(define-type <cps-data>
+ ;; const represents constants.
+ (<const> value)
+ ;; var is for lexical variables. these things just map to variable
+ ;; objects in the VM.
+ (<var>)
+ ;; toplevel vars are like pseudo-vars. instead of actually creating a
+ ;; variable object, we'll just remember that there *is* a variable
+ ;; object already in existence and look it up when we need it. we
+ ;; remember the name of the variable so that we can look it up.
+ (<toplevel-var> name))
+
(define (parse-cps tree)
(match tree
(('letval names vals body)
- (make-letval names vals (parse-cps body)))
+ (make-letval names
+ (map parse-cps vals)
+ (parse-cps body)))
+ (('const value)
+ (make-const value))
+ (('var value)
+ (make-var value))
+ (('toplevel-var name)
+ (make-toplevel-var name))
(('letrec names funcs body)
(make-letrec names
(map parse-cps funcs)
@@ -123,6 +180,12 @@
(match cps
(($ <letval> names vals body)
(list 'letval names vals (unparse-cps body)))
+ (($ <const> value)
+ (list 'const value))
+ (($ <var> value)
+ (list 'var value))
+ (($ <toplevel-var> name)
+ (list 'toplevel-var name))
(($ <letrec> names funcs body)
(list 'letrec names
(map unparse-cps funcs)
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index bfb8c2e..058dcf5 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -29,13 +29,15 @@
(set! label-counter (+ label-counter 1))
label))
-;; this lets us find the values of names bound in 'let...' forms. right
-;; now it only holds continuations, but there's no barrier to it holding
-;; other things, because all of the CPS names are distinct symbols. we
-;; don't have to worry about scoping, either. it might be better to get
-;; rid of this and replace names with direct links to their values, but
-;; that's a bigger project.
-(define name-value (make-object-property))
+;; the name-defn map lets us find the definitions of names bound in
+;; 'let...' forms. right now it only holds things from 'letval' and
+;; 'letcont' forms, but there's no barrier to adding 'letrec' too. it
+;; might be better to get rid of this and replace names with direct
+;; links to their values, but that's a bigger project.
+
+;; bikeshedding note: what's the correct naming convention here?
+;; "name-defn"? "name->defn"? "definition"? "lookup-defn"?
+(define name-defn (make-object-property))
;; this holds the number of local variable slots needed by every 'lambda'
;; form, so we can allocate them with the 'nlocals or
@@ -45,7 +47,7 @@
(define nlocals (make-object-property))
;; This function walks some CPS and allocates registers and labels for
-;; it. It's certainly not optimal yet. It also sets the name-value
+;; it. It's certainly not optimal yet. It also sets the name-defn
;; property for continuations
(define (allocate-registers-and-labels! cps)
(define (visit cps counter)
@@ -70,6 +72,12 @@
(iter (cdr names) (+ counter 1))))))
((<letval> names vals body)
+ ;; update the name-defn mapping
+ (map (lambda (n c)
+ (set! (name-defn n) c))
+ names vals)
+
+ ;; and allocate the registers
(let iter ((names names)
(counter counter))
(if (null? names)
@@ -90,9 +98,9 @@
(map (lambda (n)
(set! (label n) (next-label!)))
names)
- ;; then the name-value mapping
+ ;; then the name-defn mapping
(map (lambda (n c)
- (set! (name-value n) c))
+ (set! (name-defn n) c))
names conts)
;; then local variables. we need to return the maximum of the
;; register numbers used so that whatever procedure we're part of
@@ -131,21 +139,28 @@
;; show what registers and labels we've allocated where. use this at the
;; REPL: ,pp (with-alloc cps)
(define (with-alloc cps)
- ;; return a list that looks like the CPS, but with everyone annotated
- ;; with a register
- (define (with-reg s) ;; s must be a symbol
- (if (eq? s 'return)
- s
- (cons s (register s)))) ;; (register s) will be #f if we haven't
- ;; allocated s.
+ (define (with-register s) ;; s must be a symbol
+ (cons s (register s))) ;; (register s) will be #f if we haven't
+ ;; allocated s.
- (define (with-label s)
+
+ (define (do-value v) ;; v is a cps-data object
+ (cond ((var? v)
+ (list 'var (var-value v)))
+ ((toplevel-var? v)
+ (list 'toplevel-var (toplevel-var-name v)))
+ ((const? v)
+ (list 'const (const-value v)))
+ (else
+ (error "Bad cps-data object" v))))
+
+ (define (with-label s) ;; s must be the name of a continuation
(if (eq? s 'return)
s
(cons s (label s))))
(cond ((symbol? cps)
- (with-reg cps))
+ (with-register cps))
((boolean? cps)
;; we get a boolean when with-alloc is called on the cont of a
;; call to a letcont continuation.
@@ -157,11 +172,12 @@
(with-alloc cont)
(map with-alloc args)))
((<lambda> names body)
- `(lambda ,(map with-reg names)
+ `(lambda ,(map with-register names)
,(with-alloc body)))
((<letval> names vals body)
- `(letval ,(map with-reg names)
- ,vals ,(with-alloc body)))
+ `(letval ,(map with-register names)
+ ,(map do-value vals)
+ ,(with-alloc body)))
((<letcont> names conts body)
`(letcont ,(map with-label names)
,(map with-alloc conts)
@@ -262,6 +278,48 @@
;; This is the main function. cps->rtl compiles a cps form into a list
;; of RTL code.
(define (cps->rtl cps)
+ ;; generate-primitive-call: generate a call to primitive prim with the
+ ;; given args, placing the result in register(s) dsts. This is its own
+ ;; function because it is called twice in visit - once in the tail
+ ;; case and once in the non-tail case.
+ (define (generate-primitive-call dst prim args)
+ ;; the primitives 'ref and 'set are handled differently than the
+ ;; others because they need to know whether they're setting a
+ ;; toplevel variable or not. I think there's some bad abstraction
+ ;; going on here, but fixing it is hard. The most elegant thing from
+ ;; the CPS point of view is to forget about the toplevel-ref and
+ ;; toplevel-set VM instructions and just use resolve for everything,
+ ;; but that's ugly and probably slow. maybe once we have a peephole
+ ;; optimizer we'll be able to do that.
+
+ (case prim
+ ((ref) (let* ((var-value (car args))
+ (var (name-defn var-value)))
+ (if (toplevel-var? var)
+ (let ((var-name (toplevel-var-name var)))
+ ;; the scope is 'foo because we don't meaningfully
+ ;; distinguish scopes yet. we should really just
+ ;; cache the current module once per procedure.
+ `((cache-current-module! ,dst foo)
+ (cached-toplevel-ref ,dst foo ,var-name)))
+ `((box-ref ,dst ,(register var-value))))))
+ ((set) (let* ((var-value (car args))
+ (var (name-defn var-value)))
+ (if (toplevel-var? var)
+ (let ((var-name (toplevel-var-name var)))
+ `((cache-current-module! ,dst foo)
+ (cached-toplevel-set! ,(register (cadr args))
+ foo ,var-name)))
+ `((box-set!
+ ,(register (car args))
+ ,(register (cadr args)))))))
+ (else
+ (let ((insn (hashq-ref *primitive-insn-table* prim))
+ (arity (hashq-ref *primitive-arity-table* prim)))
+ (if (and insn (= arity (length args)))
+ `((,insn ,dst ,@(map register args)))
+ (error "malformed primitive call" (cons prim args)))))))
+
(define (visit cps)
;; cps is either a let expression or a call
(match cps
@@ -275,58 +333,61 @@
;; whether proc is a continuation or a real function, and do
;; something different if it's a continuation.
(($ <call> proc 'return args)
- (let ((num-args (length args)))
- ;; the shuffle here includes the procedure that we're going to
- ;; call, because we don't want to accidentally overwrite
- ;; it. this is a bit ugly - maybe there should be a better
- ;; generate-shuffle procedure that knows that some registers
- ;; are "protected", meaning that their values have to exist
- ;; after the shuffle, but don't have to end up in any specific
- ;; target register.
- (let ((shuffle
- (cons (cons (register proc)
- (+ num-args 1))
- (let iter ((args args)
- (arg-num 0))
- (if (null? args)
- '()
- (cons
- (cons (register (car args))
- arg-num)
- (iter (cdr args) (+ arg-num 1))))))))
- `(,@(apply generate-shuffle (+ num-args 2) shuffle)
- (tail-call ,num-args ,(+ num-args 1))))))
- ;; note that because of where this clause is placed, we will only
- ;; compile calls to primitives with non-return
- ;; continuations. this is because I don't know how to compile
- ;; primitive tail calls yet - it might be best to make them into
- ;; non-tail calls.
- (($ <call> ($ <primitive> prim) cont args)
- (let ((insn (hashq-ref *primitive-insn-table* prim))
- (arity (hashq-ref *primitive-arity-table* prim))
- (return-reg (register
- (car (lambda-names (name-value cont))))))
- (if (and insn (= arity (length args)))
- `((,insn ,return-reg ,@(map register args))
- (br ,(label cont)))
- (error "malformed primitive call" cps))))
+ (if (primitive? proc)
+ ;; we can't really call primitive procedures in tail
+ ;; position, so we just generate them in non-tail manner and
+ ;; then return. this seems like it might have to change in
+ ;; the future. it's fine to take the maximum register and
+ ;; add one, because the allocator reserved us one extra.
+ (let ((return-reg
+ (+ 1 (apply max (map register args)))))
+ `(,@(generate-primitive-call
+ return-reg (primitive-name proc) args)
+ (return ,return-reg)))
+
+ (let ((num-args (length args)))
+ ;; the shuffle here includes the procedure that we're going to
+ ;; call, because we don't want to accidentally overwrite
+ ;; it. this is a bit ugly - maybe there should be a better
+ ;; generate-shuffle procedure that knows that some registers
+ ;; are "protected", meaning that their values have to exist
+ ;; after the shuffle, but don't have to end up in any specific
+ ;; target register.
+ (let ((shuffle
+ (cons (cons (register proc)
+ (+ num-args 1))
+ (let iter ((args args)
+ (arg-num 0))
+ (if (null? args)
+ '()
+ (cons
+ (cons (register (car args))
+ arg-num)
+ (iter (cdr args) (+ arg-num 1))))))))
+ `(,@(apply generate-shuffle (+ num-args 2) shuffle)
+ (tail-call ,num-args ,(+ num-args 1)))))))
+
(($ <call> proc cont args)
(if (label cont) ;; a call whose continuation is bound in a
;; letcont form
(let ((return-base (register
- (car (lambda-names (name-value cont))))))
+ (car (lambda-names (name-defn cont))))))
;; return-base is the stack offset where we want to put
;; the return values of this function. there can't be
;; anything important on the stack past return-base,
;; because anything in scope would already have a reserved
;; spot on the stack before return-base, because the
;; allocator works that way.
- `((call ,return-base ,(register proc)
- ,(map register args))
- ;; the RA and MVRA both branch to the continuation. we
- ;; don't do error checking yet.
- (br ,(label cont)) ;; MVRA
- (br ,(label cont)))) ;; RA
+ (if (primitive? proc)
+ `(,@(generate-primitive-call
+ return-base (primitive-name proc) args)
+ (br ,(label cont)))
+ `((call ,return-base ,(register proc)
+ ,(map register args))
+ ;; the RA and MVRA both branch to the continuation. we
+ ;; don't do error checking yet.
+ (br ,(label cont)) ;; MVRA
+ (br ,(label cont))))) ;; RA
(error "We don't know how to compile" cps)))
;; consequent and alternate should both be continuations with no
;; arguments, so we call them by just jumping to them.
@@ -336,9 +397,21 @@
`((br-if-true ,(register test) 1 ,(label alternate))
(br ,(label consequent))))
(($ <letval> names vals body)
+ ;; <letval> values can be either constants, <var>s, or
+ ;; <toplevel-var>s. For constants, we intern a constant. For
+ ;; <var>s, we make a box. For <toplevel-var>s, we do nothing.
`(,@(append-map!
(lambda (name val)
- `((load-constant ,(register name) ,val)))
+ (cond ((var? val)
+ `((box ,(register name)
+ ,(register (var-value val)))))
+ ((toplevel-var? val)
+ `())
+ ((const? val)
+ `((load-constant ,(register name)
+ ,(const-value val))))
+ (else
+ (error "Bad cps-data object" val))))
names vals)
,@(visit body)))
(($ <letcont> names conts body)
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index 4478b8d..b2f23ae 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -2,27 +2,63 @@
#:export (*primitive-insn-table*
*primitive-arity-table*))
-;; right now the primitives tables only hold one primitive. this is just
-;; a stub so I can test the compiler on it.
+;; the "primitives" in this file are the operations which are supported
+;; by VM opcodes. Each primitive has more than one name - there is its
+;; name in the (guile) module, its name in a <primitive> record (which
+;; is always the same as its name in (guile), for simplicity) and its
+;; name as a VM instruction, which may be different from the first two.
-(define (fill-table-from-alist! table alist)
- (for-each
- (lambda (entry) (hashq-set! table
- (car entry)
- (cdr entry)))
- alist))
-
-(define *primitive-insn-list*
- '((+ . add)))
+;; this list holds information about the primitive VM operations. The
+;; current fields are (Scheme name, VM name, arity). We don't handle
+;; folds, reductions, or variable-arity instructions yet.
+(define *primitive-insn-data*
+ '((string-length string-length 1)
+ (string-ref string-ref 2)
+ (string->number string->number 1)
+ (string->symbol string->symbol 1)
+ (symbol->keyword symbol->keyword 1)
+ (cons cons 2)
+ (car car 1)
+ (cdr cdr 1)
+ (+ add 2)
+ (1+ add1 1)
+ (- sub 2)
+ (1- sub1 1)
+ (* mul 2)
+ (/ div 2)
+ ;; quo isn't here because I don't know which of our many types of
+ ;; division it's supposed to be. same for rem and mod.
+ (ash ash 2)
+ (logand logand 2)
+ (logior logior 2)
+ (logxor logxor 2)
+ (vector-length vector-length 1)
+ (vector-ref vector-ref 2)
+ (struct-vtable struct-vtable 1)
+ (struct-ref struct-ref 2)
+ (class-of class-of 1)))
-(define *primitive-arity-list*
- '((+ . 2)))
+;; this table maps our names for primitives (which are the Scheme names)
+;; to the corresponding VM instructions. It also does double duty as the
+;; list of Scheme names that can be turned into primitive instructions -
+;; if a procedure is in (guile) and is a key in this hash table, then it
+;; must represent a primitive operation.
(define *primitive-insn-table* (make-hash-table))
+
+;; this table maps our names to the instruction arities. We assume that
+;; each instruction takes its destination first and the remaining
+;; arguments in order. We don't handle folds or reductions right now.
+
(define *primitive-arity-table* (make-hash-table))
-(fill-table-from-alist! *primitive-insn-table*
- *primitive-insn-list*)
+(define (fill-insn-tables!)
+ (for-each
+ (lambda (entry)
+ (hashq-set! *primitive-insn-table*
+ (car entry) (cadr entry))
+ (hashq-set! *primitive-arity-table*
+ (car entry) (caddr entry)))
+ *primitive-insn-data*))
-(fill-table-from-alist! *primitive-arity-table*
- *primitive-arity-list*)
+(fill-insn-tables!)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 7637198..796800b 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -3,6 +3,7 @@
#:use-module ((language cps)
#:renamer (symbol-prefix-proc 'cps-))
#:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
#:export (tree-il->cps))
@@ -12,34 +13,58 @@
;; tree, and then calls 'gen-k' to generate more CPS code - but
;; 'gen-k' is called with a name which can reference the value of
;; tree. the real point is to abstract out the idea of *not*
- ;; generating extra continuations for lexical variable references. we
- ;; could always optimize them out later, but it seems easier to just
- ;; not make them in the first place.
- (define (with-value-name gen-k tree)
- (if (lexical-ref? tree)
- (gen-k (lexical-ref-gensym tree))
- (let ((con (gensym "con-"))
- (val (gensym "val-")))
- (cps-make-letcont
- (list con)
- (list (cps-make-lambda (list val) (gen-k val)))
- (visit con tree)))))
+ ;; generating extra continuations for lexical variable references and
+ ;; constants. we could always optimize them out later, but it seems
+ ;; easier to just not make them in the first place.
+ (define (with-value-name gen-k tree env)
+ (cond ((lexical-ref? tree)
+ (gen-k (lexical-ref-gensym tree)))
+ ((const? tree)
+ (let ((val-name (gensym "val-")))
+ (cps-make-letval
+ (list val-name)
+ (list (cps-make-const (const-exp tree)))
+ (gen-k val-name))))
+ (else
+ (let ((con (gensym "con-"))
+ (val (gensym "val-")))
+ (cps-make-letcont
+ (list con)
+ (list (cps-make-lambda (list val) (gen-k val)))
+ (visit con tree env))))))
;; like with-value-names, but takes a list of trees, and applies gen-k
;; to the corresponding list of values. the generated code evaluates
;; the list of values in the same order as they appear in the list.
- (define (with-value-names gen-k trees)
+ (define (with-value-names gen-k trees env)
(let iter ((trees trees)
(names '())) ;; names are accumulated in reverse order
(if (null? trees)
(apply gen-k (reverse names))
(with-value-name
(lambda (name) (iter (cdr trees) (cons name names)))
- (car trees)))))
+ (car trees)
+ env))))
+
+ ;; with-variable-boxes generates CPS that makes variable objects for
+ ;; the given variables and then calls 'gen-k' with a new environment
+ ;; in which the given names are mapped to the names of their boxes.
+ (define (with-variable-boxes gen-k vars env)
+ (let iter ((vars vars)
+ (env env))
+ (if (null? vars)
+ (gen-k env)
+ (let ((var-name (gensym "var-")))
+ (cps-make-letval
+ (list var-name)
+ (list (cps-make-var (car vars)))
+ (iter (car vars)
+ (vhash-consq (car vars) var-name env)))))))
;; visit returns a CPS version of tree which ends by calling
- ;; continuation k
- (define (visit k tree)
+ ;; continuation k. 'env' is a vhash that maps Tree-IL variable gensyms
+ ;; to CPS variable names.
+ (define (visit k tree env)
(match tree
;; note: 1. we only support lambdas with one case right now, and
;; totally ignore optional, rest and keyword arguments. 2. we only
@@ -47,12 +72,13 @@
(($ <lambda> src meta
($ <lambda-case> src req opt rest kw inits gensyms body alternate))
(cps-make-lambda gensyms
- (visit 'return body)))
+ (visit 'return body env)))
(($ <call> src proc args)
(with-value-names
(lambda (proc . args)
(cps-make-call proc k args))
- (cons proc args)))
+ (cons proc args)
+ env))
(($ <conditional> src test consequent alternate)
;; the control flow for an if looks like this:
;; test --> if ---> then ---> con
@@ -62,20 +88,42 @@
(cps-make-letcont
(list con alt)
(list
- (cps-make-lambda '() (visit k consequent))
- (cps-make-lambda '() (visit k alternate)))
+ (cps-make-lambda '() (visit k consequent env))
+ (cps-make-lambda '() (visit k alternate env)))
(with-value-name
(lambda (test-val)
(cps-make-if test-val con alt))
- test))))
+ test
+ env))))
(($ <lexical-ref> src name gensym)
(cps-make-call k #f (list gensym)))
+ (($ <toplevel-ref> src name)
+ (let ((var-name (gensym "var-")))
+ (cps-make-letval
+ (list var-name)
+ (list (cps-make-toplevel-var name))
+ (cps-make-call
+ (cps-make-primitive 'ref)
+ k
+ (list var-name)))))
+ (($ <toplevel-set> src name exp)
+ (with-value-name
+ (lambda (set-val)
+ (let ((var-name (gensym "var-")))
+ (cps-make-letval
+ (list var-name)
+ (list (cps-make-toplevel-var name))
+ (cps-make-call
+ (cps-make-primitive 'set)
+ k
+ (list var-name set-val)))))
+ exp env))
(($ <const> src exp)
(let ((v (gensym "val-")))
(cps-make-letval
(list v)
- (list exp)
+ (list (cps-make-const exp))
(cps-make-call k #f (list v)))))
(x (error "Unrecognized tree-il:" x))))
- (visit 'return tree))
+ (visit 'return tree vlist-null))
diff --git a/module/system/vm/rtl.scm b/module/system/vm/rtl.scm
index 3832968..0f8b391 100644
--- a/module/system/vm/rtl.scm
+++ b/module/system/vm/rtl.scm
@@ -1,6 +1,6 @@
;;; Guile VM program functions
-;;; Copyright (C) 2001, 2009, 2010, 2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 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
@@ -472,6 +472,14 @@
static-procedure?
(code static-procedure-code))
+;; Used for cells that cache the module that was current when a toplevel
+;; closure was created, or for toplevel refs within a procedure.
+(define-record-type <cache-cell>
+ (make-cache-cell scope key)
+ cache-cell?
+ (scope cache-cell-scope)
+ (key cache-cell-key))
+
(define (statically-allocatable? x)
(or (pair? x) (vector? x) (string? x) (stringbuf? x) (static-procedure? x)))
@@ -502,6 +510,7 @@
((static-procedure? obj)
`((make-non-immediate 0 ,label)
(link-procedure! 0 ,(static-procedure-code obj))))
+ ((cache-cell? obj) '())
((symbol? obj)
`((make-non-immediate 0 ,(recur (symbol->string obj)))
(string->symbol 0 0)
@@ -537,6 +546,15 @@
(error "expected a non-immediate" obj))
(intern-constant asm obj))
+;; Returns a label. Resolutions of the same key within the same scope
+;; share a cell.
+(define (emit-cache-cell asm scope key)
+ (intern-constant asm (make-cache-cell scope key)))
+
+;; Return the label of the cell that holds the module for a scope.
+(define (emit-module-cache-cell asm scope)
+ (emit-cache-cell asm scope #t))
+
(define-syntax define-macro-assembler
(lambda (x)
(syntax-case x ()
@@ -578,6 +596,38 @@
(define-macro-assembler (label asm sym)
(set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
+(define-macro-assembler (cache-current-module! asm tmp scope)
+ (let ((mod-label (emit-module-cache-cell asm scope)))
+ (emit-current-module asm tmp)
+ (reset-asm-start! asm)
+ (emit-static-set! asm tmp mod-label 0)))
+
+(define-macro-assembler (cached-toplevel-ref asm dst scope sym)
+ (let ((sym-label (emit-non-immediate asm sym))
+ (mod-label (emit-module-cache-cell asm scope))
+ (cell-label (emit-cache-cell asm scope sym)))
+ (emit-toplevel-ref asm dst cell-label mod-label sym-label)))
+
+(define-macro-assembler (cached-toplevel-set! asm src scope sym)
+ (let ((sym-label (emit-non-immediate asm sym))
+ (mod-label (emit-module-cache-cell asm scope))
+ (cell-label (emit-cache-cell asm scope sym)))
+ (emit-toplevel-set! asm src cell-label mod-label sym-label)))
+
+(define-macro-assembler (cached-module-ref asm dst module-name public? sym)
+ (let* ((sym-label (emit-non-immediate asm sym))
+ (key (cons public? module-name))
+ (mod-name-label (intern-constant asm key))
+ (cell-label (emit-cache-cell asm key sym)))
+ (emit-module-ref asm dst cell-label mod-name-label sym-label)))
+
+(define-macro-assembler (cached-module-set! asm src module-name public? sym)
+ (let* ((sym-label (emit-non-immediate asm sym))
+ (key (cons public? module-name))
+ (mod-name-label (emit-non-immediate asm key))
+ (cell-label (emit-cache-cell asm key sym)))
+ (emit-module-set! asm src cell-label mod-name-label sym-label)))
+
(define (emit-text asm instructions)
(for-each (lambda (inst)
(reset-asm-start! asm)
@@ -639,7 +689,7 @@
(define (link-text-object asm)
(let ((buf (make-u32vector (asm-pos asm))))
- (let lp ((pos 0) (prev (asm-prev asm)))
+ (let lp ((pos 0) (prev (reverse (asm-prev asm))))
(if (null? prev)
(let ((byte-size (* (asm-idx asm) 4)))
(bytevector-copy! (asm-cur asm) 0 buf pos byte-size)
@@ -722,7 +772,8 @@
(assert-nargs-ee/locals 0 1)
,@(reverse inits)
(load-constant 0 ,*unspecified*)
- (return 0)))
+ (return 0)
+ (end-program)))
label))))
(define (link-data asm data name)
@@ -807,6 +858,9 @@
(bytevector-u64-set! buf (+ pos 8) 0 endianness))
(else (error "bad word size"))))
+ ((cache-cell? obj)
+ (write-immediate asm buf pos #f))
+
((string? obj)
(let ((tag (logior tc7-ro-string (ash (string-length obj) 8))))
(case word-size
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 3b1c5ad..7b96af5 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -63,7 +63,7 @@
(format (current-error-port) "~a~v:@y\n"
prefix
width
- (frame-local-ref frame (- len 2))))
+ (car values)))
(else
;; this should work, but there appears to be a bug
;; "~a~d values:~:{ ~v:@y~}\n"
diff --git a/test-suite/tests/cps.test b/test-suite/tests/cps.test
index bb84f36..8620902 100644
--- a/test-suite/tests/cps.test
+++ b/test-suite/tests/cps.test
@@ -46,11 +46,17 @@
(pass-if "if false"
(= 2 (if-func #f)))
-;; (lambda () (+ 2 3))
-(pass-if "+"
- (= 5
- ((cps (lambda ()
- (letval (x y) (2 3)
- (letcont (c) ((lambda (z) (call return #f (z))))
- (call (primitive +) c (x y)))))))))
-
+(define *foo* 6)
+(pass-if "toplevel-ref"
+ (= 6
+ ((by-cps '(lambda () *foo*)))))
+
+(pass-if "toplevel-set"
+ (= 12
+ (begin
+ ((by-cps '(lambda () (set! *foo* 12))))
+ *foo*)))
+
+(pass-if "addition"
+ (= 7
+ ((by-cps '(lambda () (+ 3 4))))))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 3de5c74..219407c 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -131,7 +131,8 @@
(assert-nargs-ee/locals 1 0)
(call 1 0 ())
(return 1) ;; MVRA from call
- (return 1))))) ;; RA from call
+ (return 1) ;; RA from call
+ (end-program)))))
(call (lambda () 42))))
(assert-equal 6
@@ -142,7 +143,8 @@
(load-constant 1 3)
(call 2 0 (1))
(return 2) ;; MVRA from call
- (return 2))))) ;; RA from call
+ (return 2) ;; RA from call
+ (end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
(with-test-prefix "tail-call"
@@ -151,7 +153,8 @@
(assemble-program
'((begin-program call)
(assert-nargs-ee/locals 1 0)
- (tail-call 0 0)))))
+ (tail-call 0 0)
+ (end-program)))))
(call (lambda () 3))))
(assert-equal 6
@@ -161,5 +164,86 @@
(assert-nargs-ee/locals 1 1)
(mov 1 0) ;; R1 <- R0
(load-constant 0 3) ;; R0 <- 3
- (tail-call 1 1)))))
+ (tail-call 1 1)
+ (end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
+
+(with-test-prefix "cached-toplevel-ref"
+ (assert-equal 5.0
+ (let ((get-sqrt-trampoline
+ (assemble-program
+ '((begin-program get-sqrt-trampoline)
+ (assert-nargs-ee/locals 0 1)
+ (cache-current-module! 0 sqrt-scope)
+ (load-static-procedure 0 sqrt-trampoline)
+ (return 0)
+ (end-program)
+
+ (begin-program sqrt-trampoline)
+ (assert-nargs-ee/locals 1 1)
+ (cached-toplevel-ref 1 sqrt-scope sqrt)
+ (tail-call 1 1)
+ (end-program)))))
+ ((get-sqrt-trampoline) 25.0))))
+
+(define *top-val* 0)
+
+(with-test-prefix "cached-toplevel-set!"
+ (let ((prev *top-val*))
+ (assert-equal (1+ prev)
+ (let ((make-top-incrementor
+ (assemble-program
+ '((begin-program make-top-incrementor)
+ (assert-nargs-ee/locals 0 1)
+ (cache-current-module! 0 top-incrementor)
+ (load-static-procedure 0 top-incrementor)
+ (return 0)
+ (end-program)
+
+ (begin-program top-incrementor)
+ (assert-nargs-ee/locals 0 1)
+ (cached-toplevel-ref 0 top-incrementor *top-val*)
+ (add1 0 0)
+ (cached-toplevel-set! 0 top-incrementor *top-val*)
+ (return/values 0)
+ (end-program)))))
+ ((make-top-incrementor))
+ *top-val*))))
+
+(with-test-prefix "cached-module-ref"
+ (assert-equal 5.0
+ (let ((get-sqrt-trampoline
+ (assemble-program
+ '((begin-program get-sqrt-trampoline)
+ (assert-nargs-ee/locals 0 1)
+ (load-static-procedure 0 sqrt-trampoline)
+ (return 0)
+ (end-program)
+
+ (begin-program sqrt-trampoline)
+ (assert-nargs-ee/locals 1 1)
+ (cached-module-ref 1 (guile) #t sqrt)
+ (tail-call 1 1)
+ (end-program)))))
+ ((get-sqrt-trampoline) 25.0))))
+
+(with-test-prefix "cached-module-set!"
+ (let ((prev *top-val*))
+ (assert-equal (1+ prev)
+ (let ((make-top-incrementor
+ (assemble-program
+ '((begin-program make-top-incrementor)
+ (assert-nargs-ee/locals 0 1)
+ (load-static-procedure 0 top-incrementor)
+ (return 0)
+ (end-program)
+
+ (begin-program top-incrementor)
+ (assert-nargs-ee/locals 0 1)
+ (cached-module-ref 0 (tests rtl) #f *top-val*)
+ (add1 0 0)
+ (cached-module-set! 0 (tests rtl) #f *top-val*)
+ (return 0)
+ (end-program)))))
+ ((make-top-incrementor))
+ *top-val*))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-176-g2aeb4f8,
Noah Lavine <=