diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index 5faa402581..27e153c7af 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -3285,6 +3285,25 @@ empty? ; so that it counts as imported (null? 10))) +(test-comp `(module m racket/base + (module a racket/base + (provide b c) + (define c #f) + (set! c c) + (define (b) (c))) + (module d racket/base + (require (submod ".." a)) + (list b c (b)))) + `(module m racket/base + (module a racket/base + (provide b c) + (define c #f) + (set! c c) + (define (b) (c))) + (module d racket/base + (require (submod ".." a)) + (list b c (c))))) + (module check-inline-request racket/base (require racket/performance-hint) (provide loop) diff --git a/racket/src/racket/src/compenv.c b/racket/src/racket/src/compenv.c index b1a166dc0d..d765f33231 100644 --- a/racket/src/racket/src/compenv.c +++ b/racket/src/racket/src/compenv.c @@ -1485,12 +1485,12 @@ scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, if (modname) { val = scheme_module_syntax(modname, env->genv, find_id, SCHEME_INT_VAL(mod_defn_phase)); if (val && !(flags & SCHEME_NO_CERT_CHECKS)) - scheme_check_accessible_in_module(genv, in_modidx, - find_id, src_find_id, - env->insp, rename_insp, - -2, 0, - NULL, NULL, - env->genv, NULL, NULL); + scheme_check_accessible_in_module_instance(genv, + find_id, src_find_id, + env->insp, rename_insp, + -2, 0, + NULL, NULL, + env->genv, NULL, NULL); } else { /* Only try syntax table if there's not an explicit (later) variable mapping: */ @@ -1511,12 +1511,12 @@ scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, if (flags & SCHEME_NO_CERT_CHECKS) pos = 0; else - pos = scheme_check_accessible_in_module(genv, in_modidx, - find_id, src_find_id, - env->insp, rename_insp, - -1, 1, - _protected, NULL, - env->genv, NULL, &mod_constant); + pos = scheme_check_accessible_in_module_instance(genv, + find_id, src_find_id, + env->insp, rename_insp, + -1, 1, + _protected, NULL, + env->genv, NULL, &mod_constant); modpos = (int)SCHEME_INT_VAL(pos); } else modpos = -1; @@ -1579,8 +1579,17 @@ scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, is_constant = 2; shape = intern_struct_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant)); } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) { - if (_inline_variant) - *_inline_variant = mod_constant; + if (_inline_variant) { + /* In case the inline variant includes references to module + variables, we'll need to shift the references: */ + Scheme_Object *shiftable; + shiftable = scheme_make_vector(4, scheme_false); + SCHEME_VEC_ELS(shiftable)[0] = mod_constant; + SCHEME_VEC_ELS(shiftable)[1] = genv->module->me->src_modidx; + SCHEME_VEC_ELS(shiftable)[2] = modidx; + SCHEME_VEC_ELS(shiftable)[3] = mod_defn_phase; + *_inline_variant = shiftable; + } is_constant = 2; shape = scheme_get_or_check_procedure_shape(mod_constant, NULL); } else { diff --git a/racket/src/racket/src/compile.c b/racket/src/racket/src/compile.c index a85d500513..2c5e51628a 100644 --- a/racket/src/racket/src/compile.c +++ b/racket/src/racket/src/compile.c @@ -3404,7 +3404,7 @@ Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy) static void *eval_letmacro_rhs_k(void); -static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Comp_Env *rhs_env, +static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Env *genv, Scheme_Comp_Env *rhs_env, int max_let_depth, Resolve_Prefix *rp, int phase) { @@ -3417,12 +3417,13 @@ static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Comp_Env *rhs_e p->ku.k.p1 = a; p->ku.k.p2 = rhs_env; p->ku.k.p3 = rp; + p->ku.k.p4 = genv; p->ku.k.i1 = max_let_depth; p->ku.k.i2 = phase; return (Scheme_Object *)scheme_enlarge_runstack(depth, eval_letmacro_rhs_k); } - save_runstack = scheme_push_prefix(NULL, rp, NULL, NULL, phase, phase, rhs_env->genv, NULL); + save_runstack = scheme_push_prefix(genv, 1, rp, NULL, NULL, phase, phase, rhs_env->genv, NULL); if (scheme_omittable_expr(a, 1, -1, OMITTABLE_RESOLVED, NULL, NULL)) { /* short cut */ @@ -3460,10 +3461,12 @@ static void *eval_letmacro_rhs_k(void) Scheme_Comp_Env *rhs_env; int max_let_depth, phase; Resolve_Prefix *rp; + Scheme_Env *genv; a = (Scheme_Object *)p->ku.k.p1; rhs_env = (Scheme_Comp_Env *)p->ku.k.p2; rp = (Resolve_Prefix *)p->ku.k.p3; + genv = (Scheme_Env *)p->ku.k.p4; max_let_depth = p->ku.k.i1; phase = p->ku.k.i2; @@ -3471,7 +3474,7 @@ static void *eval_letmacro_rhs_k(void) p->ku.k.p2 = NULL; p->ku.k.p3 = NULL; - return (void *)eval_letmacro_rhs(a, rhs_env, max_let_depth, rp, phase); + return (void *)eval_letmacro_rhs(a, genv, rhs_env, max_let_depth, rp, phase); } void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, @@ -3521,15 +3524,11 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object a = scheme_letrec_check_expr(a); - oi = scheme_optimize_info_create(eenv->prefix, 1); + oi = scheme_optimize_info_create(eenv->prefix, eenv->genv, insp, 1); if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) scheme_optimize_info_never_inline(oi); a = scheme_optimize_expr(a, oi, 0); - /* For internal defn, don't simplify as resolving, because the - expression may have syntax objects with a lexical rename that - is still being extended. - For letrec-syntaxes+values, don't simplify because it's too expensive. */ rp = scheme_resolve_prefix(eenv->genv->phase, eenv->prefix, insp); ri = scheme_resolve_info_create(rp); @@ -3547,7 +3546,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object } a_expr = a; - a = eval_letmacro_rhs(a_expr, rhs_env, + a = eval_letmacro_rhs(a_expr, eenv->genv, rhs_env, scheme_resolve_info_max_let_depth(ri), rp, eenv->genv->phase); diff --git a/racket/src/racket/src/env.c b/racket/src/racket/src/env.c index 7400699f27..d18f1581f2 100644 --- a/racket/src/racket/src/env.c +++ b/racket/src/racket/src/env.c @@ -1425,7 +1425,8 @@ scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym, if (constant && scheme_defining_primitives) { ((Scheme_Bucket_With_Flags *)b)->id = builtin_ref_counter++; ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_HAS_REF_ID | GLOB_IS_CONST | GLOB_STRONG_HOME_LINK); - } + } else if (constant) + ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_IS_CONST | GLOB_STRONG_HOME_LINK); scheme_set_bucket_home(b, env); } else scheme_add_to_table(env->syntax, (const char *)sym, obj, constant); diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index 375a305afc..795bd93101 100644 --- a/racket/src/racket/src/eval.c +++ b/racket/src/racket/src/eval.c @@ -900,17 +900,18 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx, } if (check_access && !SAME_OBJ(menv, env)) { - varname = scheme_check_accessible_in_module(menv, NULL, varname, NULL, - NULL, insp, - pos, 0, - NULL, NULL, - env, NULL, NULL); + varname = scheme_check_accessible_in_module_instance(menv, varname, NULL, + NULL, insp, + pos, 0, + NULL, NULL, + env, NULL, NULL); } } if (exprs) { + Scheme_Object *simplified; if (self) { - exprs[which] = varname; + simplified = varname; } else { if (flags & SCHEME_MODVAR_CONST) { Scheme_Object *v; @@ -919,14 +920,17 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx, SCHEME_VEC_ELS(v)[2] = (shape ? shape : scheme_false); if (mod_phase != 0) SCHEME_VEC_ELS(v)[3] = scheme_make_integer(mod_phase); + simplified = v; } else { Scheme_Object *v = modname; if (mod_phase != 0) v = scheme_make_pair(v, scheme_make_integer(mod_phase)); v = scheme_make_pair(varname, v); - exprs[which] = v; + simplified = v; } + simplified = scheme_make_mutable_pair(simplified, exprs[which]); } + exprs[which] = simplified; } bkt = scheme_global_bucket(varname, menv); @@ -944,8 +948,8 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx, bad_reason = "has the wrong procedure or structure-type shape"; } } else { - if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & GLOB_IS_IMMUTATED)) - bad_reason = "not constant"; + if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & (GLOB_IS_CONST | GLOB_IS_IMMUTATED))) + bad_reason = "is not constant"; } } @@ -982,6 +986,12 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env { Scheme_Object *expr = exprs[which]; + if (SCHEME_MPAIRP(expr)) { + /* Simplified reference was installed by link_module_variable; + simplified is in CAR, and original is in CDR */ + expr = SCHEME_CAR(expr); + } + if (SCHEME_FALSEP(expr)) { /* See scheme_make_environment_dummy */ Scheme_Bucket *b; @@ -1997,7 +2007,7 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, if (dm_env) { scheme_prepare_exp_env(dm_env); - save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1, NULL, scheme_false); + save_runstack = scheme_push_prefix(dm_env->exp_env, 0, rp, NULL, NULL, 1, 1, NULL, scheme_false); vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals_expr, dyn_state); scheme_pop_prefix(save_runstack); } else { @@ -2446,7 +2456,7 @@ do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env) form = SCHEME_VEC_ELS(form)[0]; - save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1, NULL, scheme_false); + save_runstack = scheme_push_prefix(dm_env->exp_env, 0, rp, NULL, NULL, 1, 1, NULL, scheme_false); while (!SCHEME_NULLP(form)) { ignore_result(scheme_eval_linked_expr_multi_with_dynamic_state(SCHEME_CAR(form), &dyn_state)); @@ -4054,7 +4064,8 @@ static Scheme_Object *binding_namess_as_list(Scheme_Hash_Table *binding_namess) return l; } -static Scheme_Object *optimize_resolve_expr(Scheme_Object* o, Comp_Prefix *cp, +static Scheme_Object *optimize_resolve_expr(Scheme_Object* o, + Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, Scheme_Object *src_insp_desc, Scheme_Object *binding_namess, int comp_flags) @@ -4070,7 +4081,7 @@ static Scheme_Object *optimize_resolve_expr(Scheme_Object* o, Comp_Prefix *cp, enforce_consts = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS)); if (enforce_consts) comp_flags |= COMP_ENFORCE_CONSTS; - oi = scheme_optimize_info_create(cp, 1); + oi = scheme_optimize_info_create(cp, env, insp, 1); scheme_optimize_info_enforce_const(oi, enforce_consts); if (!(comp_flags & COMP_CAN_INLINE)) scheme_optimize_info_never_inline(oi); @@ -4259,7 +4270,7 @@ static void *compile_k(void) o = scheme_letrec_check_expr(o); - oi = scheme_optimize_info_create(cenv->prefix, 1); + oi = scheme_optimize_info_create(cenv->prefix, genv, insp, 1); scheme_optimize_info_enforce_const(oi, enforce_consts); if (!(comp_flags & COMP_CAN_INLINE)) scheme_optimize_info_never_inline(oi); @@ -4448,7 +4459,7 @@ static void *eval_k(void) scheme_install_binding_names(top->binding_namess, env); - save_runstack = scheme_push_prefix(env, rp, NULL, NULL, 0, env->phase, NULL, scheme_false); + save_runstack = scheme_push_prefix(env, 0, rp, NULL, NULL, 0, env->phase, NULL, scheme_false); if (as_tail) { /* Cons up a closure to capture the prefix */ @@ -4940,7 +4951,9 @@ static Scheme_Object *recompile_top(Scheme_Object *top, int comp_flags) printf("%s\n\n", scheme_print_to_string(code, NULL)); #endif - top = optimize_resolve_expr(code, cp, ((Scheme_Compilation_Top*)top)->prefix->src_insp_desc, + top = optimize_resolve_expr(code, cp, scheme_get_env(NULL), + scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR), + ((Scheme_Compilation_Top*)top)->prefix->src_insp_desc, ((Scheme_Compilation_Top*)top)->binding_namess, comp_flags); @@ -5969,7 +5982,7 @@ int scheme_prefix_depth(Resolve_Prefix *rp) return 0; } -Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, +Scheme_Object **scheme_push_prefix(Scheme_Env *genv, int already_linked, Resolve_Prefix *rp, Scheme_Object *src_modidx, Scheme_Object *now_modidx, int src_phase, int now_phase, Scheme_Env *dummy_env, Scheme_Object *insp) @@ -6002,8 +6015,12 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, for (i = 0; i < rp->num_toplevels; i++) { v = rp->toplevels[i]; - if (genv || SCHEME_FALSEP(v)) + if (!already_linked || SCHEME_FALSEP(v)) v = link_toplevel(rp->toplevels, i, genv ? genv : dummy_env, src_modidx, now_modidx, insp); + else if (SAME_TYPE(SCHEME_TYPE(v), scheme_module_variable_type)) { + /* not already linked, after all */ + v = link_toplevel(rp->toplevels, i, genv, src_modidx, now_modidx, insp); + } pf->a[i] = v; } @@ -6013,7 +6030,7 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, i = rp->num_toplevels; v = scheme_make_shift(scheme_make_integer(now_phase - src_phase), src_modidx, now_modidx, - genv ? genv->module_registry->exports : NULL, + !already_linked ? genv->module_registry->exports : NULL, rp->src_insp_desc, insp); if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) { /* Put lazy-shift info in pf->a[i]: */ diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c index 270918fb6c..a916c3909e 100644 --- a/racket/src/racket/src/module.c +++ b/racket/src/racket/src/module.c @@ -4518,18 +4518,21 @@ Scheme_Env *scheme_module_access(Scheme_Object *name, Scheme_Env *env, intptr_t return menv; } -static void check_certified(Scheme_Object *stx, +static void check_certified(Scheme_Object *guard_insp, Scheme_Object *current_insp, Scheme_Object *binding_insp, - Scheme_Object *in_modidx, - Scheme_Env *env, Scheme_Object *symbol, - int var, int prot, int *_would_complain) + Scheme_Object *stx, /* for error reporting */ + Scheme_Module *module, /* for error reporting */ + Scheme_Object *symbol, /* for error reporting */ + int var, /* for error reporting */ + int prot, /* for error reporting */ + int *_would_complain) { int need_cert = 1; if (need_cert && current_insp) - need_cert = scheme_module_protected_wrt(env->guard_insp, current_insp); + need_cert = scheme_module_protected_wrt(guard_insp, current_insp); if (need_cert && binding_insp) - need_cert = scheme_module_protected_wrt(env->guard_insp, binding_insp); + need_cert = scheme_module_protected_wrt(guard_insp, binding_insp); if (need_cert) { if (_would_complain) { @@ -4544,7 +4547,7 @@ static void check_certified(Scheme_Object *stx, "access disallowed by code inspector to %s %s from module: %D", prot ? "protected" : "unexported", var ? "variable" : "syntax", - scheme_get_modsrc(env->module)); + scheme_get_modsrc(module)); } } } @@ -4567,44 +4570,43 @@ static Scheme_Object *to_defined_symbol(Scheme_Object *symbol, Scheme_Env *env) return to_defined_symbol_at_phase(symbol, env, scheme_make_integer(env->phase)); } -Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *in_modidx, - Scheme_Object *symbol, Scheme_Object *stx, - Scheme_Object *current_insp, +static Scheme_Object *check_accessible_in_module(Scheme_Module *module, intptr_t mod_phase, Scheme_Object *guard_insp, + Scheme_Object *symbol, + Scheme_Object *stx, /* for error reporting, only */ + Scheme_Object *current_insp, Scheme_Object *binding_insp, - int position, int want_pos, + int position, int want_pos, int *_protected, int *_unexported, - Scheme_Env *from_env, int *_would_complain, + Scheme_Env *from_env, /* for error reporting, only */ + int *_would_complain, Scheme_Object **_is_constant) - /* Returns the actual name when !want_pos, needed in case of - uninterned names. Otherwise, returns a position value on success. - If position < -1, then merely checks for protected syntax. +/* Returns the actual name when !want_pos, needed in case of + uninterned names. Otherwise, returns a position value on success. + If position < -1, then merely checks for protected syntax. - Access for protected and unexported names depends on - `current_insp` (dynamic context) and `binding_insp` (static context). */ + Access for protected and unexported names depends on + `current_insp` (dynamic context) and `binding_insp` (static context). */ { Scheme_Module_Phase_Exports *pt; - if (!SCHEME_SYMBOLP(symbol)) - symbol = to_defined_symbol(symbol, env); - - if (scheme_is_kernel_env(env) - || ((env->module->primitive && !env->module->exp_infos[0]->provide_protects))) { + if (SAME_OBJ(scheme_get_kernel_env()->module, module) + || ((module->primitive && !module->exp_infos[0]->provide_protects))) { if (want_pos) return scheme_make_integer(-1); else return symbol; } - switch (env->mod_phase) { + switch (mod_phase) { case 0: - pt = env->module->me->rt; + pt = module->me->rt; break; case 1: - pt = env->module->me->et; + pt = module->me->et; break; default: - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(env->module->me->other_phases, - scheme_make_integer(env->mod_phase)); + pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(module->me->other_phases, + scheme_make_integer(mod_phase)); break; } @@ -4626,9 +4628,9 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object int num_indirect_provides; Scheme_Object **indirect_provides; - if ((env->mod_phase >= 0) && (env->mod_phase < env->module->num_phases)) { - num_indirect_provides = env->module->exp_infos[env->mod_phase]->num_indirect_provides; - indirect_provides = env->module->exp_infos[env->mod_phase]->indirect_provides; + if ((mod_phase >= 0) && (mod_phase < module->num_phases)) { + num_indirect_provides = module->exp_infos[mod_phase]->num_indirect_provides; + indirect_provides = module->exp_infos[mod_phase]->indirect_provides; } else { num_indirect_provides = 0; indirect_provides = NULL; @@ -4649,11 +4651,11 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object && !memcmp(SCHEME_SYM_VAL(isym), SCHEME_SYM_VAL(symbol), SCHEME_SYM_LEN(isym)))) { if ((position < pt->num_var_provides) - && scheme_module_protected_wrt(env->guard_insp, current_insp)) { + && scheme_module_protected_wrt(guard_insp, current_insp)) { char *provide_protects; - if ((env->mod_phase >= 0) && (env->mod_phase < env->module->num_phases)) - provide_protects = env->module->exp_infos[env->mod_phase]->provide_protects; + if ((mod_phase >= 0) && (mod_phase < module->num_phases)) + provide_protects = module->exp_infos[mod_phase]->provide_protects; else provide_protects = NULL; @@ -4661,12 +4663,12 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object && provide_protects[position]) { if (_protected) *_protected = 1; - check_certified(stx, current_insp, binding_insp, in_modidx, env, symbol, 1, 1, _would_complain); + check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 1, 1, _would_complain); } } if (need_cert) - check_certified(stx, current_insp, binding_insp, in_modidx, env, symbol, 1, 0, _would_complain); + check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 1, 0, _would_complain); if (want_pos) return scheme_make_integer(position); @@ -4678,8 +4680,8 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object } else { Scheme_Object *pos; - if (env->mod_phase < env->module->num_phases) - pos = scheme_hash_get(env->module->exp_infos[env->mod_phase]->accessible, symbol); + if (mod_phase < module->num_phases) + pos = scheme_hash_get(module->exp_infos[mod_phase]->accessible, symbol); else pos = NULL; @@ -4719,8 +4721,8 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object if (pos) { char *provide_protects; - if ((env->mod_phase >= 0) && (env->mod_phase < env->module->num_phases)) - provide_protects = env->module->exp_infos[env->mod_phase]->provide_protects; + if ((mod_phase >= 0) && (mod_phase < module->num_phases)) + provide_protects = module->exp_infos[mod_phase]->provide_protects; else provide_protects = NULL; @@ -4729,7 +4731,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object && provide_protects[SCHEME_INT_VAL(pos)]) { if (_protected) *_protected = 1; - check_certified(stx, current_insp, binding_insp, in_modidx, env, symbol, 1, 1, _would_complain); + check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 1, 1, _would_complain); } if ((position >= -1) @@ -4739,7 +4741,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *_protected = 1; if (_unexported) *_unexported = 1; - check_certified(stx, current_insp, binding_insp, in_modidx, env, symbol, 1, 0, _would_complain); + check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 1, 0, _would_complain); } if (want_pos) @@ -4752,7 +4754,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object /* unexported syntax -- need cert */ if (_unexported) *_unexported = 1; - check_certified(stx, current_insp, binding_insp, in_modidx, env, symbol, 0, 0, _would_complain); + check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 0, 0, _would_complain); return NULL; } } @@ -4790,14 +4792,66 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object srclen ? " importing module: " : "", srcstr, srclen, srclen ? "\n" : "", - scheme_get_modsrc(env->module), - env->mod_phase, + scheme_get_modsrc(module), + mod_phase, (position >= 0) ? " and at the expected position" : ""); } return NULL; } +Scheme_Object *scheme_check_accessible_in_module_instance(Scheme_Env *env, + Scheme_Object *symbol, + Scheme_Object *stx, /* for error reporting, only */ + Scheme_Object *current_insp, + Scheme_Object *binding_insp, + int position, int want_pos, + int *_protected, int *_unexported, + Scheme_Env *from_env, /* for error reporting, only */ + int *_would_complain, + Scheme_Object **_is_constant) +{ + if (!SCHEME_SYMBOLP(symbol)) + symbol = to_defined_symbol(symbol, env); + + return check_accessible_in_module(env->module, env->mod_phase, env->guard_insp, + symbol, stx, + current_insp, binding_insp, + position, want_pos, + _protected, _unexported, + from_env, + _would_complain, + _is_constant); +} + +int scheme_check_accessible_in_module_name(Scheme_Object *modidx, intptr_t mod_phase, Scheme_Env *env, + Scheme_Object *symbol, int position, + Scheme_Object *current_insp, Scheme_Object *binding_insp, + Scheme_Object **_is_constant) +{ + Scheme_Module *module; + Scheme_Object *modname; + int would_complain = 0; + + modname = scheme_module_resolve(modidx, 0); + + module = registry_get_loaded(env, modname); + if (!module) + return 0; + + (void)check_accessible_in_module(module, mod_phase, scheme_make_inspector(module->insp), + symbol, NULL, + current_insp, binding_insp, + position, 0, + NULL, NULL, + NULL, + &would_complain, + _is_constant); + + return !would_complain; +} + + void scheme_check_unsafe_accessible(Scheme_Object *insp, Scheme_Env *from_env) { Scheme_Env *unsafe_env; @@ -5939,7 +5993,7 @@ void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env) LOG_START_RUN(menv->module); - save_runstack = scheme_push_prefix(menv, m->prefix, + save_runstack = scheme_push_prefix(menv, 0, m->prefix, m->me->src_modidx, menv->link_midx, 0, menv->phase, NULL, menv->access_insp); @@ -6407,7 +6461,7 @@ static void eval_exptime(Scheme_Object *names, int count, if (SCHEME_TYPE(expr) > _scheme_values_types_) { vals = expr; } else { - save_runstack = scheme_push_prefix(genv, rp, + save_runstack = scheme_push_prefix(genv, 0, rp, (shift ? genv->module->me->src_modidx : NULL), (shift ? genv->link_midx : NULL), at_phase, genv->phase, @@ -8558,7 +8612,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env o = scheme_letrec_check_expr((Scheme_Object *)env->genv->module); - oi = scheme_optimize_info_create(env->prefix, 1); + oi = scheme_optimize_info_create(env->prefix, env->genv, env->insp, 1); scheme_optimize_info_enforce_const(oi, rec[drec].comp_flags & COMP_ENFORCE_CONSTS); if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) scheme_optimize_info_never_inline(oi); @@ -9286,7 +9340,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ m = scheme_letrec_check_expr(m); - oi = scheme_optimize_info_create(eenv->prefix, 1); + oi = scheme_optimize_info_create(eenv->prefix, eenv->genv, env->insp, 1); scheme_optimize_info_set_context(oi, (Scheme_Object *)env->genv->module); if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) scheme_optimize_info_never_inline(oi); diff --git a/racket/src/racket/src/mzmark_optimize.inc b/racket/src/racket/src/mzmark_optimize.inc index a3567bcaca..1567137434 100644 --- a/racket/src/racket/src/mzmark_optimize.inc +++ b/racket/src/racket/src/mzmark_optimize.inc @@ -15,6 +15,8 @@ static int mark_optimize_info_MARK(void *p, struct NewGC *gc) { gcMARK2(i->next, gc); gcMARK2(i->consts, gc); gcMARK2(i->cp, gc); + gcMARK2(i->env, gc); + gcMARK2(i->insp, gc); gcMARK2(i->top_level_consts, gc); gcMARK2(i->transitive_use_var, gc); gcMARK2(i->context, gc); @@ -38,6 +40,8 @@ static int mark_optimize_info_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(i->next, gc); gcFIXUP2(i->consts, gc); gcFIXUP2(i->cp, gc); + gcFIXUP2(i->env, gc); + gcFIXUP2(i->insp, gc); gcFIXUP2(i->top_level_consts, gc); gcFIXUP2(i->transitive_use_var, gc); gcFIXUP2(i->context, gc); diff --git a/racket/src/racket/src/mzmark_resolve.inc b/racket/src/racket/src/mzmark_resolve.inc index fa96140d0e..369c8e995e 100644 --- a/racket/src/racket/src/mzmark_resolve.inc +++ b/racket/src/racket/src/mzmark_resolve.inc @@ -69,6 +69,12 @@ static int mark_unresolve_info_MARK(void *p, struct NewGC *gc) { gcMARK2(i->closures, gc); gcMARK2(i->module, gc); gcMARK2(i->comp_prefix, gc); + gcMARK2(i->new_toplevels, gc); + gcMARK2(i->from_modidx, gc); + gcMARK2(i->to_modidx, gc); + gcMARK2(i->opt_env, gc); + gcMARK2(i->opt_insp, gc); + gcMARK2(i->inline_variants, gc); gcMARK2(i->toplevels, gc); gcMARK2(i->definitions, gc); gcMARK2(i->ref_lifts, gc); @@ -91,6 +97,12 @@ static int mark_unresolve_info_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(i->closures, gc); gcFIXUP2(i->module, gc); gcFIXUP2(i->comp_prefix, gc); + gcFIXUP2(i->new_toplevels, gc); + gcFIXUP2(i->from_modidx, gc); + gcFIXUP2(i->to_modidx, gc); + gcFIXUP2(i->opt_env, gc); + gcFIXUP2(i->opt_insp, gc); + gcFIXUP2(i->inline_variants, gc); gcFIXUP2(i->toplevels, gc); gcFIXUP2(i->definitions, gc); gcFIXUP2(i->ref_lifts, gc); diff --git a/racket/src/racket/src/mzmarksrc.c b/racket/src/racket/src/mzmarksrc.c index e8903b7f6a..8654616a99 100644 --- a/racket/src/racket/src/mzmarksrc.c +++ b/racket/src/racket/src/mzmarksrc.c @@ -1339,6 +1339,12 @@ mark_unresolve_info { gcMARK2(i->closures, gc); gcMARK2(i->module, gc); gcMARK2(i->comp_prefix, gc); + gcMARK2(i->new_toplevels, gc); + gcMARK2(i->from_modidx, gc); + gcMARK2(i->to_modidx, gc); + gcMARK2(i->opt_env, gc); + gcMARK2(i->opt_insp, gc); + gcMARK2(i->inline_variants, gc); gcMARK2(i->toplevels, gc); gcMARK2(i->definitions, gc); gcMARK2(i->ref_lifts, gc); @@ -1409,6 +1415,8 @@ mark_optimize_info { gcMARK2(i->next, gc); gcMARK2(i->consts, gc); gcMARK2(i->cp, gc); + gcMARK2(i->env, gc); + gcMARK2(i->insp, gc); gcMARK2(i->top_level_consts, gc); gcMARK2(i->transitive_use_var, gc); gcMARK2(i->context, gc); diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index 2831444540..57b74066a6 100644 --- a/racket/src/racket/src/optimize.c +++ b/racket/src/racket/src/optimize.c @@ -37,6 +37,7 @@ #define OPT_LIMIT_FUNCTION_RESIZE 0 #define OPT_BRANCH_ADDS_NO_SIZE 1 #define OPT_DELAY_GROUP_PROPAGATE 0 +#define OPT_PRE_OPTIMIZE_FOR_CROSS_MODULE(size_override) (size_override) #define MAX_PROC_INLINE_SIZE 256 #define CROSS_MODULE_INLINE_SIZE 8 @@ -57,6 +58,10 @@ struct Optimize_Info Comp_Prefix *cp; int init_kclock; + /* Compilation context, used for unresolving for cross-module inlining: */ + Scheme_Env *env; + Scheme_Object *insp; + /* Propagated up and down the chain: */ int size; int vclock; /* virtual clock that ticks for a side effect, a branch, @@ -2057,10 +2062,14 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a if (!iv) iv = scheme_hash_get(iv_ht, scheme_false); } - if (SAME_TYPE(SCHEME_TYPE(iv), scheme_inline_variant_type)) { + if (SAME_TYPE(SCHEME_TYPE(iv), scheme_vector_type)) { /* inline variant + shift info */ int has_cases = 0; Scheme_Object *orig_iv = iv; - iv = scheme_unresolve(iv, argc, &has_cases); + MZ_ASSERT(SAME_TYPE(scheme_inline_variant_type, SCHEME_TYPE(SCHEME_VEC_ELS(iv)[0]))); + /* unresolving may add new top-levels to `info->cp`: */ + iv = scheme_unresolve(SCHEME_VEC_ELS(iv)[0], argc, &has_cases, + info->cp, info->env, info->insp, SCHEME_INT_VAL(SCHEME_VEC_ELS(iv)[3]), + SCHEME_VEC_ELS(iv)[1], SCHEME_VEC_ELS(iv)[2]); if (has_cases) { if (!iv_ht) { iv_ht = scheme_make_hash_table(SCHEME_hash_ptr); @@ -5510,7 +5519,7 @@ static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_ val = SCHEME_VEC_ELS(data)[3]; - einfo = scheme_optimize_info_create(info->cp, 0); + einfo = scheme_optimize_info_create(info->cp, info->env, info->insp, 0); if (info->inline_fuel < 0) einfo->inline_fuel = -1; einfo->logger = info->logger; @@ -5535,7 +5544,7 @@ static Scheme_Object *begin_for_syntax_optimize(Scheme_Object *data, Optimize_In l = SCHEME_VEC_ELS(data)[2]; while (!SCHEME_NULLP(l)) { - einfo = scheme_optimize_info_create(info->cp, 0); + einfo = scheme_optimize_info_create(info->cp, info->env, info->insp, 0); if (info->inline_fuel < 0) einfo->inline_fuel = -1; einfo->logger = info->logger; @@ -7851,7 +7860,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) e = SCHEME_VEC_ELS(e)[1]; old_e = scheme_hash_get(info->top_level_consts, rpos); - if (old_e && SCHEME_LAMBDAP(old_e)) { + if (old_e && SCHEME_LAMBDAP(old_e) && OPT_PRE_OPTIMIZE_FOR_CROSS_MODULE(1)) { if (!originals) originals = scheme_make_hash_table(SCHEME_hash_ptr); scheme_hash_set(originals, scheme_make_integer(start_simultaneous), old_e); @@ -7937,7 +7946,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) Scheme_Object *sub_e, *alt_e; sub_e = SCHEME_VEC_ELS(e)[1]; alt_e = is_cross_module_inline_candidiate(sub_e, info, 0); - if (!alt_e && originals) { + if (!alt_e && originals && OPT_PRE_OPTIMIZE_FOR_CROSS_MODULE(size_override)) { alt_e = scheme_hash_get(originals, scheme_make_integer(i_m)); if (SAME_OBJ(alt_e, sub_e) && !size_override) alt_e = NULL; @@ -8514,7 +8523,7 @@ Scheme_Object *optimize_clone(int single_use, Scheme_Object *expr, Optimize_Info /* compile-time env for optimization */ /*========================================================================*/ -Optimize_Info *scheme_optimize_info_create(Comp_Prefix *cp, int get_logger) +Optimize_Info *scheme_optimize_info_create(Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, int get_logger) { Optimize_Info *info; @@ -8525,6 +8534,8 @@ Optimize_Info *scheme_optimize_info_create(Comp_Prefix *cp, int get_logger) info->inline_fuel = INITIAL_INLINING_FUEL; info->flatten_fuel = INITIAL_FLATTENING_FUEL; info->cp = cp; + info->env = env; + info->insp = insp; if (get_logger) { Scheme_Logger *logger; @@ -8771,7 +8782,7 @@ static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int { Optimize_Info *naya; - naya = scheme_optimize_info_create(info->cp, 0); + naya = scheme_optimize_info_create(info->cp, info->env, info->insp, 0); naya->flags = (short)flags; naya->next = info; naya->original_frame = orig; diff --git a/racket/src/racket/src/resolve.c b/racket/src/racket/src/resolve.c index 3cdb6e607d..bd4edcf2e4 100644 --- a/racket/src/racket/src/resolve.c +++ b/racket/src/racket/src/resolve.c @@ -2886,7 +2886,26 @@ typedef struct Unresolve_Info { int inlining; Scheme_Module *module; - Comp_Prefix *comp_prefix; + + Comp_Prefix *comp_prefix; /* Top-level and syntax-constant info for + top-level unresolved. This prefix is + the unresolved from of the original + resolved prefix. + + When unresolving a single lambda for + inlining, this prefix is NULL, and + tenattive additions are added to + `new_toplevels`, instead. */ + + Scheme_Hash_Table *new_toplevels; /* toplevels to add to an optimiation context */ + int new_toplevel_offset; /* the number of toplevels already registered in the + optimization context */ + Scheme_Object *from_modidx, *to_modidx; /* non-NULL => shift for adding to `new_toplevels` */ + intptr_t toplevel_ref_phase; + Scheme_Env *opt_env; + Scheme_Object *opt_insp; + Scheme_Object *inline_variants; + Scheme_Hash_Table *toplevels; Scheme_Object *definitions; int lift_offset, lift_to_local; @@ -2899,7 +2918,7 @@ static void locate_cyclic_closures(Scheme_Object *e, Unresolve_Info *ui); static Scheme_IR_Let_Header *make_let_header(int count); static Scheme_IR_Let_Value *make_ir_let_value(int count); -static Unresolve_Info *new_unresolve_info(Scheme_Prefix *prefix, int comp_flags) +static Unresolve_Info *new_unresolve_info(Resolve_Prefix *prefix, int comp_flags) { Unresolve_Info *ui; Scheme_IR_Local **vars; @@ -2908,12 +2927,13 @@ static Unresolve_Info *new_unresolve_info(Scheme_Prefix *prefix, int comp_flags) ui = MALLOC_ONE_RT(Unresolve_Info); SET_REQUIRED_TAG(ui->type = scheme_rt_unresolve_info); + ui->prefix = prefix; + ui->stack_pos = 0; ui->stack_size = 10; vars = MALLOC_N(Scheme_IR_Local *, ui->stack_size); ui->vars = vars; - ui->inlining = 1; ht = scheme_make_hash_table(SCHEME_hash_ptr); ui->toplevels = ht; ui->definitions = scheme_null; @@ -3091,6 +3111,7 @@ static int unresolve_toplevel_pos(int pos, Unresolve_Info *ui) LOG_UNRESOLVE(printf("pos before = %d\n", pos)); if (ui->prefix->num_stxes && (pos > (ui->prefix->num_toplevels + ui->prefix->num_stxes))) { + /* shift lifted reference down to toplevel range */ pos -= ui->prefix->num_stxes + 1; /* extra slot for lazy syntax */ } LOG_UNRESOLVE(printf("pos = %d\n", pos)); @@ -3100,23 +3121,132 @@ static int unresolve_toplevel_pos(int pos, Unresolve_Info *ui) static Scheme_Object *unresolve_toplevel(Scheme_Object *rdata, Unresolve_Info *ui) { - Scheme_Object *v, *opos; - int pos; + Scheme_Object *v; - if (!ui->prefix) return_NULL; + if (ui->inlining) { + /* Create a reference that works for the optimization context. */ + int pos = SCHEME_TOPLEVEL_POS(rdata); + if (ui->prefix->num_stxes + && (pos > (ui->prefix->num_toplevels + ui->prefix->num_stxes))) { + /* Cannot refer to a lift across a module boundary. */ + return_NULL; + } else { + Scheme_Object *hv, *modidx, *mod_constant; + int flags, is_constant; + int sym_pos; + intptr_t mod_defn_phase; - pos = unresolve_toplevel_pos(SCHEME_TOPLEVEL_POS(rdata), ui); - opos = scheme_make_integer(pos); - v = scheme_hash_get(ui->toplevels, opos); - if (!v) { - v = scheme_make_toplevel(0, - pos, - 0, - SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK); - scheme_hash_set(ui->toplevels, opos, v); + flags = SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK; + switch (flags) { + case SCHEME_TOPLEVEL_CONST: + is_constant = 2; + break; + case SCHEME_TOPLEVEL_FIXED: + is_constant = 1; + break; + case SCHEME_TOPLEVEL_READY: + default: + /* Since we're referencing from an imported context, the + variable is now at least ready: */ + flags = SCHEME_TOPLEVEL_READY; + is_constant = 0; + } + + v = ui->prefix->toplevels[pos]; + if (SCHEME_MPAIRP(v)) { + /* Simplified version was installed by link_module_variable; original is in CDR */ + v = SCHEME_CDR(v); + } + + if (SCHEME_SYMBOLP(v)) { + mod_defn_phase = ui->toplevel_ref_phase; + modidx = ui->to_modidx; + sym_pos = -1; + hv = scheme_hash_module_variable(ui->opt_env, modidx, + v, ui->opt_insp, + sym_pos, mod_defn_phase, is_constant, + NULL); + } else { + Module_Variable *mv = (Module_Variable *)v; + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_module_variable_type)); + mod_defn_phase = mv->mod_phase; + modidx = scheme_modidx_shift(mv->modidx, ui->from_modidx, ui->to_modidx); + hv = scheme_hash_module_variable(ui->opt_env, modidx, + mv->sym, ui->opt_insp, + mv->pos, mv->mod_phase, is_constant, + mv->shape); + v = mv->sym; + sym_pos = mv->pos; + } + + mod_constant = NULL; + if (!scheme_check_accessible_in_module_name(modidx, mod_defn_phase, ui->opt_env, + v, sym_pos, + ui->opt_insp, NULL, + &mod_constant)) + return_NULL; + + /* Check whether this variable is already known in the optimzation context: */ + v = scheme_hash_get(ui->comp_prefix->toplevels, hv); + if (!v) { + /* Not already in optimization context; check/extend tentative additions */ + if (!ui->new_toplevels) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + ui->new_toplevels = ht; + } + + v = scheme_hash_get(ui->new_toplevels, hv); + if (!v) { + int new_pos = ui->new_toplevel_offset + ui->new_toplevels->count; + v = scheme_make_toplevel(0, new_pos, 0, flags); + scheme_hash_set(ui->new_toplevels, hv, v); + + if (mod_constant + && ui->comp_prefix->inline_variants) { + if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) { + Scheme_Object *shiftable; + shiftable = scheme_make_vector(4, scheme_false); + SCHEME_VEC_ELS(shiftable)[0] = mod_constant; + SCHEME_VEC_ELS(shiftable)[1] = ui->from_modidx; + SCHEME_VEC_ELS(shiftable)[2] = ui->to_modidx; + SCHEME_VEC_ELS(shiftable)[3] = scheme_make_integer(mod_defn_phase); + mod_constant = shiftable; + } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) { + /* keep it */ + } else + mod_constant = NULL; + + if (mod_constant) { + mod_constant = scheme_make_pair(scheme_make_pair(scheme_make_integer(new_pos), + mod_constant), + ui->inline_variants); + ui->inline_variants = mod_constant; + } + } + } + } + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type)); + } + } else { + /* If needed, shift top-level position to account for moving + lifts to toplevels. */ + Scheme_Object *opos; + int pos; + + pos = unresolve_toplevel_pos(SCHEME_TOPLEVEL_POS(rdata), ui); + opos = scheme_make_integer(pos); + v = scheme_hash_get(ui->toplevels, opos); + if (!v) { + v = scheme_make_toplevel(0, + pos, + 0, + SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK); + scheme_hash_set(ui->toplevels, opos, v); + } + LOG_UNRESOLVE(printf("flags for %d: %d\n", pos, SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK)); } - LOG_UNRESOLVE(printf("flags for %d: %d\n", pos, SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK)); - + ui->has_tl = 1; return v; @@ -3186,9 +3316,7 @@ static Scheme_Object *unresolve_define_or_begin_syntaxes(int def, Scheme_Object } else names = NULL; - nui = new_unresolve_info(NULL, ui->comp_flags); - nui->inlining = 0; - nui->prefix = prefix; + nui = new_unresolve_info(prefix, ui->comp_flags); nui->lift_to_local = 1; dummy = unresolve_expr(dummy, ui, 0); @@ -3739,16 +3867,13 @@ Scheme_Object *unresolve_module(Scheme_Object *e, Unresolve_Info *ui_in) Unresolve_Info *ui; int i, cnt, len; - ui = new_unresolve_info(NULL, ui_in->comp_flags); - ui->inlining = 0; + ui = new_unresolve_info(m->prefix, ui_in->comp_flags); ui->module = m; cp = unresolve_prefix(m->prefix, ui); if (!cp) return_NULL; ui->comp_prefix = cp; - ui->prefix = m->prefix; - cnt = SCHEME_VEC_SIZE(m->bodies[0]); bs = scheme_make_vector(cnt, NULL); @@ -4431,7 +4556,7 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int a Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)e; Scheme_Local *cqs; - if (!ui->prefix) return_NULL; + if (ui->inlining) return_NULL; cqs = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); cqs->iso.so.type = scheme_ir_quote_syntax_type; @@ -4466,6 +4591,9 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int a } Scheme_Object *scheme_unresolve_top(Scheme_Object* o, Comp_Prefix **cp, int comp_flags) +/* Convert from "resolved" form back to the intermediate representation used + by the optimizer. Unresolving generates an intermediate-representation prefix + (for top levels and syntax literals) in addition to the code. */ { Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)o; Scheme_Object *code = top->code, *defns; @@ -4474,9 +4602,7 @@ Scheme_Object *scheme_unresolve_top(Scheme_Object* o, Comp_Prefix **cp, int comp Unresolve_Info *ui; int len, i; - ui = new_unresolve_info(NULL, comp_flags); - ui->inlining = 0; - ui->prefix = rp; + ui = new_unresolve_info(rp, comp_flags); c = unresolve_prefix(rp, ui); ui->comp_prefix = c; @@ -4507,10 +4633,18 @@ Scheme_Object *scheme_unresolve_top(Scheme_Object* o, Comp_Prefix **cp, int comp return code; } -Scheme_Object *scheme_unresolve(Scheme_Object *iv, int argc, int *_has_cases) +Scheme_Object *scheme_unresolve(Scheme_Object *iv, int argc, int *_has_cases, + Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, intptr_t ref_phase, + Scheme_Object *from_modidx, Scheme_Object *to_modidx) +/* Convert a single function from "resolved" form back to the + intermediate representation used by the optimizer. Unresolving can + add new items to the intermediate-representation prefix for top levels. */ { Scheme_Object *o; Scheme_Lambda *lam = NULL; + Unresolve_Info *ui; + + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(iv), scheme_inline_variant_type)); o = SCHEME_VEC_ELS(iv)[1]; @@ -4545,12 +4679,44 @@ Scheme_Object *scheme_unresolve(Scheme_Object *iv, int argc, int *_has_cases) if (!lam) return_NULL; - if (lam->closure_size) - return_NULL; + ui = new_unresolve_info((Resolve_Prefix *)SCHEME_VEC_ELS(iv)[2], 0); + ui->inlining = 1; + ui->from_modidx = from_modidx; + ui->to_modidx = to_modidx; + ui->new_toplevel_offset = cp->num_toplevels; + ui->comp_prefix = cp; + ui->opt_env = env; + ui->opt_insp = insp; + ui->toplevel_ref_phase = ref_phase; + ui->inline_variants = scheme_null; /* convert an optimized & resolved closure back to compiled form: */ - return unresolve_lambda(lam, - new_unresolve_info((Scheme_Prefix *)SCHEME_VEC_ELS(iv)[2], 0)); + o = unresolve_lambda(lam, ui); + + if (o) { + /* Added any toplevels? */ + if (ui->new_toplevels) { + int i; + Scheme_Object *l; + + for (i = ui->new_toplevels->size; i--; ) { + if (ui->new_toplevels->vals[i]) { + scheme_hash_set(cp->toplevels, + ui->new_toplevels->keys[i], + ui->new_toplevels->vals[i]); + cp->num_toplevels++; + } + } + + for (l = ui->inline_variants; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + scheme_hash_set(ui->comp_prefix->inline_variants, + SCHEME_CAR(SCHEME_CAR(l)), + SCHEME_CDR(SCHEME_CAR(l))); + } + } + } + + return o; } /*========================================================================*/ diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 73e7e0a305..f83b17dd11 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -3274,7 +3274,9 @@ Scheme_Object *scheme_optimize_extract_tail_inside(Scheme_Object *t2); Scheme_Object *scheme_resolve_expr(Scheme_Object *, Resolve_Info *); Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *); -Scheme_Object *scheme_unresolve(Scheme_Object *, int argv, int *_has_cases); +Scheme_Object *scheme_unresolve(Scheme_Object *, int argv, int *_has_cases, + Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, intptr_t ref_phase, + Scheme_Object *from_modidx, Scheme_Object *to_modidx); Scheme_Object *scheme_unresolve_top(Scheme_Object *, Comp_Prefix **, int comp_flags); int scheme_check_leaf_rator(Scheme_Object *le, int *_flags); @@ -3294,7 +3296,7 @@ int scheme_resolve_info_use_jit(Resolve_Info *ri); void scheme_enable_expression_resolve_lifts(Resolve_Info *ri); Scheme_Object *scheme_merge_expression_resolve_lifts(Scheme_Object *expr, Resolve_Prefix *rp, Resolve_Info *ri); -Optimize_Info *scheme_optimize_info_create(Comp_Prefix *cp, int get_logger); +Optimize_Info *scheme_optimize_info_create(Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, int get_logger); void scheme_optimize_info_enforce_const(Optimize_Info *, int enforce_const); void scheme_optimize_info_set_context(Optimize_Info *, Scheme_Object *ctx); void scheme_optimize_info_never_inline(Optimize_Info *); @@ -3518,7 +3520,7 @@ void scheme_install_binding_names(Scheme_Object *binding_namess, Scheme_Env *env Scheme_Hash_Table *scheme_get_binding_names_table(Scheme_Env *env); int scheme_prefix_depth(Resolve_Prefix *rp); -Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, +Scheme_Object **scheme_push_prefix(Scheme_Env *genv, int already_linked, Resolve_Prefix *rp, Scheme_Object *src_modix, Scheme_Object *now_modix, int src_phase, int now_phase, Scheme_Env *dummy_env, Scheme_Object *insp); @@ -3890,13 +3892,17 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem Scheme_Module_Exports *scheme_make_module_exports(); -Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *in_modidx, - Scheme_Object *symbol, Scheme_Object *stx, - Scheme_Object *current_insp, Scheme_Object *binding_insp, - int position, int want_pos, - int *_protected, int *_unexported, - Scheme_Env *from_env, int *_would_complain, - Scheme_Object **_is_constant); +Scheme_Object *scheme_check_accessible_in_module_instance(Scheme_Env *env, + Scheme_Object *symbol, Scheme_Object *stx, + Scheme_Object *current_insp, Scheme_Object *binding_insp, + int position, int want_pos, + int *_protected, int *_unexported, + Scheme_Env *from_env, int *_would_complain, + Scheme_Object **_is_constant); +int scheme_check_accessible_in_module_name(Scheme_Object *modidx, intptr_t mod_phase, Scheme_Env *env, + Scheme_Object *symbol, int position, + Scheme_Object *current_insp, Scheme_Object *binding_insp, + Scheme_Object **_is_constant); Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name, int mod_phase); Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx,