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

228
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 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");
@ -245,10 +287,13 @@ eval (SCM x, SCM env)
case SCM_M_LET:
{
SCM inits = CAR (mx);
SCM new_env = CAPTURE_ENV (env);
for (; scm_is_pair (inits); inits = CDR (inits))
new_env = scm_cons (EVAL1 (CAR (inits), env),
new_env);
SCM new_env;
int i;
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;
x = CDR (mx);
goto loop;
@ -325,11 +370,15 @@ eval (SCM x, SCM env)
case SCM_M_LEXICAL_REF:
{
int n;
SCM ret;
for (n = SCM_I_INUM (mx); n; n--)
env = CDR (env);
ret = CAR (env);
SCM pos, ret;
int depth, width;
pos = mx;
depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
ret = env_ref (env, depth, width);
if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
/* we don't know what variable, though, because we don't have its
name */
@ -339,11 +388,16 @@ eval (SCM x, SCM env)
case SCM_M_LEXICAL_SET:
{
int n;
SCM pos;
int depth, width;
SCM val = EVAL1 (CDR (mx), env);
for (n = SCM_I_INUM (CAR (mx)); n; n--)
env = CDR (env);
SCM_SETCAR (env, val);
pos = CAR (mx);
depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
env_set (env, depth, width, val);
return SCM_UNSPECIFIED;
}
@ -352,8 +406,7 @@ eval (SCM x, SCM env)
return SCM_VARIABLE_REF (mx);
else
{
while (scm_is_pair (env))
env = CDR (env);
env = env_tail (env);
return SCM_VARIABLE_REF
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
}
@ -369,8 +422,7 @@ eval (SCM x, SCM env)
}
else
{
while (scm_is_pair (env))
env = CDR (env);
env = env_tail (env);
SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
val);
@ -683,6 +735,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
{
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
SCM env = BOOT_CLOSURE_ENV (proc);
int i;
if (BOOT_CLOSURE_IS_FIXED (proc)
|| (BOOT_CLOSURE_IS_REST (proc)
@ -690,8 +743,10 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
{
if (SCM_UNLIKELY (scm_ilength (args) != nreq))
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_env = env;
}
@ -699,15 +754,18 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
{
if (SCM_UNLIKELY (scm_ilength (args) < nreq))
scm_wrong_num_args (proc);
for (; nreq; nreq--, args = CDR (args))
env = scm_cons (CAR (args), env);
env = scm_cons (args, env);
env = make_env (nreq + 1, SCM_UNDEFINED, 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_env = env;
}
else
{
int i, argc, nreq, nopt;
int i, argc, nreq, nopt, nenv;
SCM body, rest, kw, inits, alt;
SCM mx = BOOT_CLOSURE_CODE (proc);
@ -735,25 +793,46 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
else
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))
env = scm_cons (CAR (args), env);
env_set (env, 0, i, CAR (args));
if (scm_is_false (kw))
{
/* Optional args (possibly), but no keyword args. */
for (; i < argc && i < nreq + nopt;
i++, args = CDR (args))
{
env = scm_cons (CAR (args), env);
inits = CDR (inits);
}
i++, args = CDR (args), inits = CDR (inits))
env_set (env, 0, i, CAR (args));
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))
env = scm_cons (args, env);
env_set (env, 0, i++, args);
}
else
{
@ -762,45 +841,27 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
aok = CAR (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));
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))
env = scm_cons (EVAL1 (CAR (inits), env), env);
env_set (env, 0, i, EVAL1 (CAR (inits), env));
if (scm_is_true (rest))
{
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;
}
env_set (env, 0, i++, args);
/* Now fill in env with unbound values, limn the rest of the args for
keywords, and fill in unbound values with their inits. */
/* Parse keyword args. */
{
int imax = i - 1;
int kw_start_idx = i;
SCM walk, k, v;
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);
SCM walk;
if (scm_is_pair (args) && scm_is_pair (CDR (args)))
for (; scm_is_pair (args) && scm_is_pair (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_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))
if (scm_is_eq (k, CAAR (walk)))
{
/* Well... ok, list-set! isn't the nicest interface, but
hey. */
int iset = imax - SCM_I_INUM (CDAR (walk));
scm_list_set_x (env, SCM_I_MAKINUM (iset), v);
env_set (env, 0, SCM_I_INUM (CDAR (walk)), v);
args = CDR (args);
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
appropriate environment. */
for (i = imax - kw_start_idx; scm_is_pair (inits); i--, inits = CDR (inits))
{
SCM tail = scm_list_tail (env, SCM_I_MAKINUM (i));
if (SCM_UNBNDP (CAR (tail)))
SCM_SETCAR (tail, EVAL1 (CAR (inits), CDR (tail)));
}
for (i = kw_start_idx; scm_is_pair (inits); i++, inits = CDR (inits))
if (SCM_UNBNDP (env_ref (env, 0, i)))
env_set (env, 0, i, EVAL1 (CAR (inits), env));
}
}
if (!scm_is_null (inits))
abort ();
if (i != nenv)
abort ();
*out_body = body;
*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);
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_HAS_REST_ARGS (proc)))
&& nreq == argc)
{
for (; scm_is_pair (exps); exps = CDR (exps), nreq--)
new_env = scm_cons (EVAL1 (CAR (exps), *inout_env),
new_env);
if (SCM_UNLIKELY (nreq != 0))
scm_wrong_num_args (proc);
int i;
new_env = make_env (nreq, SCM_UNDEFINED, new_env);
for (i = 0; i < nreq; exps = CDR (exps), i++)
env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
*out_body = BOOT_CLOSURE_BODY (proc);
*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_wrong_num_args (proc);
for (; nreq; nreq--, exps = CDR (exps))
new_env = scm_cons (EVAL1 (CAR (exps), *inout_env),
new_env);
{
SCM rest = SCM_EOL;
for (; scm_is_pair (exps); exps = CDR (exps))
SCM rest;
int i;
new_env = make_env (nreq + 1, SCM_UNDEFINED, new_env);
for (i = 0; i < nreq; exps = CDR (exps), i++)
env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
for (rest = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest);
new_env = scm_cons (scm_reverse (rest),
new_env);
}
env_set (new_env, 0, i++, scm_reverse_x (rest, SCM_UNDEFINED));
*out_body = BOOT_CLOSURE_BODY (proc);
*inout_env = new_env;
}

