[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/06: Simplify the interpreter for trivial inits and no
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/06: Simplify the interpreter for trivial inits and no letrec |
|
Date: |
Mon, 08 Dec 2014 10:50:26 +0000 |
wingo pushed a commit to branch wip-closure-conversion
in repository guile.
commit cfdc8416a2540e43504a021d4f7c44c7d21a668d
Author: Andy Wingo <address@hidden>
Date: Fri Dec 5 16:54:35 2014 +0100
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.
---
libguile/eval.c | 67 +++++++++--------------------------
libguile/expand.c | 17 +++++----
libguile/memoize.c | 94 ++++++++----------------------------------------
module/ice-9/eval.scm | 79 ++++++++++++++--------------------------
4 files changed, 70 insertions(+), 187 deletions(-)
diff --git a/libguile/eval.c b/libguile/eval.c
index 2488ee2..d76fbd3 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -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;
}
diff --git a/libguile/expand.c b/libguile/expand.c
index 1d511e6..e1c6c18 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -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
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 36766e8..9651cad 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -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));
}
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 89d17cd..98db033 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -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)
- (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)))))
+ ((and (< i (+ nreq nopt)) (< i nargs))
+ (env-set! env 0 i (car args))
+ (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))))
- (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)))))
+ ((and (< i (+ nreq nopt))
+ (< i nargs)
+ (not (keyword? (car args))))
+ (env-set! env 0 i (car args))
+ (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
@@ -463,19 +450,8 @@
"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)))))))))))))))))))))
+ ;; Finally, eval the body.
+ (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))
- [Guile-commits] branch wip-closure-conversion created (now 5bfc065), Andy Wingo, 2014/12/08
- [Guile-commits] 03/06: Add capture-env to evaluator, Andy Wingo, 2014/12/08
- [Guile-commits] 06/06: Minor evaluator tweaks, Andy Wingo, 2014/12/08
- [Guile-commits] 04/06: Closure conversion in evaluator, Andy Wingo, 2014/12/08
- [Guile-commits] 01/06: Assignment conversion in the interpreter, Andy Wingo, 2014/12/08
- [Guile-commits] 05/06: Simplify variable resolution in the evaluator, Andy Wingo, 2014/12/08
- [Guile-commits] 02/06: Simplify the interpreter for trivial inits and no letrec,
Andy Wingo <=