mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-05 09:10:18 +02:00
Code Activity

DRAFT: Scheme eval: Add source annotations to generated procedures.

Browse source
This commit is contained in:
Mark H Weaver 2019-06-01 02:39:57 -04:00
parent 28c2b44f6d
commit 716e02b85d
6 changed files with 376 additions and 301 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/eval.c
View file

@ -429,7 +429,7 @@ eval (SCM x, SCM env)
SCM var; SCM var;
var = scm_sys_resolve_variable (mx, env_tail (env)); var = scm_sys_resolve_variable (mx, env_tail (env));
scm_set_cdr_x (x, var); SCM_SET_MEMOIZED_ARGS (x, var);
return var; return var;
} }

132
libguile/expand.c
View file

@ -380,7 +380,7 @@ expand (SCM exp, SCM env)
return TOPLEVEL_REF (SCM_BOOL_F, exp); return TOPLEVEL_REF (SCM_BOOL_F, exp);
} }
else else
return CONST_ (SCM_BOOL_F, exp); return CONST_ (scm_source_properties (exp), exp);
} }
static SCM static SCM
@ -441,17 +441,21 @@ expand_and (SCM expr, SCM env)
const SCM cdr_expr = CDR (expr); const SCM cdr_expr = CDR (expr);
if (scm_is_null (cdr_expr)) if (scm_is_null (cdr_expr))
return CONST_ (SCM_BOOL_F, SCM_BOOL_T); return CONST_ (scm_source_properties (expr), SCM_BOOL_T);
ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr); ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
if (scm_is_null (CDR (cdr_expr))) if (scm_is_null (CDR (cdr_expr)))
return expand (CAR (cdr_expr), env); return expand (CAR (cdr_expr), env);
else else
return CONDITIONAL (scm_source_properties (expr), {
expand (CAR (cdr_expr), env), SCM src = scm_source_properties (expr);
expand_and (cdr_expr, env),
CONST_ (SCM_BOOL_F, SCM_BOOL_F)); return CONDITIONAL (src,
expand (CAR (cdr_expr), env),
expand_and (cdr_expr, env),
CONST_ (src, SCM_BOOL_F));
}
} }
static SCM static SCM
@ -479,7 +483,7 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
} }
if (scm_is_null (rest)) if (scm_is_null (rest))
rest = VOID_ (SCM_BOOL_F); rest = VOID_ (scm_source_properties (clause));
else else
rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env); rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);
@ -489,23 +493,23 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
{ {
SCM tmp = scm_gensym (scm_from_utf8_string ("cond ")); SCM tmp = scm_gensym (scm_from_utf8_string ("cond "));
SCM new_env = scm_acons (tmp, tmp, env); SCM new_env = scm_acons (tmp, tmp, env);
SCM src = scm_source_properties (clause);
ASSERT_SYNTAX (length > 2, s_missing_recipient, clause); ASSERT_SYNTAX (length > 2, s_missing_recipient, clause);
ASSERT_SYNTAX (length == 3, s_extra_expression, clause); ASSERT_SYNTAX (length == 3, s_extra_expression, clause);
return LET (SCM_BOOL_F, return LET (src,
scm_list_1 (tmp), scm_list_1 (tmp),
scm_list_1 (tmp), scm_list_1 (tmp),
scm_list_1 (expand (test, env)), scm_list_1 (expand (test, env)),
CONDITIONAL (SCM_BOOL_F, CONDITIONAL (src,
LEXICAL_REF (SCM_BOOL_F, tmp, tmp), LEXICAL_REF (src, tmp, tmp),
CALL (SCM_BOOL_F, CALL (src,
expand (CADDR (clause), new_env), expand (CADDR (clause), new_env),
scm_list_1 (LEXICAL_REF (SCM_BOOL_F, scm_list_1 (LEXICAL_REF (src, tmp, tmp))),
tmp, tmp))),
rest)); rest));
} }
/* FIXME length == 1 case */ /* FIXME length == 1 case */
else else
return CONDITIONAL (SCM_BOOL_F, return CONDITIONAL (scm_source_properties (clause),
expand (test, env), expand (test, env),
expand_sequence (CDR (clause), env), expand_sequence (CDR (clause), env),
rest); rest);
@ -580,13 +584,14 @@ expand_if (SCM expr, SCM env SCM_UNUSED)
{ {
const SCM cdr_expr = CDR (expr); const SCM cdr_expr = CDR (expr);
const long length = scm_ilength (cdr_expr); const long length = scm_ilength (cdr_expr);
SCM src = scm_source_properties (expr);
ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr); ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
return CONDITIONAL (scm_source_properties (expr), return CONDITIONAL (src,
expand (CADR (expr), env), expand (CADR (expr), env),
expand (CADDR (expr), env), expand (CADDR (expr), env),
((length == 3) ((length == 3)
? expand (CADDDR (expr), env) ? expand (CADDDR (expr), env)
: VOID_ (SCM_BOOL_F))); : VOID_ (src)));
} }
/* A helper function for expand_lambda to support checking for duplicate /* A helper function for expand_lambda to support checking for duplicate
@ -664,7 +669,7 @@ expand_lambda_case (SCM clause, SCM alternate, SCM env)
if (scm_is_true (alternate) && !(SCM_EXPANDED_P (alternate) && SCM_EXPANDED_TYPE (alternate) == SCM_EXPANDED_LAMBDA_CASE)) if (scm_is_true (alternate) && !(SCM_EXPANDED_P (alternate) && SCM_EXPANDED_TYPE (alternate) == SCM_EXPANDED_LAMBDA_CASE))
abort (); abort ();
return LAMBDA_CASE (SCM_BOOL_F, req, SCM_BOOL_F, rest, SCM_BOOL_F, return LAMBDA_CASE (scm_source_properties (clause), req, SCM_BOOL_F, rest, SCM_BOOL_F,
SCM_EOL, vars, body, alternate); SCM_EOL, vars, body, alternate);
} }
@ -843,7 +848,7 @@ expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
inits = scm_reverse_x (inits, SCM_UNDEFINED); inits = scm_reverse_x (inits, SCM_UNDEFINED);
body = expand_sequence (body, env); body = expand_sequence (body, env);
return LAMBDA_CASE (SCM_BOOL_F, req, opt, rest, kw, inits, vars, body, return LAMBDA_CASE (scm_source_properties (clause), req, opt, rest, kw, inits, vars, body,
alternate); alternate);
} }
@ -963,6 +968,7 @@ expand_named_let (const SCM expr, SCM env)
const SCM name = CAR (cdr_expr); const SCM name = CAR (cdr_expr);
const SCM cddr_expr = CDR (cdr_expr); const SCM cddr_expr = CDR (cdr_expr);
const SCM bindings = CAR (cddr_expr); const SCM bindings = CAR (cddr_expr);
const SCM src = scm_source_properties (expr);
check_bindings (bindings, expr); check_bindings (bindings, expr);
transform_bindings (bindings, expr, &var_names, &var_syms, &inits); transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
@ -971,16 +977,16 @@ expand_named_let (const SCM expr, SCM env)
inner_env = expand_env_extend (inner_env, var_names, var_syms); inner_env = expand_env_extend (inner_env, var_names, var_syms);
return LETREC return LETREC
(scm_source_properties (expr), SCM_BOOL_F, (src, SCM_BOOL_F,
scm_list_1 (name), scm_list_1 (name_sym), scm_list_1 (name), scm_list_1 (name_sym),
scm_list_1 (LAMBDA (SCM_BOOL_F, scm_list_1 (LAMBDA (src,
SCM_EOL, SCM_EOL,
LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F, LAMBDA_CASE (src, var_names, SCM_EOL, SCM_BOOL_F,
SCM_BOOL_F, SCM_EOL, var_syms, SCM_BOOL_F, SCM_EOL, var_syms,
expand_sequence (CDDDR (expr), inner_env), expand_sequence (CDDDR (expr), inner_env),
SCM_BOOL_F))), SCM_BOOL_F))),
CALL (SCM_BOOL_F, CALL (src,
LEXICAL_REF (SCM_BOOL_F, name, name_sym), LEXICAL_REF (src, name, name_sym),
expand_exprs (inits, env))); expand_exprs (inits, env)));
} }
@ -1008,7 +1014,7 @@ expand_let (SCM expr, SCM env)
{ {
SCM var_names, var_syms, inits; SCM var_names, var_syms, inits;
transform_bindings (bindings, expr, &var_names, &var_syms, &inits); transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
return LET (SCM_BOOL_F, return LET (scm_source_properties (expr),
var_names, var_syms, expand_exprs (inits, env), var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr), expand_sequence (CDDR (expr),
expand_env_extend (env, var_names, expand_env_extend (env, var_names,
@ -1035,7 +1041,7 @@ expand_letrec_helper (SCM expr, SCM env, SCM in_order_p)
SCM var_names, var_syms, inits; SCM var_names, var_syms, inits;
transform_bindings (bindings, expr, &var_names, &var_syms, &inits); transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
env = expand_env_extend (env, var_names, var_syms); env = expand_env_extend (env, var_names, var_syms);
return LETREC (SCM_BOOL_F, in_order_p, return LETREC (scm_source_properties (expr), in_order_p,
var_names, var_syms, expand_exprs (inits, env), var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr), env)); expand_sequence (CDDR (expr), env));
} }
@ -1069,7 +1075,7 @@ expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
sym = scm_gensym (SCM_UNDEFINED); sym = scm_gensym (SCM_UNDEFINED);
init = CADR (bind); init = CADR (bind);
return LET (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (sym), return LET (scm_source_properties (bindings), scm_list_1 (name), scm_list_1 (sym),
scm_list_1 (expand (init, env)), scm_list_1 (expand (init, env)),
expand_letstar_clause (CDR (bindings), body, expand_letstar_clause (CDR (bindings), body,
scm_acons (name, sym, env))); scm_acons (name, sym, env)));
@ -1091,20 +1097,21 @@ expand_or (SCM expr, SCM env SCM_UNUSED)
{ {
SCM tail = CDR (expr); SCM tail = CDR (expr);
const long length = scm_ilength (tail); const long length = scm_ilength (tail);
SCM src = scm_source_properties (expr);
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
if (scm_is_null (CDR (expr))) if (scm_is_null (CDR (expr)))
return CONST_ (SCM_BOOL_F, SCM_BOOL_F); return CONST_ (src, SCM_BOOL_F);
else else
{ {
SCM tmp = scm_gensym (SCM_UNDEFINED); SCM tmp = scm_gensym (SCM_UNDEFINED);
return LET (SCM_BOOL_F, return LET (src,
scm_list_1 (tmp), scm_list_1 (tmp), scm_list_1 (tmp), scm_list_1 (tmp),
scm_list_1 (expand (CADR (expr), env)), scm_list_1 (expand (CADR (expr), env)),
CONDITIONAL (SCM_BOOL_F, CONDITIONAL (src,
LEXICAL_REF (SCM_BOOL_F, tmp, tmp), LEXICAL_REF (src, tmp, tmp),
LEXICAL_REF (SCM_BOOL_F, tmp, tmp), LEXICAL_REF (src, tmp, tmp),
expand_or (CDR (expr), expand_or (CDR (expr),
scm_acons (tmp, tmp, env)))); scm_acons (tmp, tmp, env))));
} }
@ -1277,17 +1284,17 @@ compute_assigned (SCM exp, SCM assigned)
} }
static SCM static SCM
box_value (SCM exp) box_value (SCM src, SCM exp)
{ {
return PRIMCALL (SCM_BOOL_F, scm_from_latin1_symbol ("make-variable"), return PRIMCALL (src, scm_from_latin1_symbol ("make-variable"),
scm_list_1 (exp)); scm_list_1 (exp));
} }
static SCM static SCM
box_lexical (SCM name, SCM sym) box_lexical (SCM src, SCM name, SCM sym)
{ {
return LEXICAL_SET (SCM_BOOL_F, name, sym, return LEXICAL_SET (src, name, sym,
box_value (LEXICAL_REF (SCM_BOOL_F, name, sym))); box_value (src, LEXICAL_REF (SCM_BOOL_F, name, sym)));
} }
static SCM static SCM
@ -1407,24 +1414,27 @@ convert_assignment (SCM exp, SCM assigned)
convert_assignment (REF (exp, SEQ, TAIL), assigned)); convert_assignment (REF (exp, SEQ, TAIL), assigned));
case SCM_EXPANDED_LAMBDA: case SCM_EXPANDED_LAMBDA:
return LAMBDA {
(REF (exp, LAMBDA, SRC), SCM src = scm_source_properties (exp);
REF (exp, LAMBDA, META), return LAMBDA
scm_is_false (REF (exp, LAMBDA, BODY)) (REF (exp, LAMBDA, SRC),
/* Give a body to case-lambda with no clauses. */ REF (exp, LAMBDA, META),
? LAMBDA_CASE (SCM_BOOL_F, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F, scm_is_false (REF (exp, LAMBDA, BODY))
SCM_EOL, SCM_EOL, /* Give a body to case-lambda with no clauses. */
PRIMCALL ? LAMBDA_CASE (src, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F,
(SCM_BOOL_F, SCM_EOL, SCM_EOL,
scm_from_latin1_symbol ("throw"), PRIMCALL
scm_list_5 (CONST_ (SCM_BOOL_F, scm_args_number_key), (src,
CONST_ (SCM_BOOL_F, SCM_BOOL_F), scm_from_latin1_symbol ("throw"),
CONST_ (SCM_BOOL_F, scm_from_latin1_string scm_list_5 (CONST_ (src, scm_args_number_key),
("Wrong number of arguments")), CONST_ (src, SCM_BOOL_F),
CONST_ (SCM_BOOL_F, SCM_EOL), CONST_ (src, scm_from_latin1_string
CONST_ (SCM_BOOL_F, SCM_BOOL_F))), ("Wrong number of arguments")),
SCM_BOOL_F) CONST_ (src, SCM_EOL),
: convert_assignment (REF (exp, LAMBDA, BODY), assigned)); CONST_ (src, SCM_BOOL_F))),
SCM_BOOL_F)
: convert_assignment (REF (exp, LAMBDA, BODY), assigned));
}
case SCM_EXPANDED_LAMBDA_CASE: case SCM_EXPANDED_LAMBDA_CASE:
{ {
@ -1456,7 +1466,7 @@ convert_assignment (SCM exp, SCM assigned)
{ {
SCM name = CAR (namewalk), sym = CAR (symwalk); SCM name = CAR (namewalk), sym = CAR (symwalk);
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
seq = scm_cons (box_lexical (name, sym), seq); seq = scm_cons (box_lexical (src, name, sym), seq);
} }
/* Optional arguments may need initialization and/or boxing. */ /* Optional arguments may need initialization and/or boxing. */
for (namewalk = opt; for (namewalk = opt;
@ -1467,7 +1477,7 @@ convert_assignment (SCM exp, SCM assigned)
SCM name = CAR (namewalk), sym = CAR (symwalk), init = CAR (inits); SCM name = CAR (namewalk), sym = CAR (symwalk), init = CAR (inits);
seq = scm_cons (init_if_unbound (src, name, sym, init), seq); seq = scm_cons (init_if_unbound (src, name, sym, init), seq);
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
seq = scm_cons (box_lexical (name, sym), seq); seq = scm_cons (box_lexical (src, name, sym), seq);
} }
/* Rest arguments may need boxing. */ /* Rest arguments may need boxing. */
if (scm_is_true (rest)) if (scm_is_true (rest))
@ -1475,7 +1485,7 @@ convert_assignment (SCM exp, SCM assigned)
SCM sym = CAR (symwalk); SCM sym = CAR (symwalk);
symwalk = CDR (symwalk); symwalk = CDR (symwalk);
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
seq = scm_cons (box_lexical (rest, sym), seq); seq = scm_cons (box_lexical (src, rest, sym), seq);
} }
/* The rest of the arguments, if any, are keyword arguments, /* The rest of the arguments, if any, are keyword arguments,
which may need initialization and/or boxing. */ which may need initialization and/or boxing. */
@ -1486,7 +1496,7 @@ convert_assignment (SCM exp, SCM assigned)
SCM sym = CAR (symwalk), init = CAR (inits); SCM sym = CAR (symwalk), init = CAR (inits);
seq = scm_cons (init_if_unbound (src, SCM_BOOL_F, sym, init), seq); seq = scm_cons (init_if_unbound (src, SCM_BOOL_F, sym, init), seq);
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
seq = scm_cons (box_lexical (SCM_BOOL_F, sym), seq); seq = scm_cons (box_lexical (src, SCM_BOOL_F, sym), seq);
} }
for (; scm_is_pair (seq); seq = CDR (seq)) for (; scm_is_pair (seq); seq = CDR (seq))
@ -1512,7 +1522,7 @@ convert_assignment (SCM exp, SCM assigned)
{ {
SCM sym = CAR (walk), val = CAR (vals); SCM sym = CAR (walk), val = CAR (vals);
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
new_vals = scm_cons (box_value (val), new_vals); new_vals = scm_cons (box_value (src, val), new_vals);
else else
new_vals = scm_cons (val, new_vals); new_vals = scm_cons (val, new_vals);
} }
@ -1532,7 +1542,7 @@ convert_assignment (SCM exp, SCM assigned)
body = convert_assignment (REF (exp, LETREC, BODY), assigned); body = convert_assignment (REF (exp, LETREC, BODY), assigned);
empty_box = empty_box =
PRIMCALL (SCM_BOOL_F, PRIMCALL (src,
scm_from_latin1_symbol ("make-undefined-variable"), scm_from_latin1_symbol ("make-undefined-variable"),
SCM_EOL); SCM_EOL);
boxes = scm_make_list (scm_length (names), empty_box); boxes = scm_make_list (scm_length (names), empty_box);
@ -1549,7 +1559,7 @@ convert_assignment (SCM exp, SCM assigned)
{ {
SCM tmp = scm_gensym (SCM_UNDEFINED); SCM tmp = scm_gensym (SCM_UNDEFINED);
tmps = scm_cons (tmp, tmps); tmps = scm_cons (tmp, tmps);
inits = scm_cons (LEXICAL_REF (SCM_BOOL_F, SCM_BOOL_F, tmp), inits = scm_cons (LEXICAL_REF (src, SCM_BOOL_F, tmp),
inits); inits);
} }
tmps = scm_reverse (tmps); tmps = scm_reverse (tmps);

