mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

Evaluator uses two-dimensional environment

Browse source 
* libguile/memoize.c (MAKMEMO_LEX_REF, MAKMEMO_LEX_SET): Change to
  address lexicals by depth and width.
  (try_lookup_rib, lookup_rib, make_pos): New helpers.
  (lookup): Adapt to return a pair.
  (memoize, unmemoize_bindings, unmemoize_lexical): Adapt.

* libguile/eval.c (eval, prepare_boot_closure_env_for_eval):
  (prepare_boot_closure_env_for_apply):
* module/ice-9/eval.scm (make-fixed-closure, make-general-closure)
  (eval): Adapt to new environment.

This is currently a slight win for C, and a slight lose for Scheme --
because the lookup loop is so poorly compiled by the stack VM.  I expect
that the RTL-compiled eval will fix this.
This commit is contained in:
Andy Wingo 2013-10-25 12:25:53 +02:00
parent 33e9a90d7b
commit cfc28c808e
3 changed files with 425 additions and 338 deletions
Download patch file Download diff file Expand all files Collapse all files

236
libguile/eval.c
View file

@ -153,6 +153,48 @@ static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
#define CADDR(x) SCM_CADDR(x) #define CADDR(x) SCM_CADDR(x)
#define CDDDR(x) SCM_CDDDR(x) #define CDDDR(x) SCM_CDDDR(x)
#define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
#define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
#define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
static SCM
make_env (int n, SCM init, SCM next)
{
SCM env = scm_c_make_vector (n + 1, init);
VECTOR_SET (env, 0, next);
return env;
}
static SCM
next_rib (SCM env)
{
return VECTOR_REF (env, 0);
}
static SCM
env_tail (SCM env)
{
while (SCM_I_IS_VECTOR (env))
env = next_rib (env);
return env;
}
static SCM
env_ref (SCM env, int depth, int width)
{
while (depth--)
env = next_rib (env);
return VECTOR_REF (env, width + 1);
}
static void
env_set (SCM env, int depth, int width, SCM val)
{
while (depth--)
env = next_rib (env);
VECTOR_SET (env, width + 1, val);
}
SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
@ -245,10 +287,13 @@ eval (SCM x, SCM env)
case SCM_M_LET: case SCM_M_LET:
{ {
SCM inits = CAR (mx); SCM inits = CAR (mx);
SCM new_env = CAPTURE_ENV (env); SCM new_env;
for (; scm_is_pair (inits); inits = CDR (inits)) int i;
new_env = scm_cons (EVAL1 (CAR (inits), env),
new_env); new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED,
CAPTURE_ENV (env));
for (i = 0; i < VECTOR_LENGTH (inits); i++)
env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
env = new_env; env = new_env;
x = CDR (mx); x = CDR (mx);
goto loop; goto loop;
@ -325,11 +370,15 @@ eval (SCM x, SCM env)
case SCM_M_LEXICAL_REF: case SCM_M_LEXICAL_REF:
{ {
int n; SCM pos, ret;
SCM ret; int depth, width;
for (n = SCM_I_INUM (mx); n; n--)
env = CDR (env); pos = mx;
ret = CAR (env); depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
ret = env_ref (env, depth, width);
if (SCM_UNLIKELY (SCM_UNBNDP (ret))) if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
/* we don't know what variable, though, because we don't have its /* we don't know what variable, though, because we don't have its
name */ name */
@ -339,11 +388,16 @@ eval (SCM x, SCM env)
case SCM_M_LEXICAL_SET: case SCM_M_LEXICAL_SET:
{ {
int n; SCM pos;
int depth, width;
SCM val = EVAL1 (CDR (mx), env); SCM val = EVAL1 (CDR (mx), env);
for (n = SCM_I_INUM (CAR (mx)); n; n--)
env = CDR (env); pos = CAR (mx);
SCM_SETCAR (env, val); depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
env_set (env, depth, width, val);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -352,8 +406,7 @@ eval (SCM x, SCM env)
return SCM_VARIABLE_REF (mx); return SCM_VARIABLE_REF (mx);
else else
{ {
while (scm_is_pair (env)) env = env_tail (env);
env = CDR (env);
return SCM_VARIABLE_REF return SCM_VARIABLE_REF
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env))); (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
} }
@ -369,8 +422,7 @@ eval (SCM x, SCM env)
} }
else else
{ {
while (scm_is_pair (env)) env = env_tail (env);
env = CDR (env);
SCM_VARIABLE_SET SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)), (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
val); val);
@ -683,15 +735,18 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
{ {
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc); int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
SCM env = BOOT_CLOSURE_ENV (proc); SCM env = BOOT_CLOSURE_ENV (proc);
int i;
if (BOOT_CLOSURE_IS_FIXED (proc) if (BOOT_CLOSURE_IS_FIXED (proc)
|| (BOOT_CLOSURE_IS_REST (proc) || (BOOT_CLOSURE_IS_REST (proc)
&& !BOOT_CLOSURE_HAS_REST_ARGS (proc))) && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
{ {
if (SCM_UNLIKELY (scm_ilength (args) != nreq)) if (SCM_UNLIKELY (scm_ilength (args) != nreq))
scm_wrong_num_args (proc); scm_wrong_num_args (proc);
for (; scm_is_pair (args); args = CDR (args))
env = scm_cons (CAR (args), env); env = make_env (nreq, SCM_UNDEFINED, env);
for (i = 0; i < nreq; args = CDR (args), i++)
env_set (env, 0, i, CAR (args));
*out_body = BOOT_CLOSURE_BODY (proc); *out_body = BOOT_CLOSURE_BODY (proc);
*out_env = env; *out_env = env;
} }
@ -699,15 +754,18 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
{ {
if (SCM_UNLIKELY (scm_ilength (args) < nreq)) if (SCM_UNLIKELY (scm_ilength (args) < nreq))
scm_wrong_num_args (proc); scm_wrong_num_args (proc);
for (; nreq; nreq--, args = CDR (args))
env = scm_cons (CAR (args), env); env = make_env (nreq + 1, SCM_UNDEFINED, env);
env = scm_cons (args, env); for (i = 0; i < nreq; args = CDR (args), i++)
env_set (env, 0, i, CAR (args));
env_set (env, 0, i++, args);
*out_body = BOOT_CLOSURE_BODY (proc); *out_body = BOOT_CLOSURE_BODY (proc);
*out_env = env; *out_env = env;
} }
else else
{ {
int i, argc, nreq, nopt; int i, argc, nreq, nopt, nenv;
SCM body, rest, kw, inits, alt; SCM body, rest, kw, inits, alt;
SCM mx = BOOT_CLOSURE_CODE (proc); SCM mx = BOOT_CLOSURE_CODE (proc);
@ -735,25 +793,46 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
else else
scm_wrong_num_args (proc); scm_wrong_num_args (proc);
} }
if (scm_is_true (kw) && scm_is_false (rest))
{
int npos = 0;
SCM walk;
for (walk = args; scm_is_pair (walk); walk = CDR (walk), npos++)
if (npos >= nreq && scm_is_keyword (CAR (walk)))
break;
if (npos > nreq + nopt)
{
/* Too many positional args and no rest arg. */
if (scm_is_true (alt))
{
mx = alt;
goto loop;
}
else
scm_wrong_num_args (proc);
}
}
/* At this point we are committed to the chosen clause. */
nenv = nreq + (scm_is_true (rest) ? 1 : 0) + scm_ilength (inits);
env = make_env (nenv, SCM_UNDEFINED, env);
for (i = 0; i < nreq; i++, args = CDR (args)) for (i = 0; i < nreq; i++, args = CDR (args))
env = scm_cons (CAR (args), env); env_set (env, 0, i, CAR (args));
if (scm_is_false (kw)) if (scm_is_false (kw))
{ {
/* Optional args (possibly), but no keyword args. */ /* Optional args (possibly), but no keyword args. */
for (; i < argc && i < nreq + nopt; for (; i < argc && i < nreq + nopt;
i++, args = CDR (args)) i++, args = CDR (args), inits = CDR (inits))
{ env_set (env, 0, i, CAR (args));
env = scm_cons (CAR (args), env);
inits = CDR (inits);
}
for (; i < nreq + nopt; i++, inits = CDR (inits)) for (; i < nreq + nopt; i++, inits = CDR (inits))
env = scm_cons (EVAL1 (CAR (inits), env), env); env_set (env, 0, i, EVAL1 (CAR (inits), env));
if (scm_is_true (rest)) if (scm_is_true (rest))
env = scm_cons (args, env); env_set (env, 0, i++, args);
} }
else else
{ {
@ -762,45 +841,27 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
aok = CAR (kw); aok = CAR (kw);
kw = CDR (kw); kw = CDR (kw);
/* Keyword args. As before, but stop at the first keyword. */ /* Optional args. As before, but stop at the first keyword. */
for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args)); for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args));
i++, args = CDR (args), inits = CDR (inits)) i++, args = CDR (args), inits = CDR (inits))
env = scm_cons (CAR (args), env); env_set (env, 0, i, CAR (args));
for (; i < nreq + nopt; i++, inits = CDR (inits)) for (; i < nreq + nopt; i++, inits = CDR (inits))
env = scm_cons (EVAL1 (CAR (inits), env), env); env_set (env, 0, i, EVAL1 (CAR (inits), env));
if (scm_is_true (rest)) if (scm_is_true (rest))
{ env_set (env, 0, i++, args);
env = scm_cons (args, env);
i++;
}
else if (scm_is_true (alt)
&& scm_is_pair (args) && !scm_is_keyword (CAR (args)))
{
/* Too many positional args, no rest arg, and we have an
alternate clause. */
mx = alt;
goto loop;
}
/* Now fill in env with unbound values, limn the rest of the args for /* Parse keyword args. */
keywords, and fill in unbound values with their inits. */
{ {
int imax = i - 1;
int kw_start_idx = i; int kw_start_idx = i;
SCM walk, k, v; SCM walk;
for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
if (SCM_I_INUM (CDAR (walk)) > imax)
imax = SCM_I_INUM (CDAR (walk));
for (; i <= imax; i++)
env = scm_cons (SCM_UNDEFINED, env);
if (scm_is_pair (args) && scm_is_pair (CDR (args))) if (scm_is_pair (args) && scm_is_pair (CDR (args)))
for (; scm_is_pair (args) && scm_is_pair (CDR (args)); for (; scm_is_pair (args) && scm_is_pair (CDR (args));
args = CDR (args)) args = CDR (args))
{ {
k = CAR (args); v = CADR (args); SCM k = CAR (args), v = CADR (args);
if (!scm_is_keyword (k)) if (!scm_is_keyword (k))
{ {
if (scm_is_true (rest)) if (scm_is_true (rest))
@ -811,10 +872,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
for (walk = kw; scm_is_pair (walk); walk = CDR (walk)) for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
if (scm_is_eq (k, CAAR (walk))) if (scm_is_eq (k, CAAR (walk)))
{ {
/* Well... ok, list-set! isn't the nicest interface, but env_set (env, 0, SCM_I_INUM (CDAR (walk)), v);
hey. */
int iset = imax - SCM_I_INUM (CDAR (walk));
scm_list_set_x (env, SCM_I_MAKINUM (iset), v);
args = CDR (args); args = CDR (args);
break; break;
} }
@ -826,15 +884,17 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
/* Now fill in unbound values, evaluating init expressions in their /* Now fill in unbound values, evaluating init expressions in their
appropriate environment. */ appropriate environment. */
for (i = imax - kw_start_idx; scm_is_pair (inits); i--, inits = CDR (inits)) for (i = kw_start_idx; scm_is_pair (inits); i++, inits = CDR (inits))
{ if (SCM_UNBNDP (env_ref (env, 0, i)))
SCM tail = scm_list_tail (env, SCM_I_MAKINUM (i)); env_set (env, 0, i, EVAL1 (CAR (inits), env));
if (SCM_UNBNDP (CAR (tail)))
SCM_SETCAR (tail, EVAL1 (CAR (inits), CDR (tail)));
}
} }
} }
if (!scm_is_null (inits))
abort ();
if (i != nenv)
abort ();
*out_body = body; *out_body = body;
*out_env = env; *out_env = env;
} }
@ -846,32 +906,32 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
{ {
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc); int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
SCM new_env = BOOT_CLOSURE_ENV (proc); SCM new_env = BOOT_CLOSURE_ENV (proc);
if (BOOT_CLOSURE_IS_FIXED (proc) if ((BOOT_CLOSURE_IS_FIXED (proc)
|| (BOOT_CLOSURE_IS_REST (proc) || (BOOT_CLOSURE_IS_REST (proc)
&& !BOOT_CLOSURE_HAS_REST_ARGS (proc))) && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
&& nreq == argc)
{ {
for (; scm_is_pair (exps); exps = CDR (exps), nreq--) int i;
new_env = scm_cons (EVAL1 (CAR (exps), *inout_env),
new_env); new_env = make_env (nreq, SCM_UNDEFINED, new_env);
if (SCM_UNLIKELY (nreq != 0)) for (i = 0; i < nreq; exps = CDR (exps), i++)
scm_wrong_num_args (proc); env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
*out_body = BOOT_CLOSURE_BODY (proc); *out_body = BOOT_CLOSURE_BODY (proc);
*inout_env = new_env; *inout_env = new_env;
} }
else if (BOOT_CLOSURE_IS_REST (proc)) else if (BOOT_CLOSURE_IS_REST (proc) && argc >= nreq)
{ {
if (SCM_UNLIKELY (argc < nreq)) SCM rest;
scm_wrong_num_args (proc); int i;
for (; nreq; nreq--, exps = CDR (exps))
new_env = scm_cons (EVAL1 (CAR (exps), *inout_env), new_env = make_env (nreq + 1, SCM_UNDEFINED, new_env);
new_env); for (i = 0; i < nreq; exps = CDR (exps), i++)
{ env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
SCM rest = SCM_EOL; for (rest = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
for (; scm_is_pair (exps); exps = CDR (exps)) rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest);
rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest); env_set (new_env, 0, i++, scm_reverse_x (rest, SCM_UNDEFINED));
new_env = scm_cons (scm_reverse (rest),
new_env);
}
*out_body = BOOT_CLOSURE_BODY (proc); *out_body = BOOT_CLOSURE_BODY (proc);
*inout_env = new_env; *inout_env = new_env;
} }

196
libguile/memoize.c
View file

@ -54,6 +54,9 @@
#define CDDDR(x) SCM_CDDDR(x) #define CDDDR(x) SCM_CDDDR(x)
#define CADDDR(x) SCM_CADDDR(x) #define CADDDR(x) SCM_CADDDR(x)
#define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
#define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
#define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
SCM_SYMBOL (sym_case_lambda_star, "case-lambda*"); SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
@ -136,10 +139,10 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons)) MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
#define MAKMEMO_CALL(proc, nargs, args) \ #define MAKMEMO_CALL(proc, nargs, args) \
MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args))) MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
#define MAKMEMO_LEX_REF(n) \ #define MAKMEMO_LEX_REF(pos) \
MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n)) MAKMEMO (SCM_M_LEXICAL_REF, pos)
#define MAKMEMO_LEX_SET(n, val) \ #define MAKMEMO_LEX_SET(pos, val) \
MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (SCM_I_MAKINUM (n), val)) MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val))
#define MAKMEMO_TOP_REF(var) \ #define MAKMEMO_TOP_REF(var) \
MAKMEMO (SCM_M_TOPLEVEL_REF, var) MAKMEMO (SCM_M_TOPLEVEL_REF, var)
#define MAKMEMO_TOP_SET(var, val) \ #define MAKMEMO_TOP_SET(var, val) \
@ -190,15 +193,43 @@ scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
static int static int
lookup (SCM x, SCM env) try_lookup_rib (SCM x, SCM rib)
{ {
int i = 0; int idx = 0;
for (; scm_is_pair (env); env = CDR (env), i++) for (; idx < VECTOR_LENGTH (rib); idx++)
if (scm_is_eq (x, CAR (env))) if (scm_is_eq (x, VECTOR_REF (rib, idx)))
return i; /* bound */ return idx; /* bound */
abort (); return -1;
} }
static int
lookup_rib (SCM x, SCM rib)
{
int idx = try_lookup_rib (x, rib);
if (idx < 0)
abort ();
return idx;
}
static SCM
make_pos (int depth, int width)
{
return scm_cons (SCM_I_MAKINUM (depth), SCM_I_MAKINUM (width));
}
static SCM
lookup (SCM x, SCM env)
{
int d = 0;
for (; scm_is_pair (env); env = CDR (env), d++)
{
int w = try_lookup_rib (x, CAR (env));
if (w < 0)
continue;
return make_pos (d, w);
}
abort ();
}
/* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */ /* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
#define REF(x,type,field) \ #define REF(x,type,field) \
@ -373,8 +404,8 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_LAMBDA_CASE: case SCM_EXPANDED_LAMBDA_CASE:
{ {
SCM req, rest, opt, kw, inits, vars, body, alt; SCM req, rest, opt, kw, inits, vars, body, alt;
SCM walk, minits, arity, new_env; SCM walk, minits, arity, rib, new_env;
int nreq, nopt, ntotal; int nreq, nopt;
req = REF (exp, LAMBDA_CASE, REQ); req = REF (exp, LAMBDA_CASE, REQ);
rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST))); rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
@ -387,38 +418,16 @@ memoize (SCM exp, SCM env)
nreq = scm_ilength (req); nreq = scm_ilength (req);
nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0; nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
ntotal = scm_ilength (vars);
/* The vars are the gensyms, according to the divine plan. But we need /* The vars are the gensyms, according to the divine plan. But we need
to memoize the inits within their appropriate environment, to memoize the inits within their appropriate environment,
complicating things. */ complicating things. */
new_env = env; rib = scm_vector (vars);
for (walk = req; scm_is_pair (walk); new_env = scm_cons (rib, env);
walk = CDR (walk), vars = CDR (vars))
new_env = scm_cons (CAR (vars), new_env);
minits = SCM_EOL; minits = SCM_EOL;
for (walk = opt; scm_is_pair (walk); for (walk = inits; scm_is_pair (walk); walk = CDR (walk))
walk = CDR (walk), vars = CDR (vars), inits = CDR (inits)) minits = scm_cons (memoize (CAR (walk), new_env), minits);
{
minits = scm_cons (memoize (CAR (inits), new_env), minits);
new_env = scm_cons (CAR (vars), new_env);
}
if (scm_is_true (rest))
{
new_env = scm_cons (CAR (vars), new_env);
vars = CDR (vars);
}
for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits))
{
minits = scm_cons (memoize (CAR (inits), new_env), minits);
new_env = scm_cons (CAR (vars), new_env);
}
if (!scm_is_null (vars))
abort ();
minits = scm_reverse_x (minits, SCM_UNDEFINED); minits = scm_reverse_x (minits, SCM_UNDEFINED);
if (scm_is_true (kw)) if (scm_is_true (kw))
@ -431,7 +440,7 @@ memoize (SCM exp, SCM env)
int idx; int idx;
k = CAR (CAR (kw)); k = CAR (CAR (kw));
idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env); idx = lookup_rib (CADDR (CAR (kw)), rib);
indices = scm_acons (k, SCM_I_MAKINUM (idx), indices); indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
} }
kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED)); kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
@ -456,79 +465,74 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_LET: case SCM_EXPANDED_LET:
{ {
SCM vars, exps, body, inits, new_env; SCM vars, exps, body, varsv, inits, new_env;
int i;
vars = REF (exp, LET, GENSYMS); vars = REF (exp, LET, GENSYMS);
exps = REF (exp, LET, VALS); exps = REF (exp, LET, VALS);
body = REF (exp, LET, BODY); body = REF (exp, LET, BODY);
inits = SCM_EOL; varsv = scm_vector (vars);
new_env = env; inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps)) SCM_BOOL_F);
{ new_env = scm_cons (varsv, env);
new_env = scm_cons (CAR (vars), new_env); for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
inits = scm_cons (memoize (CAR (exps), env), inits); VECTOR_SET (inits, i, memoize (CAR (exps), env));
}
return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED), return MAKMEMO_LET (inits, memoize (body, new_env));
memoize (body, new_env));
} }
case SCM_EXPANDED_LETREC: case SCM_EXPANDED_LETREC:
{ {
SCM vars, exps, body, undefs, new_env; SCM vars, varsv, exps, expsv, body, undefs, new_env;
int i, nvars, in_order_p; int i, nvars, in_order_p;
vars = REF (exp, LETREC, GENSYMS); vars = REF (exp, LETREC, GENSYMS);
exps = REF (exp, LETREC, VALS); exps = REF (exp, LETREC, VALS);
body = REF (exp, LETREC, BODY); body = REF (exp, LETREC, BODY);
in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P)); in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
nvars = i = scm_ilength (vars);
undefs = SCM_EOL;
new_env = env;
for (; scm_is_pair (vars); vars = CDR (vars)) varsv = scm_vector (vars);
{ nvars = VECTOR_LENGTH (varsv);
new_env = scm_cons (CAR (vars), new_env); expsv = scm_vector (exps);
undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
} undefs = scm_c_make_vector (nvars, MAKMEMO_QUOTE (SCM_UNDEFINED));
new_env = scm_cons (varsv, env);
if (in_order_p) if (in_order_p)
{ {
SCM body_exps = SCM_EOL, seq; SCM body_exps = memoize (body, new_env);
for (; scm_is_pair (exps); exps = CDR (exps), i--) for (i = nvars - 1; i >= 0; i--)
body_exps = scm_cons (MAKMEMO_LEX_SET (i-1, {
memoize (CAR (exps), new_env)), SCM init = memoize (VECTOR_REF (expsv, i), new_env);
body_exps); body_exps = MAKMEMO_SEQ (MAKMEMO_LEX_SET (make_pos (0, i), init),
body_exps);
seq = memoize (body, new_env); }
for (; scm_is_pair (body_exps); body_exps = CDR (body_exps)) return MAKMEMO_LET (undefs, body_exps);
seq = MAKMEMO_SEQ (CAR (body_exps), seq);
return MAKMEMO_LET (undefs, seq);
} }
else else
{ {
SCM sets = SCM_EOL, inits = SCM_EOL, set_seq; SCM sets = SCM_BOOL_F, inits = scm_c_make_vector (nvars, SCM_BOOL_F);
for (; scm_is_pair (exps); exps = CDR (exps), i--) for (i = nvars - 1; i >= 0; i--)
{ {
sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars, SCM init, set;
MAKMEMO_LEX_REF (i-1)),
sets);
inits = scm_cons (memoize (CAR (exps), new_env), inits);
}
inits = scm_reverse_x (inits, SCM_UNDEFINED);
sets = scm_reverse_x (sets, SCM_UNDEFINED); init = memoize (VECTOR_REF (expsv, i), new_env);
if (scm_is_null (sets)) VECTOR_SET (inits, i, init);
set = MAKMEMO_LEX_SET (make_pos (1, i),
MAKMEMO_LEX_REF (make_pos (0, i)));
if (scm_is_false (sets))
sets = set;
else
sets = MAKMEMO_SEQ (set, sets);
}
if (scm_is_false (sets))
return memoize (body, env); return memoize (body, env);
for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets);
sets = CDR (sets))
set_seq = MAKMEMO_SEQ (CAR (sets), set_seq);
return MAKMEMO_LET (undefs, return MAKMEMO_LET (undefs,
MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq), MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
memoize (body, new_env))); memoize (body, new_env)));
} }
} }
@ -577,26 +581,22 @@ unmemoize_exprs (SCM exprs)
static SCM static SCM
unmemoize_bindings (SCM inits) unmemoize_bindings (SCM inits)
{ {
SCM ret, tail; SCM ret = SCM_EOL;
if (scm_is_null (inits)) int n = scm_c_vector_length (inits);
return SCM_EOL;
ret = scm_list_1 (scm_list_2 (sym_placeholder, unmemoize (CAR (inits)))); while (n--)
tail = ret; ret = scm_cons (unmemoize (scm_c_vector_ref (inits, n)), ret);
for (inits = CDR (inits); !scm_is_null (inits); inits = CDR (inits))
{
SCM_SETCDR (tail, scm_list_1 (scm_list_2 (sym_placeholder,
unmemoize (CAR (inits)))));
tail = CDR (tail);
}
return ret; return ret;
} }
static SCM static SCM
unmemoize_lexical (SCM n) unmemoize_lexical (SCM n)
{ {
char buf[16]; char buf[32];
buf[15] = 0; buf[31] = 0;
snprintf (buf, 15, "<%u>", scm_to_uint32 (n)); snprintf (buf, 31, "<%u,%u>", scm_to_uint32 (CAR (n)),
scm_to_uint32 (CDR (n)));
return scm_from_utf8_symbol (buf); return scm_from_utf8_symbol (buf);
} }

