From 1ae6cc05058c2d69a1e6ec6532c7ab41269f5da3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 24 Sep 2011 10:02:50 +0900 Subject: [PATCH] change `syntax-local-lift-module-end-declaration' for phase N Lift to the end of the module, instead of the end of the enclosing `begin-for-syntax'. Also, fix a bug in phase 2+ visits. --- .../scribblings/reference/stx-trans.scrbl | 9 +- src/racket/src/module.c | 119 +++++++++++++++--- src/racket/src/syntax.c | 29 ++++- 3 files changed, 129 insertions(+), 28 deletions(-) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index d5d60fe53e..f50279d7f9 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -511,8 +511,13 @@ for caching lift information to avoid redundant lifts. Cooperates with the @racket[module] form to insert @racket[stx] as a top-level declaration at the end of the module currently being expanded. If the current expression being -transformed is not in the module top-level, then @racket[stx] is -eventually expanded in an expression context. +transformed is in @tech{phase level} 0 and not in the module top-level, then @racket[stx] is +eventually expanded in an expression context. If the current expression being +transformed is in a higher @tech{phase level} (i.e., nested within some +number of @racket[begin-for-syntax]es within a module top-level), then the lifted declaration +is placed at the very end of the module (under a suitable number of +@racket[begin-for-syntax]es), instead of merely the end of the +enclosing @racket[begin-for-syntax]. @transform-time[] If the current expression being transformed is not within a @racket[module] form (see @racket[syntax-transforming-module-expression?]), diff --git a/src/racket/src/module.c b/src/racket/src/module.c index b1cd716c3c..4930a48664 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -113,6 +113,7 @@ typedef struct Module_Begin_Expand_State { Scheme_Object *saved_provides; /* list of (cons form phase) */ Scheme_Hash_Table *modidx_cache; Scheme_Object *redef_modname; + Scheme_Object *end_statementss; /* list of lists */ } Module_Begin_Expand_State; static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, @@ -4511,9 +4512,15 @@ void *scheme_module_exprun_finish(Scheme_Env *menv, int at_phase) return NULL; for (i = 1; i < at_phase; i++) { + scheme_prepare_exp_env(menv); + if (!menv->exp_env->link_midx) + menv->exp_env->link_midx = menv->link_midx; menv = menv->exp_env; } + scheme_prepare_exp_env(menv); exp_env = menv->exp_env; + if (!exp_env->link_midx) + exp_env->link_midx = menv->link_midx; if (!exp_env) return NULL; @@ -6300,6 +6307,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env bxs->saved_provides = scheme_null; bxs->modidx_cache = modidx_cache; bxs->redef_modname = redef_modname; + bxs->end_statementss = scheme_null; body_lists = do_module_begin_at_phase(form, env, rec, drec, @@ -6480,6 +6488,41 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env } } +static Scheme_Object *get_higher_phase_lifts(Module_Begin_Expand_State *bxs, + Scheme_Object *begin_for_syntax_stx) +{ + Scheme_Object *p, *e, *fm = scheme_null; + + if (SCHEME_PAIRP(bxs->end_statementss)) { + /* No other ends, so start shitfing higher-phase ends into `b-f-s': */ + int depth = 1; + for (p = bxs->end_statementss; SCHEME_PAIRP(p); p = SCHEME_CDR(p), depth++) { + if (SCHEME_PAIRP(SCHEME_CAR(p))) + break; + } + if (SCHEME_PAIRP(p)) { + /* wrap `depth' `begin-for-syntaxes' around SCHEME_CAR(p): */ + int di; + e = scheme_reverse(SCHEME_CAR(p)); + e = scheme_make_pair(begin_for_syntax_stx, e); + for (di = 1; di < depth; di++) { + e = scheme_make_pair(begin_for_syntax_stx, scheme_make_pair(e, scheme_null)); + } + fm = scheme_make_pair(scheme_datum_to_syntax(e, scheme_false, scheme_false, 0, 0), + scheme_null); + /* first `depth' end-statement lists are now empty: */ + p = SCHEME_CDR(p); + for (di = 0; di < depth; di++) { + p = scheme_make_pair(scheme_null, p); + } + bxs->end_statementss = p; + } else + bxs->end_statementss = scheme_null; + } + + return fm; +} + static Scheme_Object *do_module_begin_k(void) { Scheme_Thread *p = scheme_current_thread; @@ -6530,8 +6573,8 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ Scheme_Object *lift_data; Scheme_Object *lift_ctx; Scheme_Object *lifted_reqs = scheme_null, *req_data, *unbounds = scheme_null; - int maybe_has_lifts = 0; - Scheme_Object *observer, *vec; + int maybe_has_lifts = 0, expand_ends = (phase == 0); + Scheme_Object *observer, *vec, *end_statements; Scheme_Object *define_values_stx, *begin_stx, *define_syntaxes_stx, *begin_for_syntax_stx, *req_stx, *prov_stx, *sv[6]; #ifdef DO_STACK_CHECK @@ -6684,6 +6727,12 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ bxs->redef_modname, bxs->all_simple_renames); + if (SCHEME_PAIRP(bxs->end_statementss)) { + end_statements = SCHEME_CAR(bxs->end_statementss); + bxs->end_statementss = SCHEME_CDR(bxs->end_statementss); + } else + end_statements = scheme_null; + /* Pass 1 */ /* Partially expand all expressions, and process definitions, requires, @@ -6701,7 +6750,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ p = (maybe_has_lifts ? scheme_frame_get_end_statement_lifts(xenv) - : scheme_null); + : end_statements); prev_p = (maybe_has_lifts ? scheme_frame_get_provide_lifts(xenv) : scheme_null); @@ -6751,12 +6800,17 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ if (SCHEME_STX_NULLP(fm)) { e = scheme_frame_get_provide_lifts(xenv); e = scheme_reverse(e); - fm = scheme_frame_get_end_statement_lifts(xenv); - fm = scheme_reverse(fm); - if (!SCHEME_NULLP(e)) - fm = scheme_append(fm, e); + if (expand_ends) { + fm = scheme_frame_get_end_statement_lifts(xenv); + fm = scheme_reverse(fm); + if (!SCHEME_NULLP(e)) + fm = scheme_append(fm, e); + maybe_has_lifts = 0; + } else + fm = e; + if (SCHEME_NULLP(fm) && expand_ends) + fm = get_higher_phase_lifts(bxs, begin_for_syntax_stx); SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm); - maybe_has_lifts = 0; if (SCHEME_NULLP(fm)) { e = NULL; break; @@ -7091,16 +7145,26 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ if (SCHEME_STX_NULLP(fm) && maybe_has_lifts) { e = scheme_frame_get_provide_lifts(xenv); e = scheme_reverse(e); - fm = scheme_frame_get_end_statement_lifts(xenv); - fm = scheme_reverse(fm); - if (!SCHEME_NULLP(e)) - fm = scheme_append(fm, e); + if (expand_ends) { + fm = scheme_frame_get_end_statement_lifts(xenv); + fm = scheme_reverse(fm); + if (!SCHEME_NULLP(e)) + fm = scheme_append(fm, e); + maybe_has_lifts = 0; + if (SCHEME_NULLP(fm)) + fm = get_higher_phase_lifts(bxs, begin_for_syntax_stx); + } else + fm = e; SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm); - maybe_has_lifts = 0; } } /* first = a list of (cons semi-expanded-expression kind) */ + if (!expand_ends) { + if (maybe_has_lifts) + end_statements = scheme_frame_get_end_statement_lifts(xenv); + } + if (!phase) { /* Bound names will not be re-bound at this point: */ if (!erec || (erec[derec].depth != -2)) { @@ -7163,7 +7227,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ l = (maybe_has_lifts ? scheme_frame_get_end_statement_lifts(cenv) - : scheme_null); + : end_statements); ll = (maybe_has_lifts ? scheme_frame_get_provide_lifts(cenv) : scheme_null); @@ -7235,11 +7299,16 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ Scheme_Object *sp; e = scheme_frame_get_provide_lifts(cenv); e = scheme_reverse(e); - p = scheme_frame_get_end_statement_lifts(cenv); - p = scheme_reverse(p); - expr_cnt = scheme_list_length(p); - if (!SCHEME_NULLP(e)) - p = scheme_append(p, e); + if (expand_ends) { + p = scheme_frame_get_end_statement_lifts(cenv); + p = scheme_reverse(p); + expr_cnt = scheme_list_length(p); + if (!SCHEME_NULLP(e)) + p = scheme_append(p, e); + } else { + p = e; + expr_cnt = 0; + } SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, p); for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { e = SCHEME_CAR(ll); @@ -7264,9 +7333,19 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ } if (erec) expanded_l = scheme_reverse(expanded_l); + /* If not phase 0, save end statements */ + if (!expand_ends) { + if (maybe_has_lifts) + end_statements = scheme_frame_get_end_statement_lifts(cenv); + if (!SCHEME_NULLP(end_statements) || !SCHEME_NULLP(bxs->end_statementss)) { + p = scheme_make_pair(end_statements, bxs->end_statementss); + bxs->end_statementss = p; + } + } + adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); bxs->all_defs = adt; - + /* Pass 3 */ /* if at phase 0, expand provides for all phases */ SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer); diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index 0da57dde64..1d48e3b8ef 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -3084,7 +3084,7 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx) #define EXPLAIN_RESOLVE 0 #if EXPLAIN_RESOLVE -int scheme_explain_resolves = 0; +int scheme_explain_resolves = 1; # define EXPLAIN(x) if (scheme_explain_resolves) { x; } #else # define EXPLAIN(x) /* empty */ @@ -3629,7 +3629,8 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase, int mresult_skipped = -1; int depends_on_unsealed_rib = 0, mresult_depends_unsealed = 0; - EXPLAIN(fprintf(stderr, "%d Resolving %s [skips: %s]:\n", depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), + EXPLAIN(fprintf(stderr, "%d Resolving %s@%d [skips: %s]: -------------\n", + depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), SCHEME_INT_VAL(orig_phase), scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps); @@ -3757,7 +3758,13 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase, if (_depends_on_unsealed_rib) *_depends_on_unsealed_rib = depends_on_unsealed_rib; - EXPLAIN(fprintf(stderr, "%d Result: %s\n", depth, scheme_write_to_string(result, 0))); + if (SCHEME_MODIDXP(result)) { + EXPLAIN(fprintf(stderr, "%d Result: <%s,%s>\n", depth, + scheme_write_to_string(((Scheme_Modidx *)result)->path, NULL), + scheme_write_to_string(((Scheme_Modidx *)result)->base, NULL))); + } else { + EXPLAIN(fprintf(stderr, "%d Result: %s\n", depth, scheme_write_to_string(result, NULL))); + } return result; } else if ((SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) @@ -3892,10 +3899,15 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase, } else mresult = rename; - if (modidx_shift_from) + if (modidx_shift_from) { + EXPLAIN(fprintf(stderr, "%d shift %p->%p: %p\n", + depth, modidx_shift_from, modidx_shift_to, + mresult)); mresult = scheme_modidx_shift(mresult, modidx_shift_from, modidx_shift_to); + EXPLAIN(fprintf(stderr, "%d = %p\n", depth, mresult)); + } if (get_names) { int no_shift = 0; @@ -3987,10 +3999,11 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase, /* Phase shift */ Scheme_Object *vec, *n, *dest, *src, *insp; - EXPLAIN(fprintf(stderr, "%d phase shift\n", depth)); - vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps)); n = SCHEME_VEC_ELS(vec)[0]; + + EXPLAIN(fprintf(stderr, "%d phase shift by %d\n", depth, SCHEME_INT_VAL(n))); + if (SCHEME_TRUEP(phase)) phase = scheme_bin_minus(phase, n); @@ -4004,11 +4017,15 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase, if (!SCHEME_FALSEP(src)) { if (!modidx_shift_to) { + EXPLAIN(fprintf(stderr, "%d shift to %p\n", depth, dest)); modidx_shift_to = dest; } else if (!SAME_OBJ(modidx_shift_from, dest)) { modidx_shift_to = scheme_modidx_shift(dest, modidx_shift_from, modidx_shift_to); + EXPLAIN(fprintf(stderr, "%d shift %p->%p; %d\n", + depth, modidx_shift_from, + modidx_shift_to, SAME_OBJ(dest, modidx_shift_to))); } modidx_shift_from = src; }