[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-290-g0720f70
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-290-g0720f70 |
|
Date: |
Sun, 27 Oct 2013 08:57:59 +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=0720f70ed7e9de2685409abfe4e2c0dd01f81b74
The branch, master has been updated
via 0720f70ed7e9de2685409abfe4e2c0dd01f81b74 (commit)
via c450b47723438ad9e517b02a45b577b7f7fd848b (commit)
via d422f3167e37f045d768430565a2b77c3253a5af (commit)
via 7e273b7a75147acf028f8de2614b5ff40d69bc53 (commit)
via 607fe5a604641d53579163fabaafbe8c085e338f (commit)
via 8ba3f20c478ff019daa4a08ed5bd6ebc058e143a (commit)
via fa3b6e57c2e1d8f20a9c54bed3f3052f33a2b428 (commit)
via 4f406fea7e9f85a3fdc3d9a69654475bd6665586 (commit)
via d023ae8679654305f9b34bda53c750f91a1acde4 (commit)
via be8b62ca7f66f6acd1d342cd8576688cc33baf1c (commit)
via 4fc6b4d2c5566aa54393c3124def2d7759dd447a (commit)
via 6fb508da2abdfeb7be1415b9d9561ed74bd75292 (commit)
via 2a4ee2ac8c0d04d5d83bffd3b31cd3d8c4ae3028 (commit)
via e23f9e4423bbbe8521d13e1c9a223612a5e86762 (commit)
via db071766650d10c67524b3ddb00decfd60c55741 (commit)
via 0f676d8725ebc79cd166047203c5400d8c639a25 (commit)
via 40553c2016298e84d01c09429eede129d2d8a53a (commit)
via 27ecfd3649dc6fbc5f512d3e95a8b8ac2139e2b9 (commit)
from cfc28c808e44582e9751b54713c58fd91ab53f16 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 0720f70ed7e9de2685409abfe4e2c0dd01f81b74
Author: Andy Wingo <address@hidden>
Date: Sun Oct 27 09:52:39 2013 +0100
Memoized expressions are pairs, not SMOBs
* libguile/memoize.c (MAKMEMO): Memoized objects are pairs now, not
SMOBs. This lets eval.scm destructure them more efficiently.
(scm_print_memoized, scm_memoized_p, scm_memoized_expression_typecode)
(scm_memoized_expression_data): Remove these interfaces.
(unmemoize, scm_memoize_variable_access_x): Remove SMOB type checks.
(scm_init_memoize): Remove SMOB type definition.
* libguile/memoize.h (scm_tc16_memoized, SCM_MEMOIZED_P)
(scm_memoized_expression_typecode, scm_memoized_expression_data)
(scm_memoized_p): Remove declarations.
* libguile/validate.h (SCM_VALIDATE_MEMOIZED): Remove declaration.
* libguile/eval.c (eval): Remove memoized type check, and inline the
inum unpacking.
* module/ice-9/eval.scm (memoized-expression-case): Use car and cdr to
destructure memoized expressions. A big win!
commit c450b47723438ad9e517b02a45b577b7f7fd848b
Author: Andy Wingo <address@hidden>
Date: Sun Oct 27 09:14:04 2013 +0100
Tree-IL->GLIL: Fix primitive-ref reification bug
* module/language/tree-il/compile-glil.scm (flatten-lambda-case): Fix a
bug whereby a primitive that is present in the compilation module but
not at runtime was getting compiled as a toplevel-ref. This was
causing current-module to fail to resolve in R6RS modules.
commit d422f3167e37f045d768430565a2b77c3253a5af
Author: Andy Wingo <address@hidden>
Date: Sat Oct 26 22:54:29 2013 +0200
Mark current-module as an interesting primitive
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
Add current-module, to allow RTL compilation.
commit 7e273b7a75147acf028f8de2614b5ff40d69bc53
Author: Andy Wingo <address@hidden>
Date: Sat Oct 26 22:30:54 2013 +0200
New pass: elide-values
* module/Makefile.am:
* module/language/cps/elide-values.scm (elide-values): New pass.
* module/language/cps/compile-rtl.scm (optimize): Call the new pass.
commit 607fe5a604641d53579163fabaafbe8c085e338f
Author: Andy Wingo <address@hidden>
Date: Sat Oct 26 22:06:01 2013 +0200
Add make-vector, constant-make-vector instructions
* libguile/vm-engine.c (rtl_vm_engine): Add make-vector and
constant-make-vector instructions and renumber.
* module/language/cps/compile-rtl.scm (emit-rtl-sequence): Emit
constant-make-vector and make-vector as appropriate.
* module/language/cps/dfg.scm (constant-needs-allocation?): In some
cases, make-vector doesn't need to allocate its index.
* module/language/tree-il/primitives.scm
(*interesting-primitive-names*, *primitive-constructors*): Add
make-vector.
commit 8ba3f20c478ff019daa4a08ed5bd6ebc058e143a
Author: Andy Wingo <address@hidden>
Date: Sat Oct 26 21:30:37 2013 +0200
Emit constant-vector-ref, constant-vector-set! for known small indices
* libguile/vm-engine.c (rtl_vm_engine): Add constant-vector-set!
instruction and renumber.
* module/language/cps/compile-rtl.scm (emit-rtl-sequence): Emit
constant-vector-ref and constant-vector-set! as appropriate.
* module/language/cps/dfg.scm (constant-needs-allocation?): In some
cases, vector-ref and vector-set! don't need to allocate their index.
commit fa3b6e57c2e1d8f20a9c54bed3f3052f33a2b428
Author: Andy Wingo <address@hidden>
Date: Sat Oct 26 21:07:27 2013 +0200
New pass: inline-constructors
* module/Makefile.am:
* module/language/cps/constructors.scm (inline-constructors): New pass.
* module/language/cps/compile-rtl.scm (optimize): Call the new pass.
* module/language/tree-il/compile-cps.scm (convert): Don't handle "list"
specially here.
commit 4f406fea7e9f85a3fdc3d9a69654475bd6665586
Author: Andy Wingo <address@hidden>
Date: Sat Oct 26 15:40:49 2013 +0200
Compile variable-ref, variable-set!
* libguile/vm-engine (box-ref, box-set!): Instead of aborting if a box
isn't a var, call out to vm_error_not_a_variable. This makes these
instructions equivalent to variable-ref/variable-set!.
(vector-set!): Rename from vector-set.
* module/language/cps/compile-rtl.scm (emit-rtl-sequence): Add
variable-set! case, and adapt vector-set!.
* module/language/cps/primitives.scm (*rtl-instruction-aliases*): Add
variable-ref / variable-set! aliases to box-ref / box-set!.
commit d023ae8679654305f9b34bda53c750f91a1acde4
Author: Andy Wingo <address@hidden>
Date: Sat Oct 26 15:25:49 2013 +0200
Recognize tree-il variable? primitive
* module/language/tree-il/primitives.scm (*interesting-primitive-names*)
(*effect-free-primitives*, *effect+exception-free-primitives*): Add
variable?. Fix nil? spelling.
commit be8b62ca7f66f6acd1d342cd8576688cc33baf1c
Author: Andy Wingo <address@hidden>
Date: Sat Oct 26 15:16:09 2013 +0200
RTL compiler: Compile TC7 branches.
* module/system/vm/assembler.scm:
* module/system/vm/disassembler.scm (code-annotation):
* module/language/cps/primitives.scm (*branching-primcall-arities*):
* module/language/cps/compile-rtl.scm (emit-rtl-sequence): Add support
for compiling symbol?, variable?, vector?, and string? branches.
commit 4fc6b4d2c5566aa54393c3124def2d7759dd447a
Author: Andy Wingo <address@hidden>
Date: Wed Oct 23 15:07:34 2013 +0200
Fix primcall return arities
* module/language/cps/arities.scm (fix-clause-arities): Primcalls of
known arity that continue to ktrunc should, if their return arity does
not match the ktrunc, adapt via a call to `values'. This call may
later get removed.
commit 6fb508da2abdfeb7be1415b9d9561ed74bd75292
Author: Andy Wingo <address@hidden>
Date: Wed Oct 23 10:35:04 2013 +0200
RTL compiler: Compile `wind' primcalls
* module/language/cps/compile-rtl.scm (emit-rtl-sequence): Add handler
for `wind'.
commit 2a4ee2ac8c0d04d5d83bffd3b31cd3d8c4ae3028
Author: Andy Wingo <address@hidden>
Date: Wed Oct 23 10:05:28 2013 +0200
RTL VM: Fix fluid-ref local addressing.
* libguile/vm-engine.c (push-fluid): Fix variable addressing.
commit e23f9e4423bbbe8521d13e1c9a223612a5e86762
Author: Andy Wingo <address@hidden>
Date: Wed Oct 23 10:03:17 2013 +0200
RTL VM: Fix variable lookup before modules boot
* libguile/vm-engine.c (toplevel-box, module-box): Handle the case where
the module system isn't booted yet.
commit db071766650d10c67524b3ddb00decfd60c55741
Author: Andy Wingo <address@hidden>
Date: Thu Oct 24 10:19:07 2013 +0200
Add stringbuf printer
* libguile/strings.h:
* libguile/strings.c (scm_i_print_stringbuf):
* libguile/print.c (iprin1): Add a printer for stringbufs. The
disassembler can print a stringbuf.
commit 0f676d8725ebc79cd166047203c5400d8c639a25
Author: Andy Wingo <address@hidden>
Date: Wed Oct 23 10:35:30 2013 +0200
Peval: Fold `thunk?' in more cases.
* module/language/tree-il/peval.scm (peval): Better folding of the
`thunk?' predicate.
commit 40553c2016298e84d01c09429eede129d2d8a53a
Author: Andy Wingo <address@hidden>
Date: Sat Oct 26 13:12:25 2013 +0200
Setting procedure properties does not cause metadata lookup
* libguile/procprop.c (scm_procedure_properties, scm_procedure_property)
(scm_set_procedure_properties_x, scm_set_procedure_property_x)
(scm_procedure_name, scm_procedure_documentation): Rework to treat the
overrides table as complementary to the RTL program properties. In
this way setting a procedure property doesn't require loading up
the (system vm debug) module.
commit 27ecfd3649dc6fbc5f512d3e95a8b8ac2139e2b9
Author: Andy Wingo <address@hidden>
Date: Sat Oct 26 13:10:43 2013 +0200
Evaluator sets same procedure properties as compiler
* libguile/memoize.c (MAKMEMO_LAMBDA, memoize): Instead of passing the
docstring in the memoized lambda, pass the meta as-is. That way we
get all procedure properties, including "name".
* module/ice-9/eval.scm (primitive-eval): Set procedure properties when
making lambdas. Don't set the name when defining toplevel variables
-- before we did so only if the procedure didn't have a name
property, but I would like to avoid calls to procedure-property in
eval, because getting the name for an RTL function requires loading up
other modules.
-----------------------------------------------------------------------
Summary of changes:
libguile/eval.c | 4 +-
libguile/memoize.c | 80 +++-------------
libguile/memoize.h | 10 +--
libguile/print.c | 3 +
libguile/procprop.c | 119 +++++++++++++++--------
libguile/strings.c | 17 ++++
libguile/strings.h | 2 +
libguile/tags.h | 5 +-
libguile/validate.h | 4 +-
libguile/vm-engine.c | 155 +++++++++++++++++++++++-------
module/Makefile.am | 2 +
module/ice-9/eval.scm | 20 ++--
module/language/cps/arities.scm | 72 +++++++++-----
module/language/cps/compile-rtl.scm | 52 +++++++++-
module/language/cps/constructors.scm | 98 +++++++++++++++++++
module/language/cps/dfg.scm | 9 ++
module/language/cps/elide-values.scm | 82 ++++++++++++++++
module/language/cps/primitives.scm | 7 +-
module/language/tree-il/compile-cps.scm | 23 ++---
module/language/tree-il/compile-glil.scm | 3 +-
module/language/tree-il/peval.scm | 20 +++--
module/language/tree-il/primitives.scm | 14 ++-
module/system/vm/assembler.scm | 31 ++++++
module/system/vm/disassembler.scm | 12 ++-
24 files changed, 612 insertions(+), 232 deletions(-)
create mode 100644 module/language/cps/constructors.scm
create mode 100644 module/language/cps/elide-values.scm
diff --git a/libguile/eval.c b/libguile/eval.c
index 36199a6..43a182a 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -266,11 +266,9 @@ eval (SCM x, SCM env)
loop:
SCM_TICK;
- if (!SCM_MEMOIZED_P (x))
- abort ();
mx = SCM_MEMOIZED_ARGS (x);
- switch (SCM_MEMOIZED_TAG (x))
+ switch (SCM_I_INUM (SCM_CAR (x)))
{
case SCM_M_SEQ:
eval (CAR (mx), env);
diff --git a/libguile/memoize.c b/libguile/memoize.c
index f54feb0..6eb36d4 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -109,7 +109,7 @@ do_pop_fluid (void)
scm_t_bits scm_tc16_memoized;
#define MAKMEMO(n, args) \
- (scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args)))
+ (scm_cons (SCM_I_MAKINUM (n), args))
#define MAKMEMO_SEQ(head,tail) \
MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
@@ -122,9 +122,9 @@ scm_t_bits scm_tc16_memoized;
#define FULL_ARITY(nreq, rest, nopt, kw, inits, alt) \
scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \
alt, SCM_UNDEFINED)
-#define MAKMEMO_LAMBDA(body, arity, docstring) \
+#define MAKMEMO_LAMBDA(body, arity, meta) \
MAKMEMO (SCM_M_LAMBDA, \
- scm_cons (body, scm_cons (docstring, arity)))
+ scm_cons (body, scm_cons (meta, arity)))
#define MAKMEMO_LET(inits, body) \
MAKMEMO (SCM_M_LET, scm_cons (inits, body))
#define MAKMEMO_QUOTE(exp) \
@@ -179,15 +179,6 @@ static const char *const memoized_tags[] =
"call-with-prompt",
};
-static int
-scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
-{
- scm_puts_unlocked ("#<memoized ", port);
- scm_write (scm_unmemoize_expression (memoized), port);
- scm_puts_unlocked (">", port);
- return 1;
-}
-
@@ -367,10 +358,9 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case or #f. */
{
- SCM meta, docstring, body, proc;
+ SCM meta, body, proc;
meta = REF (exp, LAMBDA, META);
- docstring = scm_assoc_ref (meta, scm_sym_documentation);
body = REF (exp, LAMBDA, BODY);
if (scm_is_false (body))
@@ -388,15 +378,12 @@ memoize (SCM exp, SCM env)
MAKMEMO_QUOTE (SCM_EOL),
MAKMEMO_QUOTE (SCM_BOOL_F))),
FIXED_ARITY (0),
- SCM_BOOL_F /* docstring */);
+ meta);
else
- proc = memoize (body, env);
-
- if (scm_is_string (docstring))
- {
- SCM args = SCM_MEMOIZED_ARGS (proc);
- SCM_SETCAR (SCM_CDR (args), docstring);
- }
+ {
+ proc = memoize (body, env);
+ SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
+ }
return proc;
}
@@ -460,7 +447,7 @@ memoize (SCM exp, SCM env)
arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
- SCM_BOOL_F /* docstring */);
+ SCM_BOOL_F /* meta, filled in later */);
}
case SCM_EXPANDED_LET:
@@ -605,9 +592,6 @@ unmemoize (const SCM expr)
{
SCM args;
- if (!SCM_MEMOIZED_P (expr))
- abort ();
-
args = SCM_MEMOIZED_ARGS (expr);
switch (SCM_MEMOIZED_TAG (expr))
{
@@ -710,47 +694,15 @@ unmemoize (const SCM expr)
-SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is memoized.")
-#define FUNC_NAME s_scm_memoized_p
-{
- return scm_from_bool (SCM_MEMOIZED_P (obj));
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0,
(SCM m),
"Unmemoize the memoized expression @var{m}.")
#define FUNC_NAME s_scm_unmemoize_expression
{
- SCM_VALIDATE_MEMOIZED (1, m);
return unmemoize (m);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_memoized_expression_typecode, "memoized-expression-typecode",
1, 0, 0,
- (SCM m),
- "Return the typecode from the memoized expression @var{m}.")
-#define FUNC_NAME s_scm_memoized_expression_typecode
-{
- SCM_VALIDATE_MEMOIZED (1, m);
-
- /* The tag is a 16-bit integer so it fits in an inum. */
- return SCM_I_MAKINUM (SCM_MEMOIZED_TAG (m));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_memoized_expression_data, "memoized-expression-data", 1, 0, 0,
- (SCM m),
- "Return the data from the memoized expression @var{m}.")
-#define FUNC_NAME s_scm_memoized_expression_data
-{
- SCM_VALIDATE_MEMOIZED (1, m);
- return SCM_MEMOIZED_ARGS (m);
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0,
(SCM sym),
"Return the memoized typecode corresponding to the symbol
@var{sym}.")
@@ -781,9 +733,8 @@ SCM_DEFINE (scm_memoize_variable_access_x,
"memoize-variable-access!", 2, 0, 0,
"Look up and cache the variable that @var{m} will access, returning
the variable.")
#define FUNC_NAME s_scm_memoize_variable_access_x
{
- SCM mx;
- SCM_VALIDATE_MEMOIZED (1, m);
- mx = SCM_MEMOIZED_ARGS (m);
+ SCM mx = SCM_MEMOIZED_ARGS (m);
+
switch (SCM_MEMOIZED_TAG (m))
{
case SCM_M_TOPLEVEL_REF:
@@ -794,7 +745,7 @@ SCM_DEFINE (scm_memoize_variable_access_x,
"memoize-variable-access!", 2, 0, 0,
SCM var = scm_module_variable (mod, mx);
if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
error_unbound_variable (mx);
- SCM_SET_SMOB_OBJECT (m, var);
+ SCM_SETCDR (m, var);
return var;
}
@@ -825,7 +776,7 @@ SCM_DEFINE (scm_memoize_variable_access_x,
"memoize-variable-access!", 2, 0, 0,
var = scm_module_lookup (mod, CADR (mx));
if (scm_is_false (scm_variable_bound_p (var)))
error_unbound_variable (CADR (mx));
- SCM_SET_SMOB_OBJECT (m, var);
+ SCM_SETCDR (m, var);
return var;
}
@@ -857,9 +808,6 @@ SCM_DEFINE (scm_memoize_variable_access_x,
"memoize-variable-access!", 2, 0, 0,
void
scm_init_memoize ()
{
- scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
- scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
-
#include "libguile/memoize.x"
wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
diff --git a/libguile/memoize.h b/libguile/memoize.h
index 7f7624f..95e92a3 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -58,11 +58,8 @@ SCM_API SCM scm_sym_args;
/* {Memoized Source}
*/
-SCM_INTERNAL scm_t_bits scm_tc16_memoized;
-
-#define SCM_MEMOIZED_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoized, (x)))
-#define SCM_MEMOIZED_TAG(x) (SCM_SMOB_FLAGS (x))
-#define SCM_MEMOIZED_ARGS(x) (SCM_SMOB_OBJECT (x))
+#define SCM_MEMOIZED_TAG(x) (scm_to_uint16 (scm_car (x)))
+#define SCM_MEMOIZED_ARGS(x) (scm_cdr (x))
enum
{
@@ -90,11 +87,8 @@ enum
SCM_INTERNAL SCM scm_memoize_expression (SCM exp);
SCM_INTERNAL SCM scm_unmemoize_expression (SCM memoized);
-SCM_INTERNAL SCM scm_memoized_expression_typecode (SCM memoized);
-SCM_INTERNAL SCM scm_memoized_expression_data (SCM memoized);
SCM_INTERNAL SCM scm_memoized_typecode (SCM sym);
SCM_INTERNAL SCM scm_memoize_variable_access_x (SCM memoized, SCM module);
-SCM_API SCM scm_memoized_p (SCM obj);
SCM_INTERNAL void scm_init_memoize (void);
diff --git a/libguile/print.c b/libguile/print.c
index dbc6e96..a77f1a8 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -609,6 +609,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
break;
}
break;
+ case scm_tc7_stringbuf:
+ scm_i_print_stringbuf (exp, port, pstate);
+ break;
case scm_tc7_string:
if (SCM_WRITINGP (pstate))
{
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 2d9e655..78a40c1 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -136,22 +136,28 @@ SCM_DEFINE (scm_procedure_properties,
"procedure-properties", 1, 0, 0,
"Return @var{proc}'s property list.")
#define FUNC_NAME s_scm_procedure_properties
{
- SCM ret;
+ SCM ret, user_props;
SCM_VALIDATE_PROC (1, proc);
- ret = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+
+ if (scm_is_pair (user_props) && scm_is_true (scm_car (user_props)))
+ return scm_cdr (user_props);
+
+ if (SCM_PROGRAM_P (proc))
+ ret = scm_i_program_properties (proc);
+ else if (SCM_RTL_PROGRAM_P (proc))
+ ret = scm_i_rtl_program_properties (proc);
+ else
+ ret = SCM_EOL;
+
+ if (scm_is_pair (user_props))
+ for (user_props = scm_cdr (user_props);
+ scm_is_pair (user_props);
+ user_props = scm_cdr (user_props))
+ ret = scm_assq_set_x (ret, scm_caar (user_props), scm_cdar (user_props));
- if (scm_is_false (ret))
- {
- if (SCM_PROGRAM_P (proc))
- ret = scm_i_program_properties (proc);
- else if (SCM_RTL_PROGRAM_P (proc))
- ret = scm_i_rtl_program_properties (proc);
- else
- ret = SCM_EOL;
- }
-
return ret;
}
#undef FUNC_NAME
@@ -163,7 +169,7 @@ SCM_DEFINE (scm_set_procedure_properties_x,
"set-procedure-properties!", 2, 0, 0
{
SCM_VALIDATE_PROC (1, proc);
- scm_weak_table_putq_x (overrides, proc, alist);
+ scm_weak_table_putq_x (overrides, proc, scm_cons (SCM_BOOL_T, alist));
return SCM_UNSPECIFIED;
}
@@ -174,8 +180,25 @@ SCM_DEFINE (scm_procedure_property, "procedure-property",
2, 0, 0,
"Return the property of @var{proc} with name @var{key}.")
#define FUNC_NAME s_scm_procedure_property
{
+ SCM user_props;
+
SCM_VALIDATE_PROC (1, proc);
+ if (scm_is_eq (key, scm_sym_name))
+ return scm_procedure_name (proc);
+ if (scm_is_eq (key, scm_sym_documentation))
+ return scm_procedure_documentation (proc);
+
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_true (user_props))
+ {
+ SCM pair = scm_assq (key, scm_cdr (user_props));
+ if (scm_is_pair (pair))
+ return scm_cdr (pair);
+ if (scm_is_true (scm_car (user_props)))
+ return SCM_BOOL_F;
+ }
+
return scm_assq_ref (scm_procedure_properties (proc), key);
}
#undef FUNC_NAME
@@ -186,20 +209,25 @@ SCM_DEFINE (scm_set_procedure_property_x,
"set-procedure-property!", 3, 0, 0,
"@var{val}.")
#define FUNC_NAME s_scm_set_procedure_property_x
{
- SCM props;
+ SCM user_props, override_p;
SCM_VALIDATE_PROC (1, proc);
scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
- props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
- if (scm_is_false (props))
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_false (user_props))
{
- if (SCM_PROGRAM_P (proc))
- props = scm_i_program_properties (proc);
- else
- props = SCM_EOL;
+ override_p = SCM_BOOL_F;
+ user_props = SCM_EOL;
}
- scm_weak_table_putq_x (overrides, proc, scm_assq_set_x (props, key, val));
+ else
+ {
+ override_p = scm_car (user_props);
+ user_props = scm_cdr (user_props);
+ }
+ scm_weak_table_putq_x (overrides, proc,
+ scm_cons (override_p,
+ scm_assq_set_x (user_props, key, val)));
scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
return SCM_UNSPECIFIED;
@@ -217,25 +245,29 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
"Return the name of the procedure @var{proc}")
#define FUNC_NAME s_scm_procedure_name
{
- SCM props, ret;
+ SCM user_props;
SCM_VALIDATE_PROC (1, proc);
while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
proc = SCM_STRUCT_PROCEDURE (proc);
- props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_true (user_props))
+ {
+ SCM pair = scm_assq (scm_sym_name, scm_cdr (user_props));
+ if (scm_is_pair (pair))
+ return scm_cdr (pair);
+ if (scm_is_true (scm_car (user_props)))
+ return SCM_BOOL_F;
+ }
- if (scm_is_pair (props))
- ret = scm_assq_ref (props, scm_sym_name);
- else if (SCM_RTL_PROGRAM_P (proc))
- ret = scm_i_rtl_program_name (proc);
+ if (SCM_RTL_PROGRAM_P (proc))
+ return scm_i_rtl_program_name (proc);
else if (SCM_PROGRAM_P (proc))
- ret = scm_assq_ref (scm_i_program_properties (proc), scm_sym_name);
+ return scm_assq_ref (scm_i_program_properties (proc), scm_sym_name);
else
- ret = SCM_BOOL_F;
-
- return ret;
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -250,25 +282,30 @@ SCM_DEFINE (scm_procedure_documentation,
"procedure-documentation", 1, 0, 0,
"documentation for that procedure.")
#define FUNC_NAME s_scm_procedure_documentation
{
- SCM props, ret;
+ SCM user_props;
SCM_VALIDATE_PROC (1, proc);
while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
proc = SCM_STRUCT_PROCEDURE (proc);
- props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_true (user_props))
+ {
+ SCM pair = scm_assq (scm_sym_documentation, scm_cdr (user_props));
+ if (scm_is_pair (pair))
+ return scm_cdr (pair);
+ if (scm_is_true (scm_car (user_props)))
+ return SCM_BOOL_F;
+ }
- if (scm_is_pair (props))
- ret = scm_assq_ref (props, scm_sym_documentation);
- else if (SCM_RTL_PROGRAM_P (proc))
- ret = scm_i_rtl_program_documentation (proc);
+ if (SCM_RTL_PROGRAM_P (proc))
+ return scm_i_rtl_program_documentation (proc);
else if (SCM_PROGRAM_P (proc))
- ret = scm_assq_ref (scm_i_program_properties (proc),
scm_sym_documentation);
+ return scm_assq_ref (scm_i_program_properties (proc),
+ scm_sym_documentation);
else
- ret = SCM_BOOL_F;
-
- return ret;
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
diff --git a/libguile/strings.c b/libguile/strings.c
index 8ee909b..1f492bd 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -261,6 +261,23 @@ scm_i_pthread_mutex_t stringbuf_write_mutex =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
+void
+scm_i_print_stringbuf (SCM exp, SCM port, scm_print_state *pstate)
+{
+ SCM str;
+
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
+ SET_STRINGBUF_SHARED (exp);
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
+
+ str = scm_double_cell (RO_STRING_TAG, SCM_UNPACK(exp),
+ 0, STRINGBUF_LENGTH (exp));
+
+ scm_puts ("#<stringbuf ", port);
+ scm_iprin1 (str, port, pstate);
+ scm_puts (">", port);
+}
+
SCM scm_nullstr;
/* Create a scheme string with space for LEN 8-bit Latin-1-encoded
diff --git a/libguile/strings.h b/libguile/strings.h
index 445d9c8..130c436 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -179,6 +179,8 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv);
#define SCM_I_STRINGBUF_F_SHARED 0x100
#define SCM_I_STRINGBUF_F_WIDE 0x400
+SCM_INTERNAL void scm_i_print_stringbuf (SCM exp, SCM port,
+ scm_print_state *pstate);
/* internal accessor functions. Arguments must be valid. */
diff --git a/libguile/tags.h b/libguile/tags.h
index 234d4c7..9e6943e 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -3,7 +3,7 @@
#ifndef SCM_TAGS_H
#define SCM_TAGS_H
-/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
+/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -402,6 +402,9 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
#define SCM_HAS_TYP7(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag))
#define SCM_HAS_TYP7S(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7S, tag))
+/* If you change these numbers, change them also in (system vm
+ assembler). */
+
#define scm_tc7_symbol 5
#define scm_tc7_variable 7
diff --git a/libguile/validate.h b/libguile/validate.h
index b4d5441..68ff374 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -4,7 +4,7 @@
#define SCM_VALIDATE_H
/* Copyright (C) 1999, 2000, 2001, 2002, 2004, 2006, 2007, 2009,
- * 2011, 2012 Free Software Foundation, Inc.
+ * 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
@@ -293,8 +293,6 @@
#define SCM_VALIDATE_VARIABLE(pos, var) SCM_MAKE_VALIDATE_MSG (pos, var,
VARIABLEP, "variable")
-#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj,
MEMOIZED_P, "memoized code")
-
#define SCM_VALIDATE_PROC(pos, proc) \
do { \
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, pos, FUNC_NAME); \
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index cf359c9..548dc4e 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1839,7 +1839,8 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
SCM var;
SCM_UNPACK_RTL_12_12 (op, dst, src);
var = LOCAL_REF (src);
- VM_ASSERT (SCM_VARIABLEP (var), abort ());
+ VM_ASSERT (SCM_VARIABLEP (var),
+ vm_error_not_a_variable ("variable-ref", var));
VM_ASSERT (VARIABLE_BOUNDP (var),
vm_error_unbound (SCM_FRAME_PROGRAM (fp), var));
LOCAL_SET (dst, VARIABLE_REF (var));
@@ -1856,7 +1857,8 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
SCM var;
SCM_UNPACK_RTL_12_12 (op, dst, src);
var = LOCAL_REF (dst);
- VM_ASSERT (SCM_VARIABLEP (var), abort ());
+ VM_ASSERT (SCM_VARIABLEP (var),
+ vm_error_not_a_variable ("variable-set!", var));
VARIABLE_SET (var, LOCAL_REF (src));
NEXT (1);
}
@@ -2220,6 +2222,11 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
mod = *((SCM *) mod_loc);
sym = *((SCM *) sym_loc);
+ /* If the toplevel scope was captured before modules were
+ booted, use the root module. */
+ if (scm_is_false (mod))
+ mod = scm_the_root_module ();
+
var = scm_module_lookup (mod, sym);
if (ip[4] & 0x1)
VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
@@ -2267,7 +2274,18 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
modname = SCM_PACK ((scm_t_bits) modname_words);
sym = *((SCM *) sym_loc);
- if (scm_is_true (SCM_CAR (modname)))
+ if (!scm_module_system_booted_p)
+ {
+#ifdef VM_ENABLE_PARANOID_ASSERTIONS
+ ASSERT
+ (scm_is_true
+ scm_equal_p (modname,
+ scm_list_2 (SCM_BOOL_T,
+ scm_from_utf8_symbol ("guile"))));
+#endif
+ var = scm_lookup (sym);
+ }
+ else if (scm_is_true (SCM_CAR (modname)))
var = scm_public_lookup (SCM_CDR (modname), sym);
else
var = scm_private_lookup (SCM_CDR (modname), sym);
@@ -2386,7 +2404,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
SCM_UNPACK_RTL_12_12 (op, fluid, value);
scm_dynstack_push_fluid (¤t_thread->dynstack,
- fp[fluid], fp[value],
+ LOCAL_REF (fluid), LOCAL_REF (value),
current_thread->dynamic_state);
NEXT (1);
}
@@ -2829,11 +2847,49 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
RETURN (scm_logxor (x, y));
}
+ /* make-vector dst:8 length:8 init:8
+ *
+ * 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)
+ {
+ scm_t_uint8 dst, length, init;
+
+ SCM_UNPACK_RTL_8_8_8 (op, dst, length, init);
+
+ LOCAL_SET (dst, scm_make_vector (LOCAL_REF (length), LOCAL_REF (init)));
+
+ NEXT (1);
+ }
+
+ /* constant-make-vector dst:8 length:8 init:8
+ *
+ * Make a short vector of known size and write it to DST. The vector
+ * 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)
+ {
+ scm_t_uint8 dst, init;
+ scm_t_int32 length, n;
+ SCM val, vector;
+
+ SCM_UNPACK_RTL_8_8_8 (op, dst, length, init);
+
+ val = LOCAL_REF (init);
+ vector = scm_words (scm_tc7_vector | (length << 8), length + 1);
+ for (n = 0; n < length; n++)
+ SCM_SIMPLE_VECTOR_SET (vector, n, val);
+ LOCAL_SET (dst, vector);
+ NEXT (1);
+ }
+
/* vector-length dst:12 src:12
*
* Store the length of the vector in SRC in DST.
*/
- VM_DEFINE_OP (89, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (91, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
@@ -2850,7 +2906,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 (90, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (92, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
@@ -2871,7 +2927,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 (91, constant_vector_ref, "constant-vector-ref", OP1
(U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (93, constant_vector_ref, "constant-vector-ref", OP1
(U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM v;
@@ -2890,7 +2946,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 (92, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (94, vector_set, "vector-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx_var, src;
SCM vect, idx, val;
@@ -2914,6 +2970,31 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (1);
}
+ /* constant-vector-set! dst:8 idx:8 src:8
+ *
+ * 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))
+ {
+ scm_t_uint8 dst, idx, src;
+ SCM vect, val;
+
+ SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
+ vect = LOCAL_REF (dst);
+ val = LOCAL_REF (src);
+
+ if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
+ && idx < SCM_I_VECTOR_LENGTH (vect)))
+ SCM_I_VECTOR_WELTS (vect)[idx] = val;
+ else
+ {
+ SYNC_IP ();
+ scm_vector_set_x (vect, scm_from_uint8 (idx), val);
+ }
+ NEXT (1);
+ }
+
@@ -2925,7 +3006,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (93, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (96, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable");
@@ -2938,7 +3019,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 (94, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) |
OP_DST)
+ VM_DEFINE_OP (97, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) |
OP_DST)
{
scm_t_uint8 dst, vtable, nfields;
SCM ret;
@@ -2957,7 +3038,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 (95, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (98, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (obj, pos);
@@ -2991,7 +3072,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 (96, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (99, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
SCM obj, pos, val;
@@ -3032,7 +3113,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (97, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (100, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
@@ -3047,7 +3128,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 (98, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (101, 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);
@@ -3061,7 +3142,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 (99, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (102, 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);
@@ -3082,7 +3163,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 (100, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8,
N32, U32) | OP_DST)
+ VM_DEFINE_OP (103, 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;
@@ -3102,7 +3183,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 (101, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) |
OP_DST)
+ VM_DEFINE_OP (104, 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);
@@ -3200,42 +3281,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 (102, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (105, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
- VM_DEFINE_OP (103, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (106, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FIXABLE_INT_REF (s8, s8, int8, 1);
- VM_DEFINE_OP (104, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (107, 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 (105, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (108, 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 (106, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (109, 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 (107, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (110, 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 (108, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (111, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (u64, uint64, 8);
- VM_DEFINE_OP (109, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (112, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_INT_REF (s64, int64, 8);
- VM_DEFINE_OP (110, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (113, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
BV_FLOAT_REF (f32, ieee_single, float, 4);
- VM_DEFINE_OP (111, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (114, 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
@@ -3339,42 +3420,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
NEXT (1); \
} while (0)
- VM_DEFINE_OP (112, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (115, 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 (113, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (116, 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 (114, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (117, 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 (115, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (118, 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 (116, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (119, 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 (117, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (120, 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 (118, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (121, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (u64, uint64, 8);
- VM_DEFINE_OP (119, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (122, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
BV_INT_SET (s64, int64, 8);
- VM_DEFINE_OP (120, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (123, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f32, ieee_single, float, 4);
- VM_DEFINE_OP (121, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (124, 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/Makefile.am b/module/Makefile.am
index b3e573b..7b740b8 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -123,8 +123,10 @@ CPS_LANG_SOURCES =
\
language/cps/arities.scm \
language/cps/closure-conversion.scm \
language/cps/compile-rtl.scm \
+ language/cps/constructors.scm \
language/cps/contification.scm \
language/cps/dfg.scm \
+ language/cps/elide-values.scm \
language/cps/primitives.scm \
language/cps/reify-primitives.scm \
language/cps/slot-allocation.scm \
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 1d02707..ed51039 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -264,8 +264,8 @@
(lambda (x)
(syntax-case x ()
((_ mx c ...)
- #'(let ((tag (memoized-expression-typecode mx))
- (data (memoized-expression-data mx)))
+ #'(let ((tag (car mx))
+ (data (cdr mx)))
(mx-match mx data tag c ...)))))))
@@ -308,7 +308,7 @@
;; multiple arities, as with case-lambda.
(define (make-general-closure env body nreq rest? nopt kw inits alt)
(define alt-proc
- (and alt ; (body docstring nreq ...)
+ (and alt ; (body meta nreq ...)
(let* ((body (car alt))
(spec (cddr alt))
(nreq (car spec))
@@ -479,7 +479,7 @@
(lp (1+ i))))
(eval body new-env)))
- (('lambda (body docstring nreq . tail))
+ (('lambda (body meta nreq . tail))
(let ((proc
(if (null? tail)
(make-fixed-closure eval nreq body (capture-env env))
@@ -487,8 +487,10 @@
(make-rest-closure eval nreq body (capture-env env))
(apply make-general-closure (capture-env env)
body nreq tail)))))
- (when docstring
- (set-procedure-property! proc 'documentation docstring))
+ (let lp ((meta meta))
+ (unless (null? meta)
+ (set-procedure-property! proc (caar meta) (cdar meta))
+ (lp (cdr meta))))
proc))
(('seq (head . tail))
@@ -513,10 +515,8 @@
(memoize-variable-access! exp #f))))
(('define (name . x))
- (let ((x (eval x env)))
- (if (and (procedure? x) (not (procedure-property x 'name)))
- (set-procedure-property! x 'name name))
- (define! name x)
+ (begin
+ (define! name (eval x env))
(if #f #f)))
(('toplevel-set! (var-or-sym . x))
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index b697ec0..8777502 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -58,8 +58,20 @@
(kvoid #f ($kargs () ()
($continue kunspec ($void)))))
($continue kvoid ,exp)))))
- (($ $ktrunc ($ $arity () () #f () #f) kseq)
- ($continue kseq ,exp))
+ (($ $ktrunc arity kargs)
+ ,(rewrite-cps-term arity
+ (($ $arity () () #f () #f)
+ ($continue kargs ,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)))))))
(($ $kargs () () _)
($continue k ,exp))
(_
@@ -68,31 +80,37 @@
($letk ((k* #f ($kargs () () ($continue k ($void)))))
($continue k* ,exp)))))))
(1
- (let ((drop-result
- (lambda (kseq)
- (let-gensyms (k* drop)
- (build-cps-term
- ($letk ((k* #f ($kargs ('drop) (drop)
- ($continue kseq ($values ())))))
- ($continue k* ,exp)))))))
- (rewrite-cps-term (lookup-cont k conts)
- (($ $ktail)
- ,(rewrite-cps-term exp
- (($var sym)
- ($continue ktail ($primcall 'return (sym))))
- (_
- ,(let-gensyms (k* v)
- (build-cps-term
- ($letk ((k* #f ($kargs (v) (v)
- ($continue k
- ($primcall 'return (v))))))
- ($continue k* ,exp)))))))
- (($ $ktrunc ($ $arity () () #f () #f) kseq)
- ,(drop-result kseq))
- (($ $kargs () () _)
- ,(drop-result k))
- (_
- ($continue k ,exp)))))))
+ (rewrite-cps-term (lookup-cont k conts)
+ (($ $ktail)
+ ,(rewrite-cps-term exp
+ (($var sym)
+ ($continue ktail ($primcall 'return (sym))))
+ (_
+ ,(let-gensyms (k* v)
+ (build-cps-term
+ ($letk ((k* #f ($kargs (v) (v)
+ ($continue k
+ ($primcall 'return (v))))))
+ ($continue k* ,exp)))))))
+ (($ $ktrunc arity kargs)
+ ,(rewrite-cps-term arity
+ (($ $arity (_) () #f () #f)
+ ($continue kargs ,exp))
+ (_
+ ,(let-gensyms (kvalues value)
+ (build-cps-term
+ ($letk ((kvalues #f ($kargs ('value) (value)
+ ($continue k
+ ($primcall 'values (value))))))
+ ($continue kvalues ,exp)))))))
+ (($ $kargs () () _)
+ ,(let-gensyms (k* drop)
+ (build-cps-term
+ ($letk ((k* #f ($kargs ('drop) (drop)
+ ($continue k ($values ())))))
+ ($continue k* ,exp)))))
+ (_
+ ($continue k ,exp))))))
(define (visit-exp k exp)
(rewrite-cps-term exp
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index 163458e..341b715 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -30,7 +30,9 @@
#:use-module (language cps arities)
#:use-module (language cps closure-conversion)
#:use-module (language cps contification)
+ #:use-module (language cps constructors)
#:use-module (language cps dfg)
+ #:use-module (language cps elide-values)
#:use-module (language cps primitives)
#:use-module (language cps reify-primitives)
#:use-module (language cps slot-allocation)
@@ -52,7 +54,9 @@
exp))
;; Calls to source-to-source optimization passes go here.
- (let* ((exp (run-pass exp contify #:contify? #t)))
+ (let* ((exp (run-pass exp contify #:contify? #t))
+ (exp (run-pass exp inline-constructors #:inline-constructors? #t))
+ (exp (run-pass exp elide-values #:elide-values? #t)))
;; Passes that are needed:
;;
;; * Abort contification: turning abort primcalls into continuation
@@ -97,6 +101,15 @@
(_ (values))))
(define (emit-rtl-sequence asm exp allocation nlocals cont-table)
+ (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 (slot sym)
(lookup-slot sym allocation))
@@ -184,6 +197,20 @@
(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)))
@@ -215,7 +242,17 @@
(($ $primcall 'struct-set! (struct index value))
(emit-struct-set! asm (slot struct) (slot index) (slot value)))
(($ $primcall 'vector-set! (vector index value))
- (emit-vector-set asm (slot vector) (slot index) (slot value)))
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value index allocation))
+ (lambda (has-const? index-val)
+ (if (and has-const? (integer? index-val) (exact? index-val)
+ (<= 0 index-val 255))
+ (emit-constant-vector-set! asm (slot vector) index-val
+ (slot value))
+ (emit-vector-set! asm (slot vector) (slot index)
+ (slot value))))))
+ (($ $primcall 'variable-set! (var val))
+ (emit-box-set! asm (slot var) (slot val)))
(($ $primcall 'set-car! (pair value))
(emit-set-car! asm (slot pair) (slot value)))
(($ $primcall 'set-cdr! (pair value))
@@ -226,6 +263,8 @@
(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 'unwind ())
(emit-unwind asm))
(($ $primcall name args)
@@ -272,8 +311,13 @@
(($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
(($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
(($ $primcall 'char? (a)) (unary emit-br-if-char a))
- ;; Add TC7 tests here
- (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+ (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
+ (($ $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))
+ ;; 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.
(($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
(($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
(($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
diff --git a/module/language/cps/constructors.scm
b/module/language/cps/constructors.scm
new file mode 100644
index 0000000..b8d4e96
--- /dev/null
+++ b/module/language/cps/constructors.scm
@@ -0,0 +1,98 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+
+;;; Commentary:
+;;;
+;;; Constructor inlining turns "list" primcalls into a series of conses,
+;;; and does similar transformations for "vector".
+;;;
+;;; Code:
+
+(define-module (language cps constructors)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:export (inline-constructors))
+
+(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)
+ ,cont)))
+ (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 inline-constructors funs)
+ ,(visit-term body)))
+ (($ $continue k ($ $primcall 'list args))
+ ,(let-gensyms (kvalues val)
+ (build-cps-term
+ ($letk ((kvalues #f ($kargs ('val) (val)
+ ($continue k
+ ($primcall 'values (val))))))
+ ,(let lp ((args args) (k kvalues))
+ (match args
+ (()
+ (build-cps-term
+ ($continue k ($const '()))))
+ ((arg . args)
+ (let-gensyms (ktail tail)
+ (build-cps-term
+ ($letk ((ktail #f ($kargs ('tail) (tail)
+ ($continue k
+ ($primcall 'cons (arg tail))))))
+ ,(lp args ktail)))))))))))
+ (($ $continue k ($ $primcall 'vector args))
+ ,(let-gensyms (kalloc vec len init)
+ (define (initialize args n)
+ (match args
+ (()
+ (build-cps-term
+ ($continue k ($primcall 'values (vec)))))
+ ((arg . args)
+ (let-gensyms (knext idx)
+ (build-cps-term
+ ($letk ((knext #f ($kargs () ()
+ ,(initialize args (1+ n)))))
+ ($letconst (('idx idx n))
+ ($continue knext
+ ($primcall 'vector-set! (vec idx arg))))))))))
+ (build-cps-term
+ ($letk ((kalloc #f ($kargs ('vec) (vec)
+ ,(initialize args 0))))
+ ($letconst (('len len (length args))
+ ('init init #f))
+ ($continue kalloc
+ ($primcall 'make-vector (len init))))))))
+ (($ $continue k (and fun ($ $fun)))
+ ($continue k ,(inline-constructors fun)))
+ (($ $continue)
+ ,term)))
+
+ (rewrite-cps-exp fun
+ (($ $fun meta free body)
+ ($fun meta free ,(visit-cont body)))))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index e56c986..ec558e9 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -775,6 +775,9 @@
(values #f #f))))
(define (constant-needs-allocation? sym val dfg)
+ (define (immediate-u8? val)
+ (and (integer? val) (exact? val) (<= 0 val 255)))
+
(define (find-exp term)
(match term
(($ $kargs names syms body) (find-exp body))
@@ -801,6 +804,12 @@
#f)
(($ $primcall 'resolve (name bound?))
(eq? sym name))
+ (($ $primcall 'make-vector (len init))
+ (not (and (eq? sym len) (immediate-u8? val))))
+ (($ $primcall 'vector-ref (v i))
+ (not (and (eq? sym i) (immediate-u8? val))))
+ (($ $primcall 'vector-set! (v i x))
+ (not (and (eq? sym i) (immediate-u8? val))))
(_ #t)))
uses))))))
diff --git a/module/language/cps/elide-values.scm
b/module/language/cps/elide-values.scm
new file mode 100644
index 0000000..b738b1c
--- /dev/null
+++ b/module/language/cps/elide-values.scm
@@ -0,0 +1,82 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+
+;;; Commentary:
+;;;
+;;; Primcalls that don't correspond to VM instructions are treated as if
+;;; they are calls, and indeed the later reify-primitives pass turns
+;;; them into calls. Because no return arity checking is done for these
+;;; primitives, if a later optimization pass simplifies the primcall to
+;;; an RTL operation, the tail of the simplification has to be a
+;;; primcall to 'values. Most of these primcalls can be elided, and
+;;; that is the job of this pass.
+;;;
+;;; Code:
+
+(define-module (language cps elide-values)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:export (elide-values))
+
+(define (elide-values fun)
+ (let ((conts (build-local-cont-table
+ (match fun (($ $fun 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)
+ ,cont)))
+ (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 elide-values funs)
+ ,(visit-term body)))
+ (($ $continue k ($ $primcall 'values vals))
+ ,(rewrite-cps-term (lookup-cont k conts)
+ (($ $ktail)
+ ($continue k ($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))))))
+ (($ $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)
+ ,term)))
+
+ (rewrite-cps-exp fun
+ (($ $fun meta free body)
+ ($fun meta free ,(visit-cont body))))))
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index 1c683e2..c258553 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -39,7 +39,8 @@
(quotient . quo) (remainder . rem)
(modulo . mod)
(define! . define)
- (vector-set! . vector-set)))
+ (variable-ref . box-ref)
+ (variable-set! . box-set!)))
(define *macro-instruction-arities*
'((cache-current-module! . (0 . 2))
@@ -51,6 +52,10 @@
(nil? . (1 . 1))
(pair? . (1 . 1))
(struct? . (1 . 1))
+ (string? . (1 . 1))
+ (vector? . (1 . 1))
+ (symbol? . (1 . 1))
+ (variable? . (1 . 1))
(char? . (1 . 1))
(eq? . (1 . 2))
(eqv? . (1 . 2))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 6202e12..f26b188 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -332,22 +332,13 @@
(build-cps-term ($continue k ($call proc args)))))))
(($ <primcall> src name args)
- (case name
- ((list)
- (convert (fold-right (lambda (elem tail)
- (make-primcall src 'cons
- (list elem tail)))
- (make-const src '())
- args)
- k subst))
- (else
- (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)))))))))
+ (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)))))))
;; Prompts with inline handlers.
(($ <prompt> src escape-only? tag body
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 34855b9..60df245 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -595,8 +595,7 @@
((<primitive-ref> src name)
(cond
- ((eq? (module-variable (fluid-ref *comp-module*) name)
- (module-variable the-root-module name))
+ ((eq? (fluid-ref *comp-module*) the-root-module)
(case context
((tail push vals)
(emit-code src (make-glil-toplevel 'ref name))))
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index f3c0161..676ac89 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1251,13 +1251,19 @@ top-level bindings from ENV and return the resulting
expression."
(make-primcall src name args))))))
(($ <primcall> src 'thunk? (proc))
- (match (for-value proc)
- (($ <lambda> _ _ ($ <lambda-case> _ req))
- (for-tail (make-const src (null? req))))
- (proc
- (case ctx
- ((effect) (make-void src))
- (else (make-primcall src 'thunk? (list proc)))))))
+ (case ctx
+ ((effect)
+ (for-tail (make-seq src proc (make-void src))))
+ (else
+ (match (for-value proc)
+ (($ <lambda> _ _ ($ <lambda-case> _ req))
+ (for-tail (make-const src (null? req))))
+ (proc
+ (match (find-definition proc 2)
+ (($ <lambda> _ _ ($ <lambda-case> _ req))
+ (for-tail (make-const src (null? req))))
+ (_
+ (make-primcall src 'thunk? (list proc)))))))))
(($ <primcall> src (? accessor-primitive? name) args)
(match (cons name (map for-value args))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index c18d2b8..b56e54c 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -73,10 +73,12 @@
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-length vector-ref vector-set!
- variable-ref variable-set!
+ make-vector vector-length vector-ref vector-set!
+ variable? variable-ref variable-set!
variable-bound?
+ current-module
+
fluid-ref fluid-set! with-fluid*
call-with-prompt
@@ -129,7 +131,7 @@
(define *primitive-constructors*
;; Primitives that return a fresh object.
- '(acons cons cons* list vector make-struct make-struct/no-tail
+ '(acons cons cons* list vector make-vector make-struct make-struct/no-tail
make-prompt-tag))
(define *primitive-accessors*
@@ -157,7 +159,8 @@
ash logand logior logxor lognot
+ * - / 1- 1+ quotient remainder modulo
not
- pair? null? list? symbol? vector? struct? string? number? char? nil
+ pair? null? nil? list?
+ symbol? variable? vector? struct? string? number? char?
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
char<? char<=? char>=? char>?
integer->char char->integer number->string string->number
@@ -177,7 +180,8 @@
'(values
eq? eqv? equal?
not
- pair? null? list? symbol? vector? struct? string? number? char?
+ pair? null? nil? list?
+ symbol? variable? vector? struct? string? number? char?
procedure? thunk?
acons cons cons* list vector))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index f43acb3..749b693 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -638,6 +638,37 @@ returned instead."
(let ((loc (intern-constant asm (make-static-procedure label))))
(emit-make-non-immediate asm dst loc)))
+(define-syntax-rule (define-tc7-macro-assembler name tc7)
+ (define-macro-assembler (name asm slot invert? label)
+ (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.
+(define-tc7-macro-assembler br-if-symbol 5)
+(define-tc7-macro-assembler br-if-variable 7)
+(define-tc7-macro-assembler br-if-vector 13)
+;(define-tc7-macro-assembler br-if-weak-vector 13)
+(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-pointer 31)
+;(define-tc7-macro-assembler br-if-hashtable 29)
+;(define-tc7-macro-assembler br-if-fluid 37)
+;(define-tc7-macro-assembler br-if-dynamic-state 45)
+;(define-tc7-macro-assembler br-if-frame 47)
+;(define-tc7-macro-assembler br-if-objcode 53)
+;(define-tc7-macro-assembler br-if-vm 55)
+;(define-tc7-macro-assembler br-if-vm-cont 71)
+;(define-tc7-macro-assembler br-if-rtl-program 69)
+;(define-tc7-macro-assembler br-if-program 79)
+;(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-port 125)
+;(define-tc7-macro-assembler br-if-smob 127)
+
(define-macro-assembler (begin-program asm label properties)
(emit-label asm label)
(let ((meta (make-meta label properties (asm-start asm))))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 09ca337..a920923 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -214,9 +214,19 @@ address of that offset."
(((or 'br
'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
- 'br-if-char 'br-if-tc7 'br-if-eq 'br-if-eqv 'br-if-equal
+ 'br-if-char 'br-if-eq 'br-if-eqv 'br-if-equal
'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=) _ ... target)
(list "-> ~A" (vector-ref labels (- (+ offset target) start))))
+ (('br-if-tc7 slot invert? tc7 target)
+ (list "~A -> ~A"
+ (let ((tag (case tc7
+ ((5) "symbol?")
+ ((7) "variable?")
+ ((13) "vector?")
+ ((15) "string?")
+ (else (number->string tc7)))))
+ (if invert? (string-append "not " tag) tag))
+ (vector-ref labels (- (+ offset target) start))))
(('prompt tag escape-only? proc-slot handler)
;; The H is for handler.
(list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-290-g0720f70,
Andy Wingo <=