194
libguile/memoize.c
View file

@ -54,6 +54,9 @@
#define CDDDR(x) SCM_CDDDR(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*");
@ -136,10 +139,10 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
#define MAKMEMO_CALL(proc, nargs, args) \
MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
#define MAKMEMO_LEX_REF(n) \
MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n))
#define MAKMEMO_LEX_SET(n, val) \
MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (SCM_I_MAKINUM (n), val))
#define MAKMEMO_LEX_REF(pos) \
MAKMEMO (SCM_M_LEXICAL_REF, pos)
#define MAKMEMO_LEX_SET(pos, val) \
MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val))
#define MAKMEMO_TOP_REF(var) \
MAKMEMO (SCM_M_TOPLEVEL_REF, var)
#define MAKMEMO_TOP_SET(var, val) \
@ -190,15 +193,43 @@ scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
static int
lookup (SCM x, SCM env)
try_lookup_rib (SCM x, SCM rib)
{
int i = 0;
for (; scm_is_pair (env); env = CDR (env), i++)
if (scm_is_eq (x, CAR (env)))
return i; /* bound */
abort ();
int idx = 0;
for (; idx < VECTOR_LENGTH (rib); idx++)
if (scm_is_eq (x, VECTOR_REF (rib, idx)))
return idx; /* bound */
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 */
#define REF(x,type,field) \
@ -373,8 +404,8 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_LAMBDA_CASE:
{
SCM req, rest, opt, kw, inits, vars, body, alt;
SCM walk, minits, arity, new_env;
int nreq, nopt, ntotal;
SCM walk, minits, arity, rib, new_env;
int nreq, nopt;
req = REF (exp, LAMBDA_CASE, REQ);
rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
@ -387,38 +418,16 @@ memoize (SCM exp, SCM env)
nreq = scm_ilength (req);
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
to memoize the inits within their appropriate environment,
complicating things. */
new_env = env;
for (walk = req; scm_is_pair (walk);
walk = CDR (walk), vars = CDR (vars))
new_env = scm_cons (CAR (vars), new_env);
rib = scm_vector (vars);
new_env = scm_cons (rib, env);
minits = SCM_EOL;
for (walk = opt; scm_is_pair (walk);
walk = CDR (walk), 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_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 ();
for (walk = inits; scm_is_pair (walk); walk = CDR (walk))
minits = scm_cons (memoize (CAR (walk), new_env), minits);
minits = scm_reverse_x (minits, SCM_UNDEFINED);
if (scm_is_true (kw))
@ -431,7 +440,7 @@ memoize (SCM exp, SCM env)
int idx;
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);
}
kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
@ -456,79 +465,74 @@ memoize (SCM exp, SCM env)
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);
exps = REF (exp, LET, VALS);
body = REF (exp, LET, BODY);
inits = SCM_EOL;
new_env = env;
for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps))
{
new_env = scm_cons (CAR (vars), new_env);
inits = scm_cons (memoize (CAR (exps), env), inits);
}
varsv = scm_vector (vars);
inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
SCM_BOOL_F);
new_env = scm_cons (varsv, env);
for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
VECTOR_SET (inits, i, memoize (CAR (exps), env));
return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED),
memoize (body, new_env));
return MAKMEMO_LET (inits, memoize (body, new_env));
}
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;
vars = REF (exp, LETREC, GENSYMS);
exps = REF (exp, LETREC, VALS);
body = REF (exp, LETREC, BODY);
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))
{
new_env = scm_cons (CAR (vars), new_env);
undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
}
varsv = scm_vector (vars);
nvars = VECTOR_LENGTH (varsv);
expsv = scm_vector (exps);
undefs = scm_c_make_vector (nvars, MAKMEMO_QUOTE (SCM_UNDEFINED));
new_env = scm_cons (varsv, env);
if (in_order_p)
{
SCM body_exps = SCM_EOL, seq;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
memoize (CAR (exps), new_env)),
SCM body_exps = memoize (body, new_env);
for (i = nvars - 1; i >= 0; i--)
{
SCM init = memoize (VECTOR_REF (expsv, i), new_env);
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))
seq = MAKMEMO_SEQ (CAR (body_exps), seq);
return MAKMEMO_LET (undefs, seq);
}
return MAKMEMO_LET (undefs, body_exps);
}
else
{
SCM sets = SCM_EOL, inits = SCM_EOL, set_seq;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
SCM sets = SCM_BOOL_F, inits = scm_c_make_vector (nvars, SCM_BOOL_F);
for (i = nvars - 1; i >= 0; i--)
{
sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
MAKMEMO_LEX_REF (i-1)),
sets);
inits = scm_cons (memoize (CAR (exps), new_env), inits);
}
inits = scm_reverse_x (inits, SCM_UNDEFINED);
SCM init, set;
sets = scm_reverse_x (sets, SCM_UNDEFINED);
if (scm_is_null (sets))
init = memoize (VECTOR_REF (expsv, i), new_env);
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);
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,
MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq),
MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
memoize (body, new_env)));
}
}
@ -577,26 +581,22 @@ unmemoize_exprs (SCM exprs)
static SCM
unmemoize_bindings (SCM inits)
{
SCM ret, tail;
if (scm_is_null (inits))
return SCM_EOL;
ret = scm_list_1 (scm_list_2 (sym_placeholder, unmemoize (CAR (inits))));
tail = 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);
}
SCM ret = SCM_EOL;
int n = scm_c_vector_length (inits);
while (n--)
ret = scm_cons (unmemoize (scm_c_vector_ref (inits, n)), ret);
return ret;
}
static SCM
unmemoize_lexical (SCM n)
{
char buf[16];
buf[15] = 0;
snprintf (buf, 15, "<%u>", scm_to_uint32 (n));
char buf[32];
buf[31] = 0;
snprintf (buf, 31, "<%u,%u>", scm_to_uint32 (CAR (n)),
scm_to_uint32 (CDR (n)));
return scm_from_utf8_symbol (buf);
}

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

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