mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-19 02:00:26 +02:00
Simplify the interpreter for trivial inits and no letrec
* libguile/memoize.c (FULL_ARITY): Serialize "ninits" and the unbound value instead of the init list. (memoize): Adapt to FULL_ARITY changes. Remove LETREC case. (unmemoize): Adapt to memoized code change. * libguile/eval.c (BOOT_CLOSURE_PARSE_FULL): Adapt to parse ninits and unbound instead of inits. (eval): Lexical-ref can no longer raise an error. (prepare_boot_closure_env_for_apply): Adapt to inits change. * module/ice-9/eval.scm (primitive-eval): Adapt to ninits/unbound change. * libguile/expand.c (expand_named_let): Fix lambda-case creation to make lists for opt and inits.
This commit is contained in:
Andy Wingo
parent
7974c57937
commit
cfdc8416a2
4 changed files with 70 additions and 187 deletions
|
|
@ -116,13 +116,13 @@ static scm_t_bits scm_tc16_boot_closure;
|
|||
#define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x))))
|
||||
/* NB: One may only call the following accessors if the closure is not REST. */
|
||||
#define BOOT_CLOSURE_IS_FULL(x) (1)
|
||||
#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \
|
||||
#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,ninits,unbound,alt) \
|
||||
do { SCM fu = fu_; \
|
||||
body = CAR (fu); fu = CDDR (fu); \
|
||||
\
|
||||
rest = kw = alt = SCM_BOOL_F; \
|
||||
inits = SCM_EOL; \
|
||||
nopt = 0; \
|
||||
unbound = SCM_BOOL_F; \
|
||||
nopt = ninits = 0; \
|
||||
\
|
||||
nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
|
||||
if (scm_is_pair (fu)) \
|
||||
|
|
@ -132,7 +132,8 @@ static scm_t_bits scm_tc16_boot_closure;
|
|||
{ \
|
||||
nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
|
||||
kw = CAR (fu); fu = CDR (fu); \
|
||||
inits = CAR (fu); fu = CDR (fu); \
|
||||
ninits = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
|
||||
unbound = CAR (fu); fu = CDR (fu); \
|
||||
alt = CAR (fu); \
|
||||
} \
|
||||
} \
|
||||
|
|
@ -196,14 +197,6 @@ env_set (SCM env, int depth, int width, SCM val)
|
|||
}
|
||||
|
||||
|
||||
SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
|
||||
|
||||
static void error_used_before_defined (void)
|
||||
{
|
||||
scm_error (scm_unbound_variable_key, NULL,
|
||||
"Variable used before given a value", SCM_EOL, SCM_BOOL_F);
|
||||
}
|
||||
|
||||
static void error_invalid_keyword (SCM proc, SCM obj)
|
||||
{
|
||||
scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
|
||||
|
|
@ -358,20 +351,14 @@ eval (SCM x, SCM env)
|
|||
|
||||
case SCM_M_LEXICAL_REF:
|
||||
{
|
||||
SCM pos, ret;
|
||||
SCM pos;
|
||||
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 */
|
||||
error_used_before_defined ();
|
||||
return ret;
|
||||
return env_ref (env, depth, width);
|
||||
}
|
||||
|
||||
case SCM_M_LEXICAL_SET:
|
||||
|
|
@ -764,12 +751,13 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
|
|||
}
|
||||
else
|
||||
{
|
||||
int i, argc, nreq, nopt, nenv;
|
||||
SCM body, rest, kw, inits, alt;
|
||||
int i, argc, nreq, nopt, ninits, nenv;
|
||||
SCM body, rest, kw, unbound, alt;
|
||||
SCM mx = BOOT_CLOSURE_CODE (proc);
|
||||
|
||||
loop:
|
||||
BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw, inits, alt);
|
||||
BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw,
|
||||
ninits, unbound, alt);
|
||||
|
||||
argc = scm_ilength (args);
|
||||
if (argc < nreq)
|
||||
|
|
@ -814,8 +802,8 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
|
|||
}
|
||||
|
||||
/* 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);
|
||||
nenv = nreq + (scm_is_true (rest) ? 1 : 0) + ninits;
|
||||
env = make_env (nenv, unbound, env);
|
||||
|
||||
for (i = 0; i < nreq; i++, args = CDR (args))
|
||||
env_set (env, 0, i, CAR (args));
|
||||
|
|
@ -823,15 +811,10 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
|
|||
if (scm_is_false (kw))
|
||||
{
|
||||
/* Optional args (possibly), but no keyword args. */
|
||||
for (; i < argc && i < nreq + nopt;
|
||||
i++, args = CDR (args), inits = CDR (inits))
|
||||
for (; i < argc && i < nreq + nopt; i++, args = CDR (args))
|
||||
env_set (env, 0, i, CAR (args));
|
||||
|
||||
for (; i < nreq + nopt; i++, inits = CDR (inits))
|
||||
env_set (env, 0, i, EVAL1 (CAR (inits), env));
|
||||
|
||||
if (scm_is_true (rest))
|
||||
env_set (env, 0, i++, args);
|
||||
env_set (env, 0, nreq + nopt, args);
|
||||
}
|
||||
else
|
||||
{
|
||||
|
|
@ -842,18 +825,13 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
|
|||
|
||||
/* 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))
|
||||
i++, args = CDR (args))
|
||||
env_set (env, 0, i, CAR (args));
|
||||
|
||||
for (; i < nreq + nopt; i++, inits = CDR (inits))
|
||||
env_set (env, 0, i, EVAL1 (CAR (inits), env));
|
||||
|
||||
if (scm_is_true (rest))
|
||||
env_set (env, 0, i++, args);
|
||||
env_set (env, 0, nreq + nopt, args);
|
||||
|
||||
/* Parse keyword args. */
|
||||
{
|
||||
int kw_start_idx = i;
|
||||
SCM walk;
|
||||
|
||||
if (scm_is_pair (args) && scm_is_pair (CDR (args)))
|
||||
|
|
@ -880,20 +858,9 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
|
|||
}
|
||||
if (scm_is_pair (args) && scm_is_false (rest))
|
||||
error_invalid_keyword (proc, CAR (args));
|
||||
|
||||
/* Now fill in unbound values, evaluating init expressions in their
|
||||
appropriate environment. */
|
||||
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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -977,8 +977,8 @@ expand_named_let (const SCM expr, SCM env)
|
|||
scm_list_1 (name), scm_list_1 (name_sym),
|
||||
scm_list_1 (LAMBDA (SCM_BOOL_F,
|
||||
SCM_EOL,
|
||||
LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_BOOL_F, SCM_BOOL_F,
|
||||
SCM_BOOL_F, SCM_BOOL_F, var_syms,
|
||||
LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F,
|
||||
SCM_BOOL_F, SCM_EOL, var_syms,
|
||||
expand_sequence (CDDDR (expr), inner_env),
|
||||
SCM_BOOL_F))),
|
||||
CALL (SCM_BOOL_F,
|
||||
|
|
@ -1434,7 +1434,7 @@ convert_assignment (SCM exp, SCM assigned)
|
|||
alt = convert_assignment (REF (exp, LAMBDA_CASE, ALTERNATE), assigned);
|
||||
|
||||
new_inits = scm_make_list (scm_length (inits), const_unbound);
|
||||
|
||||
|
||||
seq = SCM_EOL, symwalk = syms;
|
||||
|
||||
/* Required arguments may need boxing. */
|
||||
|
|
@ -1511,7 +1511,7 @@ convert_assignment (SCM exp, SCM assigned)
|
|||
|
||||
case SCM_EXPANDED_LETREC:
|
||||
{
|
||||
SCM src, names, syms, vals, unbound, boxes, body;
|
||||
SCM src, names, syms, vals, empty_box, boxes, body;
|
||||
|
||||
src = REF (exp, LETREC, SRC);
|
||||
names = REF (exp, LETREC, NAMES);
|
||||
|
|
@ -1519,10 +1519,11 @@ convert_assignment (SCM exp, SCM assigned)
|
|||
vals = convert_assignment (REF (exp, LETREC, VALS), assigned);
|
||||
body = convert_assignment (REF (exp, LETREC, BODY), assigned);
|
||||
|
||||
unbound = PRIMCALL (SCM_BOOL_F,
|
||||
scm_from_latin1_symbol ("make-undefined-variable"),
|
||||
SCM_EOL);
|
||||
boxes = scm_make_list (scm_length (names), unbound);
|
||||
empty_box =
|
||||
PRIMCALL (SCM_BOOL_F,
|
||||
scm_from_latin1_symbol ("make-undefined-variable"),
|
||||
SCM_EOL);
|
||||
boxes = scm_make_list (scm_length (names), empty_box);
|
||||
|
||||
if (scm_is_true (REF (exp, LETREC, IN_ORDER_P)))
|
||||
return LET
|
||||
|
|
|
|||
|
|
@ -119,9 +119,9 @@ scm_t_bits scm_tc16_memoized;
|
|||
scm_list_1 (SCM_I_MAKINUM (nreq))
|
||||
#define REST_ARITY(nreq, rest) \
|
||||
scm_list_2 (SCM_I_MAKINUM (nreq), rest)
|
||||
#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 FULL_ARITY(nreq, rest, nopt, kw, ninits, unbound, alt) \
|
||||
scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, \
|
||||
SCM_I_MAKINUM (ninits), unbound, alt, SCM_UNDEFINED)
|
||||
#define MAKMEMO_LAMBDA(body, arity, meta) \
|
||||
MAKMEMO (SCM_M_LAMBDA, \
|
||||
scm_cons (body, scm_cons (meta, arity)))
|
||||
|
|
@ -418,8 +418,8 @@ memoize (SCM exp, SCM env)
|
|||
case SCM_EXPANDED_LAMBDA_CASE:
|
||||
{
|
||||
SCM req, rest, opt, kw, inits, vars, body, alt;
|
||||
SCM walk, minits, arity, rib, new_env;
|
||||
int nreq, nopt;
|
||||
SCM unbound, arity, rib;
|
||||
int nreq, nopt, ninits;
|
||||
|
||||
req = REF (exp, LAMBDA_CASE, REQ);
|
||||
rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
|
||||
|
|
@ -432,17 +432,12 @@ memoize (SCM exp, SCM env)
|
|||
|
||||
nreq = scm_ilength (req);
|
||||
nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
|
||||
|
||||
/* The vars are the gensyms, according to the divine plan. But we need
|
||||
to memoize the inits within their appropriate environment,
|
||||
complicating things. */
|
||||
ninits = scm_ilength (inits);
|
||||
/* This relies on assignment conversion turning inits into a
|
||||
sequence of CONST expressions whose values are a unique
|
||||
"unbound" token. */
|
||||
unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F;
|
||||
rib = scm_vector (vars);
|
||||
new_env = scm_cons (rib, env);
|
||||
|
||||
minits = SCM_EOL;
|
||||
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))
|
||||
{
|
||||
|
|
@ -468,12 +463,13 @@ memoize (SCM exp, SCM env)
|
|||
arity = REST_ARITY (nreq, SCM_BOOL_T);
|
||||
}
|
||||
else if (scm_is_true (alt))
|
||||
arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
|
||||
arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
|
||||
SCM_MEMOIZED_ARGS (memoize (alt, env)));
|
||||
else
|
||||
arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
|
||||
arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
|
||||
SCM_BOOL_F);
|
||||
|
||||
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
|
||||
return MAKMEMO_LAMBDA (memoize (body, scm_cons (rib, env)), arity,
|
||||
SCM_BOOL_F /* meta, filled in later */);
|
||||
}
|
||||
|
||||
|
|
@ -497,64 +493,6 @@ memoize (SCM exp, SCM env)
|
|||
(MAKMEMO_LET (inits, memoize (body, new_env)), env);
|
||||
}
|
||||
|
||||
case SCM_EXPANDED_LETREC:
|
||||
{
|
||||
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));
|
||||
|
||||
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, capture_env (env));
|
||||
|
||||
if (in_order_p)
|
||||
{
|
||||
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);
|
||||
}
|
||||
return maybe_makmemo_capture_module
|
||||
(MAKMEMO_LET (undefs, body_exps), env);
|
||||
}
|
||||
else
|
||||
{
|
||||
SCM sets = SCM_BOOL_F, inits = scm_c_make_vector (nvars, SCM_BOOL_F);
|
||||
for (i = nvars - 1; i >= 0; i--)
|
||||
{
|
||||
SCM init, set;
|
||||
|
||||
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);
|
||||
|
||||
return maybe_makmemo_capture_module
|
||||
(MAKMEMO_LET (undefs,
|
||||
MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
|
||||
memoize (body, new_env))),
|
||||
env);
|
||||
}
|
||||
}
|
||||
|
||||
default:
|
||||
abort ();
|
||||
}
|
||||
|
|
@ -670,7 +608,7 @@ unmemoize (const SCM expr)
|
|||
{
|
||||
SCM alt, tail;
|
||||
|
||||
alt = CADDR (CDDDR (spec));
|
||||
alt = CADDDR (CDDDR (spec));
|
||||
if (scm_is_true (alt))
|
||||
tail = CDR (unmemoize (alt));
|
||||
else
|
||||
|
|
@ -682,7 +620,7 @@ unmemoize (const SCM expr)
|
|||
CADR (spec),
|
||||
CADDR (spec),
|
||||
CADDDR (spec),
|
||||
unmemoize_exprs (CADR (CDDDR (spec)))),
|
||||
CADR (CDDDR (spec))),
|
||||
unmemoize (body)),
|
||||
tail));
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue