1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 12:20: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 2014-12-05 16:54:35 +01:00
parent 7974c57937
commit cfdc8416a2
4 changed files with 70 additions and 187 deletions

View file

@ -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;
}

View file

@ -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,
@ -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,
empty_box =
PRIMCALL (SCM_BOOL_F,
scm_from_latin1_symbol ("make-undefined-variable"),
SCM_EOL);
boxes = scm_make_list (scm_length (names), unbound);
boxes = scm_make_list (scm_length (names), empty_box);
if (scm_is_true (REF (exp, LETREC, IN_ORDER_P)))
return LET

View file

@ -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));
}

View file

@ -329,16 +329,10 @@
;; of arguments, and some rest arities; see make-fixed-closure and
;; make-rest-closure above.
;; A unique marker for unbound keywords. NB: There should be no
;; other instance of '(unbound-arg) in this compilation unit, so
;; that this marker is indeed unique. It's a hack, but it allows
;; the constant to propagate to inner closures, reducing free
;; variable counts all around, so it is important for perf.
(define unbound-arg '(unbound-arg))
;; Procedures with rest, optional, or keyword arguments, potentially with
;; multiple arities, as with case-lambda.
(define (make-general-closure env body nreq rest? nopt kw inits alt)
(define (make-general-closure env body nreq rest? nopt kw ninits unbound
alt)
(define alt-proc
(and alt ; (body meta nreq ...)
(let* ((body (car alt))
@ -348,9 +342,11 @@
(tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
(nopt (if tail (car tail) 0))
(kw (and tail (cadr tail)))
(inits (if tail (caddr tail) '()))
(alt (and tail (cadddr tail))))
(make-general-closure env body nreq rest nopt kw inits alt))))
(ninits (if tail (caddr tail) 0))
(unbound (and tail (cadddr tail)))
(alt (and tail (car (cddddr tail)))))
(make-general-closure env body nreq rest nopt kw ninits unbound
alt))))
(define (set-procedure-arity! proc)
(let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
(if (not alt)
@ -367,7 +363,7 @@
(rest?* (if (null? (cdr spec)) #f (cadr spec)))
(tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
(nopt* (if tail (car tail) 0))
(alt* (and tail (cadddr tail))))
(alt* (and tail (car (cddddr tail)))))
(if (or (< nreq* nreq)
(and (= nreq* nreq)
(if rest?
@ -395,8 +391,8 @@
"eval" "Wrong number of arguments"
'() #f))))
(else
(let* ((nvals (+ nreq (if rest? 1 0) (length inits)))
(env (make-env nvals unbound-arg env)))
(let* ((nvals (+ nreq (if rest? 1 0) ninits))
(env (make-env nvals unbound env)))
(let lp ((i 0) (args %args))
(cond
((< i nreq)
@ -405,39 +401,30 @@
(lp (1+ i) (cdr args)))
((not kw)
;; Optional args (possibly), but no keyword args.
(let lp ((i i) (args args) (inits inits))
(let lp ((i i) (args args))
(cond
((< i (+ nreq nopt))
(cond
((< i nargs)
((and (< i (+ nreq nopt)) (< 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)))))
(lp (1+ i) (cdr args)))
(else
(when rest?
(env-set! env 0 i args))
(env-set! env 0 (+ nreq nopt) args))
(eval body env)))))
(else
;; Optional args. As before, but stop at the first
;; keyword.
(let lp ((i i) (args args) (inits inits))
(let lp ((i i) (args args))
(cond
((< i (+ nreq nopt))
(cond
((and (< i nargs) (not (keyword? (car args))))
((and (< i (+ nreq nopt))
(< 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)))))
(lp (1+ i) (cdr args)))
(else
(when rest?
(env-set! env 0 i args))
(env-set! env 0 (+ nreq nopt) args))
(let ((aok (car kw))
(kw (cdr kw))
(kw-base (if rest? (1+ i) i)))
(kw (cdr kw)))
;; Now scan args for keywords.
(let lp ((args args))
(cond
@ -462,20 +449,9 @@
((scm-error 'keyword-argument-error
"eval" "Invalid keyword"
'() (list (car args))))))
(else
;; Finished parsing keywords. Fill in
;; uninitialized kwargs by evalling init
;; expressions in their appropriate
;; environment.
(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)
@ -513,9 +489,10 @@
(if (null? tail)
(make-rest-closure eval nreq body env)
(mx-bind
tail (nopt kw inits alt)
tail (nopt kw ninits unbound alt)
(make-general-closure env body nreq rest?
nopt kw inits alt)))))))
nopt kw ninits unbound
alt)))))))
(let lp ((meta meta))
(unless (null? meta)
(set-procedure-property! proc (caar meta) (cdar meta))