331
module/ice-9/eval.scm
View file

@ -57,6 +57,42 @@
(and (current-module) the-root-module) (and (current-module) the-root-module)
env))))) env)))))
(define-syntax env-toplevel
(syntax-rules ()
((_ env)
(let lp ((e env))
(if (vector? e)
(lp (vector-ref e 0))
e)))))
(define-syntax make-env
(syntax-rules ()
((_ n init next)
(let ((v (make-vector (1+ n) init)))
(vector-set! v 0 next)
v))))
(define-syntax make-env*
(syntax-rules ()
((_ next init ...)
(vector next init ...))))
(define-syntax env-ref
(syntax-rules ()
((_ env depth width)
(let lp ((e env) (d depth))
(if (zero? d)
(vector-ref e (1+ width))
(lp (vector-ref e 0) (1- d)))))))
(define-syntax env-set!
(syntax-rules ()
((_ env depth width val)
(let lp ((e env) (d depth))
(if (zero? d)
(vector-set! e (1+ width) val)
(lp (vector-ref e 0) (1- d)))))))
;; Fast case for procedures with fixed arities. ;; Fast case for procedures with fixed arities.
(define-syntax make-fixed-closure (define-syntax make-fixed-closure
(lambda (x) (lambda (x)
@ -79,28 +115,32 @@
#`((#,nreq) #`((#,nreq)
(lambda (#,@formals) (lambda (#,@formals)
(eval body (eval body
(cons* #,@(reverse formals) env)))))) (make-env* env #,@formals))))))
(iota *max-static-argument-count*)) (iota *max-static-argument-count*))
(else (else
#,(let ((formals (make-formals *max-static-argument-count*))) #,(let ((formals (make-formals *max-static-argument-count*)))
#`(lambda (#,@formals . more) #`(lambda (#,@formals . more)
(let lp ((new-env (cons* #,@(reverse formals) env)) (let ((env (make-env nreq #f env)))
(nreq (- nreq #,*max-static-argument-count*)) #,@(map (lambda (formal n)
(args more)) #`(env-set! env 0 #,n #,formal))
(if (zero? nreq) formals (iota (length formals)))
(let lp ((i #,*max-static-argument-count*)
(args more))
(cond
((= i nreq)
(eval body (eval body
(if (null? args) (if (null? args)
new-env env
(scm-error 'wrong-number-of-args (scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments" "eval" "Wrong number of arguments"
'() #f))) '() #f))))
(if (null? args) ((null? args)
(scm-error 'wrong-number-of-args (scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments" "eval" "Wrong number of arguments"
'() #f) '() #f))
(lp (cons (car args) new-env) (else
(1- nreq) (env-set! env 0 i (car args))
(cdr args))))))))))))) (lp (1+ i) (cdr args))))))))))))))
;; Fast case for procedures with fixed arities and a rest argument. ;; Fast case for procedures with fixed arities and a rest argument.
(define-syntax make-rest-closure (define-syntax make-rest-closure
@ -124,23 +164,28 @@
#`((#,nreq) #`((#,nreq)
(lambda (#,@formals . rest) (lambda (#,@formals . rest)
(eval body (eval body
(cons* rest #,@(reverse formals) env)))))) (make-env* env #,@formals rest))))))
(iota *max-static-argument-count*)) (iota *max-static-argument-count*))
(else (else
#,(let ((formals (make-formals *max-static-argument-count*))) #,(let ((formals (make-formals *max-static-argument-count*)))
#`(lambda (#,@formals . more) #`(lambda (#,@formals . more)
(let lp ((new-env (cons* #,@(reverse formals) env)) (let ((env (make-env (1+ nreq) #f env)))
(nreq (- nreq #,*max-static-argument-count*)) #,@(map (lambda (formal n)
(args more)) #`(env-set! env 0 #,n #,formal))
(if (zero? nreq) formals (iota (length formals)))
(eval body (cons args new-env)) (let lp ((i #,*max-static-argument-count*)
(if (null? args) (args more))
(scm-error 'wrong-number-of-args (cond
"eval" "Wrong number of arguments" ((= i nreq)
'() #f) (env-set! env 0 nreq args)
(lp (cons (car args) new-env) (eval body env))
(1- nreq) ((null? args)
(cdr args))))))))))))) (scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))
(else
(env-set! env 0 i (car args))
(lp (1+ i) (cdr args))))))))))))))
(define-syntax call (define-syntax call
(lambda (x) (lambda (x)
@ -301,125 +346,110 @@
proc) proc)
(set-procedure-arity! (set-procedure-arity!
(lambda %args (lambda %args
(let lp ((env env) (define (npositional args)
(nreq* nreq) (let lp ((n 0) (args args))
(args %args)) (if (or (null? args)
(if (> nreq* 0) (and (>= n nreq) (keyword? (car args))))
;; First, bind required arguments. n
(if (null? args) (lp (1+ n) (cdr args)))))
(if alt (let ((nargs (length %args)))
(apply alt-proc %args) (cond
(scm-error 'wrong-number-of-args ((or (< nargs nreq)
"eval" "Wrong number of arguments" (and (not kw) (not rest?) (> nargs (+ nreq nopt)))
'() #f)) (and kw (not rest?) (> (npositional %args) (+ nreq nopt))))
(lp (cons (car args) env) (if alt
(1- nreq*) (apply alt-proc %args)
(cdr args))) ((scm-error 'wrong-number-of-args
;; Move on to optional arguments. "eval" "Wrong number of arguments"
(if (not kw) '() #f))))
;; Without keywords, bind optionals from arguments. (else
(let lp ((env env) (let* ((nvals (+ nreq (if rest? 1 0) (length inits)))
(nopt nopt) (env (make-env nvals unbound-arg env)))
(args args) (let lp ((i 0) (args %args))
(inits inits)) (cond
(if (zero? nopt) ((< i nreq)
(if rest? ;; Bind required arguments.
(eval body (cons args env)) (env-set! env 0 i (car args))
(if (null? args) (lp (1+ i) (cdr args)))
(eval body env) ((not kw)
(if alt ;; Optional args (possibly), but no keyword args.
(apply alt-proc %args) (let lp ((i i) (args args) (inits inits))
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f))))
(if (null? args)
(lp (cons (eval (car inits) env) env)
(1- nopt) args (cdr inits))
(lp (cons (car args) env)
(1- nopt) (cdr args) (cdr inits)))))
(let lp ((env env)
(nopt* nopt)
(args args)
(inits inits))
(cond (cond
;; With keywords, we stop binding optionals at the ((< i (+ nreq nopt))
;; first keyword. (cond
((> nopt* 0) ((< i nargs)
(if (or (null? args) (keyword? (car args))) (env-set! env 0 i (car args))
(lp (cons (eval (car inits) env) env) (lp (1+ i) (cdr args) (cdr inits)))
(1- nopt*) args (cdr inits)) (else
(lp (cons (car args) env) (env-set! env 0 i (eval (car inits) env))
(1- nopt*) (cdr args) (cdr inits)))) (lp (1+ i) args (cdr inits)))))
;; Finished with optionals.
((and alt (pair? args) (not (keyword? (car args)))
(not rest?))
;; Too many positional args, no #:rest arg,
;; and we have an alternate.
(apply alt-proc %args))
(else (else
(let* ((aok (car kw)) (when rest?
(kw (cdr kw)) (env-set! env 0 i args))
(kw-base (+ nopt nreq (if rest? 1 0))) (eval body env)))))
(imax (let lp ((imax (1- kw-base)) (kw kw)) (else
(if (null? kw) ;; Optional args. As before, but stop at the first
imax ;; keyword.
(lp (max (cdar kw) imax) (let lp ((i i) (args args) (inits inits))
(cdr kw))))) (cond
;; Fill in kwargs with "undefined" vals. ((< i (+ nreq nopt))
(env (let lp ((i kw-base) (cond
;; Also, here we bind the rest ((and (< i nargs) (not (keyword? (car args))))
;; arg, if any. (env-set! env 0 i (car args))
(env (if rest? (lp (1+ i) (cdr args) (cdr inits)))
(cons args env) (else
env))) (env-set! env 0 i (eval (car inits) env))
(if (<= i imax) (lp (1+ i) args (cdr inits)))))
(lp (1+ i) (cons unbound-arg env)) (else
env)))) (when rest?
(env-set! env 0 i args))
(let ((aok (car kw))
(kw (cdr kw))
(kw-base (if rest? (1+ i) i)))
;; Now scan args for keywords. ;; Now scan args for keywords.
(let lp ((args args)) (let lp ((args args))
(if (and (pair? args) (pair? (cdr args)) (cond
(keyword? (car args))) ((and (pair? args) (pair? (cdr args))
(let ((kw-pair (assq (car args) kw)) (keyword? (car args)))
(v (cadr args))) (let ((kw-pair (assq (car args) kw))
(if kw-pair (v (cadr args)))
;; Found a known keyword; set its value. (if kw-pair
(list-set! env ;; Found a known keyword; set its value.
(- imax (cdr kw-pair)) v) (env-set! env 0 (cdr kw-pair) v)
;; Unknown keyword. ;; Unknown keyword.
(if (not aok) (if (not aok)
(scm-error ((scm-error
'keyword-argument-error 'keyword-argument-error
"eval" "Unrecognized keyword" "eval" "Unrecognized keyword"
'() (list (car args))))) '() (list (car args))))))
(lp (cddr args))) (lp (cddr args))))
(if (pair? args) ((pair? args)
(if rest? (if rest?
;; Be lenient parsing rest args. ;; Be lenient parsing rest args.
(lp (cdr args)) (lp (cdr args))
(scm-error 'keyword-argument-error ((scm-error 'keyword-argument-error
"eval" "Invalid keyword" "eval" "Invalid keyword"
'() (list (car args)))) '() (list (car args))))))
;; Finished parsing keywords. Fill in (else
;; uninitialized kwargs by evalling init ;; Finished parsing keywords. Fill in
;; expressions in their appropriate ;; uninitialized kwargs by evalling init
;; environment. ;; expressions in their appropriate
(let lp ((i (- imax kw-base)) ;; environment.
(inits inits)) (let lp ((i kw-base) (inits inits))
(if (pair? inits) (cond
(let ((tail (list-tail env i))) ((pair? inits)
(if (eq? (car tail) unbound-arg) (when (eq? (env-ref env 0 i) unbound-arg)
(set-car! tail (env-set! env 0 i (eval (car inits) env)))
(eval (car inits) (lp (1+ i) (cdr inits)))
(cdr tail)))) (else
(lp (1- i) (cdr inits))) ;; Finally, eval the body.
;; Finally, eval the body. (eval body env)))))))))))))))))))))
(eval body env))))))))))))))))
;; The "engine". EXP is a memoized expression. ;; The "engine". EXP is a memoized expression.
(define (eval exp env) (define (eval exp env)
(memoized-expression-case exp (memoized-expression-case exp
(('lexical-ref n) (('lexical-ref (depth . width))
(list-ref env n)) (env-ref env depth width))
(('call (f nargs . args)) (('call (f nargs . args))
(let ((proc (eval f env))) (let ((proc (eval f env)))
@ -430,9 +460,7 @@
(if (variable? var-or-sym) (if (variable? var-or-sym)
var-or-sym var-or-sym
(memoize-variable-access! exp (memoize-variable-access! exp
(capture-env (if (pair? env) (capture-env (env-toplevel env))))))
(cdr (last-pair env))
env))))))
(('if (test consequent . alternate)) (('if (test consequent . alternate))
(if (eval test env) (if (eval test env)
@ -443,11 +471,13 @@
x) x)
(('let (inits . body)) (('let (inits . body))
(let lp ((inits inits) (new-env (capture-env env))) (let* ((width (vector-length inits))
(if (null? inits) (new-env (make-env width #f (capture-env env))))
(eval body new-env) (let lp ((i 0))
(lp (cdr inits) (when (< i width)
(cons (eval (car inits) env) new-env))))) (env-set! new-env 0 i (eval (vector-ref inits i) env))
(lp (1+ i))))
(eval body new-env)))
(('lambda (body docstring nreq . tail)) (('lambda (body docstring nreq . tail))
(let ((proc (let ((proc
@ -466,9 +496,8 @@
(eval head env) (eval head env)
(eval tail env))) (eval tail env)))
(('lexical-set! (n . x)) (('lexical-set! ((depth . width) . x))
(let ((val (eval x env))) (env-set! env depth width (eval x env)))
(list-set! env n val)))
(('call-with-values (producer . consumer)) (('call-with-values (producer . consumer))
(call-with-values (eval producer env) (call-with-values (eval producer env)
@ -495,9 +524,7 @@
(if (variable? var-or-sym) (if (variable? var-or-sym)
var-or-sym var-or-sym
(memoize-variable-access! exp (memoize-variable-access! exp
(capture-env (if (pair? env) (capture-env (env-toplevel env))))
(cdr (last-pair env))
env))))
(eval x env))) (eval x env)))
(('call-with-prompt (tag thunk . handler)) (('call-with-prompt (tag thunk . handler))