209
libguile/memoize.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-2015,2018 /* Copyright 1995-2016,2018,2019
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -136,57 +136,55 @@ do_pop_dynamic_state (void)
/* {Evaluator memoized expressions} /* {Evaluator memoized expressions}
*/ */
scm_t_bits scm_tc16_memoized; #define MAKMEMO(n, src, args) \
(scm_cons (SCM_I_MAKINUM (n), scm_cons (src, args)))
#define MAKMEMO(n, args) \ #define MAKMEMO_SEQ(src, head, tail) \
(scm_cons (SCM_I_MAKINUM (n), args)) MAKMEMO (SCM_M_SEQ, src, scm_cons (head, tail))
#define MAKMEMO_IF(src, test, then, else_) \
#define MAKMEMO_SEQ(head,tail) \ MAKMEMO (SCM_M_IF, src, scm_cons (test, scm_cons (then, else_)))
MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
#define MAKMEMO_IF(test, then, else_) \
MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
#define FIXED_ARITY(nreq) \ #define FIXED_ARITY(nreq) \
scm_list_1 (SCM_I_MAKINUM (nreq)) scm_list_1 (SCM_I_MAKINUM (nreq))
#define REST_ARITY(nreq, rest) \ #define REST_ARITY(nreq, rest) \
scm_list_2 (SCM_I_MAKINUM (nreq), rest) scm_list_2 (SCM_I_MAKINUM (nreq), rest)
#define FULL_ARITY(nreq, rest, nopt, kw, ninits, unbound, alt) \ #define FULL_ARITY(nreq, rest, nopt, kw, ninits, unbound, alt) \
scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, \ scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, \
SCM_I_MAKINUM (ninits), unbound, alt, SCM_UNDEFINED) SCM_I_MAKINUM (ninits), unbound, alt, SCM_UNDEFINED)
#define MAKMEMO_LAMBDA(body, arity, meta) \ #define MAKMEMO_LAMBDA(src, body, arity, meta) \
MAKMEMO (SCM_M_LAMBDA, \ MAKMEMO (SCM_M_LAMBDA, src, \
scm_cons (body, scm_cons (meta, arity))) scm_cons (body, scm_cons (meta, arity)))
#define MAKMEMO_CAPTURE_ENV(vars, body) \ #define MAKMEMO_CAPTURE_ENV(src, vars, body) \
MAKMEMO (SCM_M_CAPTURE_ENV, scm_cons (vars, body)) MAKMEMO (SCM_M_CAPTURE_ENV, src, scm_cons (vars, body))
#define MAKMEMO_LET(inits, body) \ #define MAKMEMO_LET(src, inits, body) \
MAKMEMO (SCM_M_LET, scm_cons (inits, body)) MAKMEMO (SCM_M_LET, src, scm_cons (inits, body))
#define MAKMEMO_QUOTE(exp) \ #define MAKMEMO_QUOTE(src, exp) \
MAKMEMO (SCM_M_QUOTE, exp) MAKMEMO (SCM_M_QUOTE, src, exp)
#define MAKMEMO_CAPTURE_MODULE(exp) \ #define MAKMEMO_CAPTURE_MODULE(src, exp) \
MAKMEMO (SCM_M_CAPTURE_MODULE, exp) MAKMEMO (SCM_M_CAPTURE_MODULE, src, exp)
#define MAKMEMO_APPLY(proc, args)\ #define MAKMEMO_APPLY(src, proc, args) \
MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args)) MAKMEMO (SCM_M_APPLY, src, scm_list_2 (proc, args))
#define MAKMEMO_CONT(proc) \ #define MAKMEMO_CONT(src, proc) \
MAKMEMO (SCM_M_CONT, proc) MAKMEMO (SCM_M_CONT, src, proc)
#define MAKMEMO_CALL_WITH_VALUES(prod, cons) \ #define MAKMEMO_CALL_WITH_VALUES(src, prod, cons) \
MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons)) MAKMEMO (SCM_M_CALL_WITH_VALUES, src, scm_cons (prod, cons))
#define MAKMEMO_CALL(proc, args) \ #define MAKMEMO_CALL(src, proc, args) \
MAKMEMO (SCM_M_CALL, scm_cons (proc, args)) MAKMEMO (SCM_M_CALL, src, scm_cons (proc, args))
#define MAKMEMO_LEX_REF(pos) \ #define MAKMEMO_LEX_REF(src, pos) \
MAKMEMO (SCM_M_LEXICAL_REF, pos) MAKMEMO (SCM_M_LEXICAL_REF, src, pos)
#define MAKMEMO_LEX_SET(pos, val) \ #define MAKMEMO_LEX_SET(src, pos, val) \
MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val)) MAKMEMO (SCM_M_LEXICAL_SET, src, scm_cons (pos, val))
#define MAKMEMO_BOX_REF(box) \ #define MAKMEMO_BOX_REF(src, box) \
MAKMEMO (SCM_M_BOX_REF, box) MAKMEMO (SCM_M_BOX_REF, src, box)
#define MAKMEMO_BOX_SET(box, val) \ #define MAKMEMO_BOX_SET(src, box, val) \
MAKMEMO (SCM_M_BOX_SET, scm_cons (box, val)) MAKMEMO (SCM_M_BOX_SET, src, scm_cons (box, val))
#define MAKMEMO_TOP_BOX(mode, var) \ #define MAKMEMO_TOP_BOX(src, mode, var) \
MAKMEMO (SCM_M_RESOLVE, scm_cons (SCM_I_MAKINUM (mode), var)) MAKMEMO (SCM_M_RESOLVE, src, scm_cons (SCM_I_MAKINUM (mode), var))
#define MAKMEMO_MOD_BOX(mode, mod, var, public) \ #define MAKMEMO_MOD_BOX(src, mode, mod, var, public) \
MAKMEMO (SCM_M_RESOLVE, \ MAKMEMO (SCM_M_RESOLVE, src, \
scm_cons (SCM_I_MAKINUM (mode), \ scm_cons (SCM_I_MAKINUM (mode), \
scm_cons (mod, scm_cons (var, public)))) scm_cons (mod, scm_cons (var, public))))
#define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \ #define MAKMEMO_CALL_WITH_PROMPT(src, tag, thunk, handler) \
MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler))) MAKMEMO (SCM_M_CALL_WITH_PROMPT, src, scm_cons (tag, scm_cons (thunk, handler)))
@ -332,7 +330,7 @@ lookup (SCM x, SCM env)
} }
static SCM static SCM
capture_flat_env (SCM lambda, SCM env) capture_flat_env (SCM src, SCM lambda, SCM env)
{ {
int nenv; int nenv;
SCM vars, link, locs; SCM vars, link, locs;
@ -345,12 +343,16 @@ capture_flat_env (SCM lambda, SCM env)
for (; scm_is_pair (vars); vars = CDR (vars)) for (; scm_is_pair (vars); vars = CDR (vars))
scm_c_vector_set_x (locs, --nenv, CDAR (vars)); scm_c_vector_set_x (locs, --nenv, CDAR (vars));
return MAKMEMO_CAPTURE_ENV (locs, lambda); return MAKMEMO_CAPTURE_ENV (src, locs, lambda);
} }
/* 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) \
(scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field))) (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
#define SRC(x) \
(scm_struct_ref (x, SCM_INUM0)) /* WARNING: this assumes that every
expanded structure starts with
its source. */
static SCM list_of_guile = SCM_BOOL_F; static SCM list_of_guile = SCM_BOOL_F;
@ -374,56 +376,70 @@ capture_env (SCM env)
} }
static SCM static SCM
maybe_makmemo_capture_module (SCM exp, SCM env) maybe_makmemo_capture_module (SCM src, SCM exp, SCM env)
{ {
if (scm_is_false (env)) if (scm_is_false (env))
return MAKMEMO_CAPTURE_MODULE (exp); return MAKMEMO_CAPTURE_MODULE (src, exp);
return exp; return exp;
} }
static SCM static SCM
memoize (SCM exp, SCM env) memoize (SCM exp, SCM env)
{ {
SCM src;
if (!SCM_EXPANDED_P (exp)) if (!SCM_EXPANDED_P (exp))
abort (); abort ();
src = SRC (exp);
switch (SCM_EXPANDED_TYPE (exp)) switch (SCM_EXPANDED_TYPE (exp))
{ {
case SCM_EXPANDED_VOID: case SCM_EXPANDED_VOID:
return MAKMEMO_QUOTE (SCM_UNSPECIFIED); return MAKMEMO_QUOTE (src, SCM_UNSPECIFIED);
case SCM_EXPANDED_CONST: case SCM_EXPANDED_CONST:
return MAKMEMO_QUOTE (REF (exp, CONST, EXP)); return MAKMEMO_QUOTE (src, REF (exp, CONST, EXP));
case SCM_EXPANDED_PRIMITIVE_REF: case SCM_EXPANDED_PRIMITIVE_REF:
if (scm_is_eq (scm_current_module (), scm_the_root_module ())) if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return maybe_makmemo_capture_module return maybe_makmemo_capture_module
(MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF, (src,
MAKMEMO_BOX_REF (src,
MAKMEMO_TOP_BOX (src,
SCM_EXPANDED_TOPLEVEL_REF,
REF (exp, PRIMITIVE_REF, NAME))), REF (exp, PRIMITIVE_REF, NAME))),
env); env);
else else
return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF, return MAKMEMO_BOX_REF (src,
MAKMEMO_MOD_BOX (src,
SCM_EXPANDED_MODULE_REF,
list_of_guile, list_of_guile,
REF (exp, PRIMITIVE_REF, NAME), REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F)); SCM_BOOL_F));
case SCM_EXPANDED_LEXICAL_REF: case SCM_EXPANDED_LEXICAL_REF:
return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env)); return MAKMEMO_LEX_REF (src,
lookup (REF (exp, LEXICAL_REF, GENSYM), env));
case SCM_EXPANDED_LEXICAL_SET: case SCM_EXPANDED_LEXICAL_SET:
return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env), return MAKMEMO_LEX_SET (src,
lookup (REF (exp, LEXICAL_SET, GENSYM), env),
memoize (REF (exp, LEXICAL_SET, EXP), env)); memoize (REF (exp, LEXICAL_SET, EXP), env));
case SCM_EXPANDED_MODULE_REF: case SCM_EXPANDED_MODULE_REF:
return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX return MAKMEMO_BOX_REF (src,
(SCM_EXPANDED_MODULE_REF, MAKMEMO_MOD_BOX
(src,
SCM_EXPANDED_MODULE_REF,
REF (exp, MODULE_REF, MOD), REF (exp, MODULE_REF, MOD),
REF (exp, MODULE_REF, NAME), REF (exp, MODULE_REF, NAME),
REF (exp, MODULE_REF, PUBLIC))); REF (exp, MODULE_REF, PUBLIC)));
case SCM_EXPANDED_MODULE_SET: case SCM_EXPANDED_MODULE_SET:
return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX return MAKMEMO_BOX_SET (src,
(SCM_EXPANDED_MODULE_SET, MAKMEMO_MOD_BOX
(src,
SCM_EXPANDED_MODULE_SET,
REF (exp, MODULE_SET, MOD), REF (exp, MODULE_SET, MOD),
REF (exp, MODULE_SET, NAME), REF (exp, MODULE_SET, NAME),
REF (exp, MODULE_SET, PUBLIC)), REF (exp, MODULE_SET, PUBLIC)),
@ -431,13 +447,19 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_TOPLEVEL_REF: case SCM_EXPANDED_TOPLEVEL_REF:
return maybe_makmemo_capture_module return maybe_makmemo_capture_module
(MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF, (src,
MAKMEMO_BOX_REF (src,
MAKMEMO_TOP_BOX (src,
SCM_EXPANDED_TOPLEVEL_REF,
REF (exp, TOPLEVEL_REF, NAME))), REF (exp, TOPLEVEL_REF, NAME))),
env); env);
case SCM_EXPANDED_TOPLEVEL_SET: case SCM_EXPANDED_TOPLEVEL_SET:
return maybe_makmemo_capture_module return maybe_makmemo_capture_module
(MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET, (src,
MAKMEMO_BOX_SET (src,
MAKMEMO_TOP_BOX (src,
SCM_EXPANDED_TOPLEVEL_SET,
REF (exp, TOPLEVEL_SET, NAME)), REF (exp, TOPLEVEL_SET, NAME)),
memoize (REF (exp, TOPLEVEL_SET, EXP), memoize (REF (exp, TOPLEVEL_SET, EXP),
capture_env (env))), capture_env (env))),
@ -445,14 +467,18 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_TOPLEVEL_DEFINE: case SCM_EXPANDED_TOPLEVEL_DEFINE:
return maybe_makmemo_capture_module return maybe_makmemo_capture_module
(MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE, (src,
MAKMEMO_BOX_SET (src,
MAKMEMO_TOP_BOX (src,
SCM_EXPANDED_TOPLEVEL_DEFINE,
REF (exp, TOPLEVEL_DEFINE, NAME)), REF (exp, TOPLEVEL_DEFINE, NAME)),
memoize (REF (exp, TOPLEVEL_DEFINE, EXP), memoize (REF (exp, TOPLEVEL_DEFINE, EXP),
capture_env (env))), capture_env (env))),
env); env);
case SCM_EXPANDED_CONDITIONAL: case SCM_EXPANDED_CONDITIONAL:
return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env), return MAKMEMO_IF (src,
memoize (REF (exp, CONDITIONAL, TEST), env),
memoize (REF (exp, CONDITIONAL, CONSEQUENT), env), memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
memoize (REF (exp, CONDITIONAL, ALTERNATE), env)); memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
@ -463,7 +489,7 @@ memoize (SCM exp, SCM env)
proc = REF (exp, CALL, PROC); proc = REF (exp, CALL, PROC);
args = memoize_exps (REF (exp, CALL, ARGS), env); args = memoize_exps (REF (exp, CALL, ARGS), env);
return MAKMEMO_CALL (memoize (proc, env), args); return MAKMEMO_CALL (src, memoize (proc, env), args);
} }
case SCM_EXPANDED_PRIMCALL: case SCM_EXPANDED_PRIMCALL:
@ -477,59 +503,71 @@ memoize (SCM exp, SCM env)
if (nargs == 3 if (nargs == 3
&& scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt"))) && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
return MAKMEMO_CALL_WITH_PROMPT (CAR (args), return MAKMEMO_CALL_WITH_PROMPT (src,
CAR (args),
CADR (args), CADR (args),
CADDR (args)); CADDR (args));
else if (nargs == 2 else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("apply"))) && scm_is_eq (name, scm_from_latin1_symbol ("apply")))
return MAKMEMO_APPLY (CAR (args), CADR (args)); return MAKMEMO_APPLY (src, CAR (args), CADR (args));
else if (nargs == 1 else if (nargs == 1
&& scm_is_eq (name, && scm_is_eq (name,
scm_from_latin1_symbol scm_from_latin1_symbol
("call-with-current-continuation"))) ("call-with-current-continuation")))
return MAKMEMO_CONT (CAR (args)); return MAKMEMO_CONT (src, CAR (args));
else if (nargs == 2 else if (nargs == 2
&& scm_is_eq (name, && scm_is_eq (name,
scm_from_latin1_symbol ("call-with-values"))) scm_from_latin1_symbol ("call-with-values")))
return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args)); return MAKMEMO_CALL_WITH_VALUES (src, CAR (args), CADR (args));
else if (nargs == 1 else if (nargs == 1
&& scm_is_eq (name, && scm_is_eq (name,
scm_from_latin1_symbol ("variable-ref"))) scm_from_latin1_symbol ("variable-ref")))
return MAKMEMO_BOX_REF (CAR (args)); return MAKMEMO_BOX_REF (src, CAR (args));
else if (nargs == 2 else if (nargs == 2
&& scm_is_eq (name, && scm_is_eq (name,
scm_from_latin1_symbol ("variable-set!"))) scm_from_latin1_symbol ("variable-set!")))
return MAKMEMO_BOX_SET (CAR (args), CADR (args)); return MAKMEMO_BOX_SET (src, CAR (args), CADR (args));
else if (nargs == 2 else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("wind"))) && scm_is_eq (name, scm_from_latin1_symbol ("wind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), args); return MAKMEMO_CALL (src, MAKMEMO_QUOTE (src, wind), args);
else if (nargs == 0 else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind"))) && scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), SCM_EOL); return MAKMEMO_CALL (src, MAKMEMO_QUOTE (src, unwind), SCM_EOL);
else if (nargs == 2 else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("push-fluid"))) && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), args); return MAKMEMO_CALL (src, MAKMEMO_QUOTE (src, push_fluid), args);
else if (nargs == 0 else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid"))) && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL); return MAKMEMO_CALL (src, MAKMEMO_QUOTE (src, pop_fluid), SCM_EOL);
else if (nargs == 1 else if (nargs == 1
&& scm_is_eq (name, && scm_is_eq (name,
scm_from_latin1_symbol ("push-dynamic-state"))) scm_from_latin1_symbol ("push-dynamic-state")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args); return MAKMEMO_CALL (src,
MAKMEMO_QUOTE (src, push_dynamic_state),
args);
else if (nargs == 0 else if (nargs == 0
&& scm_is_eq (name, && scm_is_eq (name,
scm_from_latin1_symbol ("pop-dynamic-state"))) scm_from_latin1_symbol ("pop-dynamic-state")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL); return MAKMEMO_CALL (src,
MAKMEMO_QUOTE (src, pop_dynamic_state),
SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ())) else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (maybe_makmemo_capture_module return MAKMEMO_CALL (src,
(MAKMEMO_BOX_REF maybe_makmemo_capture_module
(MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF, (src,
MAKMEMO_BOX_REF
(src,
MAKMEMO_TOP_BOX (src,
SCM_EXPANDED_TOPLEVEL_REF,
name)), name)),
env), env),
args); args);
else else
return MAKMEMO_CALL (MAKMEMO_BOX_REF return MAKMEMO_CALL (src,
(MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF, MAKMEMO_BOX_REF
(src,
MAKMEMO_MOD_BOX (src,
SCM_EXPANDED_MODULE_REF,
list_of_guile, list_of_guile,
name, name,
SCM_BOOL_F)), SCM_BOOL_F)),
@ -537,7 +575,8 @@ memoize (SCM exp, SCM env)
} }
case SCM_EXPANDED_SEQ: case SCM_EXPANDED_SEQ:
return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env), return MAKMEMO_SEQ (src,
memoize (REF (exp, SEQ, HEAD), env),
memoize (REF (exp, SEQ, TAIL), env)); memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA: case SCM_EXPANDED_LAMBDA:
@ -551,7 +590,10 @@ memoize (SCM exp, SCM env)
proc = memoize (body, new_env); proc = memoize (body, new_env);
SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta); SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
return maybe_makmemo_capture_module (capture_flat_env (proc, new_env), return maybe_makmemo_capture_module (src,
capture_flat_env (src,
proc,
new_env),
env); env);
} }
@ -610,7 +652,8 @@ memoize (SCM exp, SCM env)
arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound, arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
SCM_BOOL_F); SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity, return MAKMEMO_LAMBDA (src,
memoize (body, new_env), arity,
SCM_EOL /* meta, filled in later */); SCM_EOL /* meta, filled in later */);
} }
@ -631,7 +674,7 @@ memoize (SCM exp, SCM env)
VECTOR_SET (inits, i, memoize (CAR (exps), env)); VECTOR_SET (inits, i, memoize (CAR (exps), env));
return maybe_makmemo_capture_module return maybe_makmemo_capture_module
(MAKMEMO_LET (inits, memoize (body, new_env)), env); (src, MAKMEMO_LET (src, inits, memoize (body, new_env)), env);
} }
default: default:

8
libguile/memoize.h
View file

@ -1,7 +1,7 @@
#ifndef SCM_MEMOIZE_H #ifndef SCM_MEMOIZE_H
#define SCM_MEMOIZE_H #define SCM_MEMOIZE_H
/* Copyright 1995-1996,1998-2002,2004,2008-2011,2013-2014,2018 /* Copyright 1995-1996,1998-2002,2004,2008-2011,2013-2014,2018,2019
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -56,8 +56,10 @@ SCM_API SCM scm_sym_args;
/* {Memoized Source} /* {Memoized Source}
*/ */
#define SCM_MEMOIZED_TAG(x) (scm_to_uint16 (scm_car (x))) #define SCM_MEMOIZED_TAG(x) (scm_to_uint16 (scm_car (x)))
#define SCM_MEMOIZED_ARGS(x) (scm_cdr (x)) #define SCM_MEMOIZED_SRC(x) (scm_cadr (x))
#define SCM_MEMOIZED_ARGS(x) (scm_cddr (x))
#define SCM_SET_MEMOIZED_ARGS(x, v) (scm_set_cdr_x (scm_cdr (x), (v)))
enum enum
{ {

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

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*- ;;; -*- mode: scheme; coding: utf-8; -*-
;;;; Copyright (C) 2009-2015, 2018 Free Software Foundation, Inc. ;;;; Copyright (C) 2009-2015, 2018, 2019 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -111,19 +111,26 @@
(or (memoized-typecode (syntax->datum #'type)) (or (memoized-typecode (syntax->datum #'type))
(error "not a typecode" (syntax->datum #'type))))))) (error "not a typecode" (syntax->datum #'type)))))))
(define-syntax-rule (lazy (arg ...) exp) (define (annotate src proc)
(set-procedure-property! proc 'source-override src)
proc)
(define-syntax-rule (lambda@ src formals body bodies ...)
(annotate src (lambda formals body bodies ...)))
(define-syntax-rule (lazy src (arg ...) exp)
(letrec ((proc (lambda (arg ...) (letrec ((proc (lambda (arg ...)
(set! proc exp) (set! proc exp)
(proc arg ...)))) (proc arg ...))))
(lambda (arg ...) (lambda@ src (arg ...)
(proc arg ...)))) (proc arg ...))))
(define (compile-lexical-ref depth width) (define (compile-lexical-ref src depth width)
(case depth (case depth
((0) (lambda (env) (env-ref env 0 width))) ((0) (lambda@ src (env) (env-ref env 0 width)))
((1) (lambda (env) (env-ref env 1 width))) ((1) (lambda@ src (env) (env-ref env 1 width)))
((2) (lambda (env) (env-ref env 2 width))) ((2) (lambda@ src (env) (env-ref env 2 width)))
(else (lambda (env) (env-ref env depth width))))) (else (lambda@ src (env) (env-ref env depth width)))))
(define (primitive=? name loc module var) (define (primitive=? name loc module var)
"Return true if VAR is the same as the primitive bound to NAME." "Return true if VAR is the same as the primitive bound to NAME."
@ -137,7 +144,7 @@
(or (not module) (or (not module)
(eq? var (module-local-variable the-root-module name))))))) (eq? var (module-local-variable the-root-module name)))))))
(define (compile-top-call cenv loc args) (define (compile-top-call src cenv loc args)
(let* ((module (env-toplevel cenv)) (let* ((module (env-toplevel cenv))
(var (%resolve-variable loc module))) (var (%resolve-variable loc module)))
(define-syntax-rule (maybe-primcall (prim ...) arg ...) (define-syntax-rule (maybe-primcall (prim ...) arg ...)
@ -145,12 +152,12 @@
...) ...)
(cond (cond
((primitive=? 'prim loc module var) ((primitive=? 'prim loc module var)
(lambda (env) (prim (arg env) ...))) (lambda@ src (env) (prim (arg env) ...)))
... ...
(else (lambda (env) ((variable-ref var) (arg env) ...)))))) (else (lambda@ src (env) ((variable-ref var) (arg env) ...))))))
(match args (match args
(() (()
(lambda (env) ((variable-ref var)))) (lambda@ src (env) ((variable-ref var))))
((a) ((a)
(maybe-primcall (1+ 1- car cdr lognot vector-length (maybe-primcall (1+ 1- car cdr lognot vector-length
variable-ref string-length struct-vtable) variable-ref string-length struct-vtable)
@ -169,37 +176,37 @@
(if (null? args) (if (null? args)
'() '()
(cons (compile (car args)) (lp (cdr args))))))) (cons (compile (car args)) (lp (cdr args)))))))
(lambda (env) (lambda@ src (env)
(apply (variable-ref var) (a env) (b env) (c env) (apply (variable-ref var) (a env) (b env) (c env)
(let lp ((args args)) (let lp ((args args))
(if (null? args) (if (null? args)
'() '()
(cons ((car args) env) (lp (cdr args)))))))))))) (cons ((car args) env) (lp (cdr args))))))))))))
(define (compile-call f args) (define (compile-call src f args)
(match f (match f
((,(typecode box-ref) . (,(typecode resolve) . loc)) ((,(typecode box-ref) _ . (,(typecode resolve) _ . loc))
(lazy (env) (compile-top-call env loc args))) (lazy src (env) (compile-top-call src env loc args)))
(_ (_
(match args (match args
(() (()
(let ((f (compile f))) (let ((f (compile f)))
(lambda (env) ((f env))))) (lambda@ src (env) ((f env)))))
((a) ((a)
(let ((f (compile f)) (let ((f (compile f))
(a (compile a))) (a (compile a)))
(lambda (env) ((f env) (a env))))) (lambda@ src (env) ((f env) (a env)))))
((a b) ((a b)
(let ((f (compile f)) (let ((f (compile f))
(a (compile a)) (a (compile a))
(b (compile b))) (b (compile b)))
(lambda (env) ((f env) (a env) (b env))))) (lambda@ src (env) ((f env) (a env) (b env)))))
((a b c) ((a b c)
(let ((f (compile f)) (let ((f (compile f))
(a (compile a)) (a (compile a))
(b (compile b)) (b (compile b))
(c (compile c))) (c (compile c)))
(lambda (env) ((f env) (a env) (b env) (c env))))) (lambda@ src (env) ((f env) (a env) (b env) (c env)))))
((a b c . args) ((a b c . args)
(let ((f (compile f)) (let ((f (compile f))
(a (compile a)) (a (compile a))
@ -209,46 +216,46 @@
(if (null? args) (if (null? args)
'() '()
(cons (compile (car args)) (lp (cdr args))))))) (cons (compile (car args)) (lp (cdr args)))))))
(lambda (env) (lambda@ src (env)
(apply (f env) (a env) (b env) (c env) (apply (f env) (a env) (b env) (c env)
(let lp ((args args)) (let lp ((args args))
(if (null? args) (if (null? args)
'() '()
(cons ((car args) env) (lp (cdr args))))))))))))) (cons ((car args) env) (lp (cdr args)))))))))))))
(define (compile-box-ref box) (define (compile-box-ref src box)
(match box (match box
((,(typecode resolve) . loc) ((,(typecode resolve) _ . loc)
(lazy (cenv) (lazy src (cenv)
(let ((var (%resolve-variable loc (env-toplevel cenv)))) (let ((var (%resolve-variable loc (env-toplevel cenv))))
(lambda (env) (variable-ref var))))) (lambda@ src (env) (variable-ref var)))))
((,(typecode lexical-ref) depth . width) ((,(typecode lexical-ref) _ depth . width)
(lambda (env) (lambda@ src (env)
(variable-ref (env-ref env depth width)))) (variable-ref (env-ref env depth width))))
(_ (_
(let ((box (compile box))) (let ((box (compile box)))
(lambda (env) (lambda@ src (env)
(variable-ref (box env))))))) (variable-ref (box env)))))))
(define (compile-resolve cenv loc) (define (compile-resolve src cenv loc)
(let ((var (%resolve-variable loc (env-toplevel cenv)))) (let ((var (%resolve-variable loc (env-toplevel cenv))))
(lambda (env) var))) (lambda@ src (env) var)))
(define (compile-top-branch cenv loc args consequent alternate) (define (compile-top-branch src cenv loc args consequent alternate)
(let* ((module (env-toplevel cenv)) (let* ((module (env-toplevel cenv))
(var (%resolve-variable loc module)) (var (%resolve-variable loc module))
(consequent (compile consequent)) (consequent (compile consequent))
(alternate (compile alternate))) (alternate (compile alternate)))
(define (generic-top-branch) (define (generic-top-branch)
(let ((test (compile-top-call cenv loc args))) (let ((test (compile-top-call src cenv loc args)))
(lambda (env) (lambda@ src (env)
(if (test env) (consequent env) (alternate env))))) (if (test env) (consequent env) (alternate env)))))
(define-syntax-rule (maybe-primcall (prim ...) arg ...) (define-syntax-rule (maybe-primcall (prim ...) arg ...)
(cond (cond
((primitive=? 'prim loc module var) ((primitive=? 'prim loc module var)
(let ((arg (compile arg)) (let ((arg (compile arg))
...) ...)
(lambda (env) (lambda@ src (env)
(if (prim (arg env) ...) (if (prim (arg env) ...)
(consequent env) (consequent env)
(alternate env))))) (alternate env)))))
@ -265,94 +272,94 @@
(_ (_
(generic-top-branch))))) (generic-top-branch)))))
(define (compile-if test consequent alternate) (define (compile-if src test consequent alternate)
(match test (match test
((,(typecode call) ((,(typecode call) _
(,(typecode box-ref) . (,(typecode resolve) . loc)) (,(typecode box-ref) _ . (,(typecode resolve) _ . loc))
. args) . args)
(lazy (env) (compile-top-branch env loc args consequent alternate))) (lazy src (env) (compile-top-branch src env loc args consequent alternate)))
(_ (_
(let ((test (compile test)) (let ((test (compile test))
(consequent (compile consequent)) (consequent (compile consequent))
(alternate (compile alternate))) (alternate (compile alternate)))
(lambda (env) (lambda@ src (env)
(if (test env) (consequent env) (alternate env))))))) (if (test env) (consequent env) (alternate env)))))))
(define (compile-quote x) (define (compile-quote src x)
(lambda (env) x)) (lambda@ src (env) x))
(define (compile-let inits body) (define (compile-let src inits body)
(let ((body (compile body)) (let ((body (compile body))
(width (vector-length inits))) (width (vector-length inits)))
(case width (case width
((0) (lambda (env) ((0) (lambda@ src (env)
(body (make-env* env)))) (body (make-env* env))))
((1) ((1)
(let ((a (compile (vector-ref inits 0)))) (let ((a (compile (vector-ref inits 0))))
(lambda (env) (lambda@ src (env)
(body (make-env* env (a env)))))) (body (make-env* env (a env))))))
((2) ((2)
(let ((a (compile (vector-ref inits 0))) (let ((a (compile (vector-ref inits 0)))
(b (compile (vector-ref inits 1)))) (b (compile (vector-ref inits 1))))
(lambda (env) (lambda@ src (env)
(body (make-env* env (a env) (b env)))))) (body (make-env* env (a env) (b env))))))
((3) ((3)
(let ((a (compile (vector-ref inits 0))) (let ((a (compile (vector-ref inits 0)))
(b (compile (vector-ref inits 1))) (b (compile (vector-ref inits 1)))
(c (compile (vector-ref inits 2)))) (c (compile (vector-ref inits 2))))
(lambda (env) (lambda@ src (env)
(body (make-env* env (a env) (b env) (c env)))))) (body (make-env* env (a env) (b env) (c env))))))
((4) ((4)
(let ((a (compile (vector-ref inits 0))) (let ((a (compile (vector-ref inits 0)))
(b (compile (vector-ref inits 1))) (b (compile (vector-ref inits 1)))
(c (compile (vector-ref inits 2))) (c (compile (vector-ref inits 2)))
(d (compile (vector-ref inits 3)))) (d (compile (vector-ref inits 3))))
(lambda (env) (lambda@ src (env)
(body (make-env* env (a env) (b env) (c env) (d env)))))) (body (make-env* env (a env) (b env) (c env) (d env))))))
(else (else
(let lp ((n width) (let lp ((n width)
(k (lambda (env) (k (lambda@ src (env)
(make-env width #f env)))) (make-env width #f env))))
(if (zero? n) (if (zero? n)
(lambda (env) (lambda@ src (env)
(body (k env))) (body (k env)))
(lp (1- n) (lp (1- n)
(let ((init (compile (vector-ref inits (1- n))))) (let ((init (compile (vector-ref inits (1- n)))))
(lambda (env) (lambda@ src (env)
(let* ((x (init env)) (let* ((x (init env))
(new-env (k env))) (new-env (k env)))
(env-set! new-env 0 (1- n) x) (env-set! new-env 0 (1- n) x)
new-env)))))))))) new-env))))))))))
(define (compile-fixed-lambda body nreq) (define (compile-fixed-lambda src body nreq)
(case nreq (case nreq
((0) (lambda (env) ((0) (lambda@ src (env)
(lambda () (lambda@ src ()
(body (make-env* env))))) (body (make-env* env)))))
((1) (lambda (env) ((1) (lambda@ src (env)
(lambda (a) (lambda@ src (a)
(body (make-env* env a))))) (body (make-env* env a)))))
((2) (lambda (env) ((2) (lambda@ src (env)
(lambda (a b) (lambda@ src (a b)
(body (make-env* env a b))))) (body (make-env* env a b)))))
((3) (lambda (env) ((3) (lambda@ src (env)
(lambda (a b c) (lambda@ src (a b c)
(body (make-env* env a b c))))) (body (make-env* env a b c)))))
((4) (lambda (env) ((4) (lambda@ src (env)
(lambda (a b c d) (lambda@ src (a b c d)
(body (make-env* env a b c d))))) (body (make-env* env a b c d)))))
((5) (lambda (env) ((5) (lambda@ src (env)
(lambda (a b c d e) (lambda@ src (a b c d e)
(body (make-env* env a b c d e))))) (body (make-env* env a b c d e)))))
((6) (lambda (env) ((6) (lambda@ src (env)
(lambda (a b c d e f) (lambda@ src (a b c d e f)
(body (make-env* env a b c d e f))))) (body (make-env* env a b c d e f)))))
((7) (lambda (env) ((7) (lambda@ src (env)
(lambda (a b c d e f g) (lambda@ src (a b c d e f g)
(body (make-env* env a b c d e f g))))) (body (make-env* env a b c d e f g)))))
(else (else
(lambda (env) (lambda@ src (env)
(lambda (a b c d e f g . more) (lambda@ src (a b c d e f g . more)
(let ((env (make-env nreq #f env))) (let ((env (make-env nreq #f env)))
(env-set! env 0 0 a) (env-set! env 0 0 a)
(env-set! env 0 1 b) (env-set! env 0 1 b)
@ -377,23 +384,23 @@
(env-set! env 0 n (car args)) (env-set! env 0 n (car args))
(lp (1+ n) (cdr args))))))))))) (lp (1+ n) (cdr args)))))))))))
(define (compile-rest-lambda body nreq rest?) (define (compile-rest-lambda src body nreq rest?)
(case nreq (case nreq
((0) (lambda (env) ((0) (lambda@ src (env)
(lambda rest (lambda@ src rest
(body (make-env* env rest))))) (body (make-env* env rest)))))
((1) (lambda (env) ((1) (lambda@ src (env)
(lambda (a . rest) (lambda@ src (a . rest)
(body (make-env* env a rest))))) (body (make-env* env a rest)))))
((2) (lambda (env) ((2) (lambda@ src (env)
(lambda (a b . rest) (lambda@ src (a b . rest)
(body (make-env* env a b rest))))) (body (make-env* env a b rest)))))
((3) (lambda (env) ((3) (lambda@ src (env)
(lambda (a b c . rest) (lambda@ src (a b c . rest)
(body (make-env* env a b c rest))))) (body (make-env* env a b c rest)))))
(else (else
(lambda (env) (lambda@ src (env)
(lambda (a b c . more) (lambda@ src (a b c . more)
(let ((env (make-env (1+ nreq) #f env))) (let ((env (make-env (1+ nreq) #f env)))
(env-set! env 0 0 a) (env-set! env 0 0 a)
(env-set! env 0 1 b) (env-set! env 0 1 b)
@ -411,10 +418,10 @@
(env-set! env 0 n (car args)) (env-set! env 0 n (car args))
(lp (1+ n) (cdr args))))))))))) (lp (1+ n) (cdr args)))))))))))
(define (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt) (define (compile-opt-lambda src body nreq rest? nopt ninits unbound make-alt)
(lambda (env) (lambda@ src (env)
(define alt (and make-alt (make-alt env))) (define alt (and make-alt (make-alt env)))
(lambda args (lambda@ src args
(let ((nargs (length args))) (let ((nargs (length args)))
(cond (cond
((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt)))) ((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt))))
@ -449,12 +456,12 @@
(body env)) (body env))
(bind-req args)))))))) (bind-req args))))))))
(define (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt) (define (compile-kw-lambda src body nreq rest? nopt kw ninits unbound make-alt)
(define allow-other-keys? (car kw)) (define allow-other-keys? (car kw))
(define keywords (cdr kw)) (define keywords (cdr kw))
(lambda (env) (lambda@ src (env)
(define alt (and make-alt (make-alt env))) (define alt (and make-alt (make-alt env)))
(lambda args (lambda@ src args
(define (npositional args) (define (npositional args)
(let lp ((n 0) (args args)) (let lp ((n 0) (args args))
(if (or (null? args) (if (or (null? args)
@ -557,7 +564,7 @@
(lp alt* nreq* nopt* rest?*) (lp alt* nreq* nopt* rest?*)
(lp alt* nreq nopt rest?)))))) (lp alt* nreq nopt rest?))))))
(define (compile-general-lambda body nreq rest? nopt kw ninits unbound alt) (define (compile-general-lambda src body nreq rest? nopt kw ninits unbound alt)
(call-with-values (call-with-values
(lambda () (lambda ()
(compute-arity alt nreq rest? nopt kw)) (compute-arity alt nreq rest? nopt kw))
@ -566,42 +573,42 @@
(match alt (match alt
(#f #f) (#f #f)
((body meta nreq . tail) ((body meta nreq . tail)
(compile-lambda body meta nreq tail)))) (compile-lambda src body meta nreq tail))))
(define make-closure (define make-closure
(if kw (if kw
(compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt) (compile-kw-lambda src body nreq rest? nopt kw ninits unbound make-alt)
(compile-opt-lambda body nreq rest? nopt ninits unbound make-alt))) (compile-opt-lambda src body nreq rest? nopt ninits unbound make-alt)))
(lambda (env) (lambda@ src (env)
(let ((proc (make-closure env))) (let ((proc (make-closure env)))
(set-procedure-property! proc 'arglist arglist) (set-procedure-property! proc 'arglist arglist)
(set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?) (set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?)
proc))))) proc)))))
(define (compile-lambda body meta nreq tail) (define (compile-lambda src body meta nreq tail)
(define (set-procedure-meta meta proc) (define (set-procedure-meta meta proc)
(match meta (match meta
(() proc) (() proc)
(((prop . val) . meta) (((prop . val) . meta)
(set-procedure-meta meta (set-procedure-meta meta
(lambda (env) (lambda@ src (env)
(let ((proc (proc env))) (let ((proc (proc env)))
(set-procedure-property! proc prop val) (set-procedure-property! proc prop val)
proc)))))) proc))))))
(let ((body (lazy (env) (compile body)))) (let ((body (lazy src (env) (compile body))))
(set-procedure-meta (set-procedure-meta
meta meta
(match tail (match tail
(() (compile-fixed-lambda body nreq)) (() (compile-fixed-lambda src body nreq))
((rest? . tail) ((rest? . tail)
(match tail (match tail
(() (compile-rest-lambda body nreq rest?)) (() (compile-rest-lambda src body nreq rest?))
((nopt kw ninits unbound alt) ((nopt kw ninits unbound alt)
(compile-general-lambda body nreq rest? nopt kw (compile-general-lambda src body nreq rest? nopt kw
ninits unbound alt)))))))) ninits unbound alt))))))))
(define (compile-capture-env locs body) (define (compile-capture-env src locs body)
(let ((body (compile body))) (let ((body (compile body)))
(lambda (env) (lambda@ src (env)
(let* ((len (vector-length locs)) (let* ((len (vector-length locs))
(new-env (make-env len #f (env-toplevel env)))) (new-env (make-env len #f (env-toplevel env))))
(let lp ((n 0)) (let lp ((n 0))
@ -612,107 +619,107 @@
(lp (1+ n)))) (lp (1+ n))))
(body new-env))))) (body new-env)))))
(define (compile-seq head tail) (define (compile-seq src head tail)
(let ((head (compile head)) (let ((head (compile head))
(tail (compile tail))) (tail (compile tail)))
(lambda (env) (lambda@ src (env)
(head env) (head env)
(tail env)))) (tail env))))
(define (compile-box-set! box val) (define (compile-box-set! src box val)
(let ((box (compile box)) (let ((box (compile box))
(val (compile val))) (val (compile val)))
(lambda (env) (lambda@ src (env)
(let ((val (val env))) (let ((val (val env)))
(variable-set! (box env) val))))) (variable-set! (box env) val)))))
(define (compile-lexical-set! depth width x) (define (compile-lexical-set! src depth width x)
(let ((x (compile x))) (let ((x (compile x)))
(lambda (env) (lambda@ src (env)
(env-set! env depth width (x env))))) (env-set! env depth width (x env)))))
(define (compile-call-with-values producer consumer) (define (compile-call-with-values src producer consumer)
(let ((producer (compile producer)) (let ((producer (compile producer))
(consumer (compile consumer))) (consumer (compile consumer)))
(lambda (env) (lambda@ src (env)
(call-with-values (producer env) (call-with-values (producer env)
(consumer env))))) (consumer env)))))
(define (compile-apply f args) (define (compile-apply src f args)
(let ((f (compile f)) (let ((f (compile f))
(args (compile args))) (args (compile args)))
(lambda (env) (lambda@ src (env)
(apply (f env) (args env))))) (apply (f env) (args env)))))
(define (compile-capture-module x) (define (compile-capture-module src x)
(let ((x (compile x))) (let ((x (compile x)))
(lambda (env) (lambda@ src (env)
(x (current-module))))) (x (current-module)))))
(define (compile-call-with-prompt tag thunk handler) (define (compile-call-with-prompt src tag thunk handler)
(let ((tag (compile tag)) (let ((tag (compile tag))
(thunk (compile thunk)) (thunk (compile thunk))
(handler (compile handler))) (handler (compile handler)))
(lambda (env) (lambda@ src (env)
(call-with-prompt (tag env) (thunk env) (handler env))))) (call-with-prompt (tag env) (thunk env) (handler env)))))
(define (compile-call/cc proc) (define (compile-call/cc src proc)
(let ((proc (compile proc))) (let ((proc (compile proc)))
(lambda (env) (lambda@ src (env)
(call/cc (proc env))))) (call/cc (proc env)))))
(define (compile exp) (define (compile exp)
(match exp (match exp
((,(typecode lexical-ref) depth . width) ((,(typecode lexical-ref) src depth . width)
(compile-lexical-ref depth width)) (compile-lexical-ref src depth width))
((,(typecode call) f . args) ((,(typecode call) src f . args)
(compile-call f args)) (compile-call src f args))
((,(typecode box-ref) . box) ((,(typecode box-ref) src . box)
(compile-box-ref box)) (compile-box-ref src box))
((,(typecode resolve) . loc) ((,(typecode resolve) src . loc)
(lazy (env) (compile-resolve env loc))) (lazy src (env) (compile-resolve src env loc)))
((,(typecode if) test consequent . alternate) ((,(typecode if) src test consequent . alternate)
(compile-if test consequent alternate)) (compile-if src test consequent alternate))
((,(typecode quote) . x) ((,(typecode quote) src . x)
(compile-quote x)) (compile-quote src x))
((,(typecode let) inits . body) ((,(typecode let) src inits . body)
(compile-let inits body)) (compile-let src inits body))
((,(typecode lambda) body meta nreq . tail) ((,(typecode lambda) src body meta nreq . tail)
(compile-lambda body meta nreq tail)) (compile-lambda src body meta nreq tail))
((,(typecode capture-env) locs . body) ((,(typecode capture-env) src locs . body)
(compile-capture-env locs body)) (compile-capture-env src locs body))
((,(typecode seq) head . tail) ((,(typecode seq) src head . tail)
(compile-seq head tail)) (compile-seq src head tail))
((,(typecode box-set!) box . val) ((,(typecode box-set!) src box . val)
(compile-box-set! box val)) (compile-box-set! src box val))
((,(typecode lexical-set!) (depth . width) . x) ((,(typecode lexical-set!) src (depth . width) . x)
(compile-lexical-set! depth width x)) (compile-lexical-set! src depth width x))
((,(typecode call-with-values) producer . consumer) ((,(typecode call-with-values) src producer . consumer)
(compile-call-with-values producer consumer)) (compile-call-with-values src producer consumer))
((,(typecode apply) f args) ((,(typecode apply) src f args)
(compile-apply f args)) (compile-apply src f args))
((,(typecode capture-module) . x) ((,(typecode capture-module) src . x)
(compile-capture-module x)) (compile-capture-module src x))
((,(typecode call-with-prompt) tag thunk . handler) ((,(typecode call-with-prompt) src tag thunk . handler)
(compile-call-with-prompt tag thunk handler)) (compile-call-with-prompt src tag thunk handler))
((,(typecode call/cc) . proc) ((,(typecode call/cc) src . proc)
(compile-call/cc proc)))) (compile-call/cc src proc))))
(let ((eval (compile (let ((eval (compile
(memoize-expression (memoize-expression
@ -721,3 +728,7 @@
((module-transformer (current-module)) exp))))) ((module-transformer (current-module)) exp)))))
(env #f)) (env #f))
(eval env))) (eval env)))
;;; Local Variables:
;;; eval: (put 'lambda@ 'scheme-indent-function 2)
;;; End:

15
module/system/vm/program.scm
View file

@ -267,9 +267,18 @@ lists."
;; procedure property interface. ;; procedure property interface.
(name (or (and program (procedure-name program)) (name (or (and program (procedure-name program))
(and pdi (program-debug-info-name pdi)))) (and pdi (program-debug-info-name pdi))))
(source (match (find-program-sources addr) (source (let ((source-override
(() #f) (procedure-property program 'source-override)))
((source . _) source))) (if (and source-override
(not (null? source-override))) ; I think the () case didn't occur in 2.2. What's up with that?
((@@ (system vm debug) make-source) ; XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
0
(assq-ref source-override 'filename)
(assq-ref source-override 'line)
(assq-ref source-override 'column))
(match (find-program-sources addr)
(() #f)
((source . _) source)))))
(formals (if program (formals (if program
(program-arguments-alists program) (program-arguments-alists program)
(let ((arities (find-program-arities addr))) (let ((arities (find-program-arities addr)))