diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 6f41f371ec..ac46d04000 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -1928,8 +1928,8 @@ void scheme_unbound_global(Scheme_Bucket *b) else errmsg = "reference to an identifier before its definition: %S%_%s"; - if (SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase)) { - sprintf(phase_buf, " phase: %ld", SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase)); + if (((Scheme_Bucket_With_Home *)b)->home->phase) { + sprintf(phase_buf, " phase: %ld", ((Scheme_Bucket_With_Home *)b)->home->phase); phase = phase_buf; } else phase = ""; diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index b2a3a21a44..f9f6646870 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -7399,6 +7399,8 @@ scheme_get_stack_trace(Scheme_Object *mark_set) if (SCHEME_FALSEP(SCHEME_CDR(name))) what = "[traversing imports]"; + else if (SCHEME_VOIDP(SCHEME_CDR(name))) + what = "[running expand-time body]"; else what = "[running body]"; diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index f6c17b8e2a..593a7ee31a 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -166,7 +166,7 @@ SHARED_OK static void *struct_proc_extract_code; SHARED_OK static void *bad_app_vals_target; SHARED_OK static void *app_values_slow_code, *app_values_multi_slow_code, *app_values_tail_slow_code; SHARED_OK static void *finish_tail_call_code, *finish_tail_call_fixup_code; -SHARED_OK static void *module_run_start_code, *module_start_start_code; +SHARED_OK static void *module_run_start_code, *module_exprun_start_code, *module_start_start_code; SHARED_OK static void *box_flonum_from_stack_code; SHARED_OK static void *fl1_fail_code, *fl2rr_fail_code[2], *fl2fr_fail_code[2], *fl2rf_fail_code[2]; @@ -11555,6 +11555,37 @@ static int do_generate_more_common(mz_jit_state *jitter, void *_data) register_sub_func(jitter, module_run_start_code, scheme_eof); } + /* *** module_exprun_start_code *** */ + /* Pushes a module name onto the stack for stack traces. */ + { + int in; + + module_exprun_start_code = jit_get_ip().ptr; + jit_prolog(3); + in = jit_arg_p(); + jit_getarg_p(JIT_R0, in); /* menv */ + in = jit_arg_p(); + jit_getarg_i(JIT_R1, in); /* set_ns */ + in = jit_arg_p(); + jit_getarg_p(JIT_R2, in); /* &name */ + CHECK_LIMIT(); + + /* Store the name where we can find it */ + mz_push_locals(); + mz_set_local_p(JIT_R2, JIT_LOCAL2); + + jit_prepare(2); + jit_pusharg_i(JIT_R1); + jit_pusharg_p(JIT_R0); + (void)mz_finish(scheme_module_exprun_finish); + CHECK_LIMIT(); + mz_pop_locals(); + jit_ret(); + CHECK_LIMIT(); + + register_sub_func(jitter, module_exprun_start_code, scheme_eof); + } + /* *** module_start_start_code *** */ /* Pushes a module name onto the stack for stack traces. */ { @@ -12822,6 +12853,7 @@ static void release_native_code(void *fnlized, void *p) #endif typedef void *(*Module_Run_Proc)(Scheme_Env *menv, Scheme_Env *env, Scheme_Object **name); +typedef void *(*Module_Exprun_Proc)(Scheme_Env *menv, int set_ns, Scheme_Object **name); typedef void *(*Module_Start_Proc)(struct Start_Module_Args *a, Scheme_Object **name); void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *name) @@ -12833,6 +12865,15 @@ void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object * return scheme_module_run_finish(menv, env); } +void *scheme_module_exprun_start(Scheme_Env *menv, int set_ns, Scheme_Object *name) +{ + Module_Exprun_Proc proc = (Module_Exprun_Proc)module_exprun_start_code; + if (proc) + return proc(menv, set_ns, &name); + else + return scheme_module_exprun_finish(menv, set_ns); +} + void *scheme_module_start_start(struct Start_Module_Args *a, Scheme_Object *name) { Module_Start_Proc proc = (Module_Start_Proc)module_start_start_code; diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 8c24c7ab9c..75c976daa5 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -4164,6 +4164,15 @@ static void expstart_module(Scheme_Env *menv, Scheme_Env *env, int restart) } static void run_module_exptime(Scheme_Env *menv, int set_ns) +{ +#ifdef MZ_USE_JIT + (void)scheme_module_exprun_start(menv, set_ns, scheme_make_pair(menv->module->modname, scheme_void)); +#else + (void)scheme_module_exprun_finish(menv, set_ns); +#endif +} + +void *scheme_module_exprun_finish(Scheme_Env *menv, int set_ns) { int let_depth, for_stx; Scheme_Object *names, *e; @@ -4176,17 +4185,17 @@ static void run_module_exptime(Scheme_Env *menv, int set_ns) Scheme_Config *config; if (menv->module->primitive) - return; + return NULL; if (!SCHEME_VEC_SIZE(menv->module->et_body)) - return; + return NULL; syntax = menv->syntax; exp_env = menv->exp_env; if (!exp_env) - return; + return NULL; for_stx_globals = exp_env->toplevel; @@ -4222,6 +4231,8 @@ static void run_module_exptime(Scheme_Env *menv, int set_ns) if (set_ns) { scheme_pop_continuation_frame(&cframe); } + + return NULL; } static void do_start_module(Scheme_Module *m, Scheme_Env *menv, Scheme_Env *env, int restart) @@ -4350,12 +4361,25 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, static void do_prepare_compile_env(Scheme_Env *env, int base_phase, int pos) { - Scheme_Object *v; + Scheme_Object *v, *prev; Scheme_Env *menv; v = MODCHAIN_AVAIL(env->modchain, pos); if (!SCHEME_FALSEP(v)) { MODCHAIN_AVAIL(env->modchain, pos) = scheme_false; + + /* Reverse order of the list; if X requires Y, Y + has been pushed onto the front of the list + before X. */ + prev = scheme_false; + while (SCHEME_NAMESPACEP(v)) { + menv = (Scheme_Env *)v; + v = menv->available_next[pos]; + menv->available_next[pos] = prev; + prev = (Scheme_Object *)menv; + } + v = prev; + while (SCHEME_NAMESPACEP(v)) { menv = (Scheme_Env *)v; v = menv->available_next[pos]; diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index e006fd44a9..a166835415 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -2475,9 +2475,11 @@ struct Start_Module_Args; #ifdef MZ_USE_JIT void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *name); +void *scheme_module_exprun_start(Scheme_Env *menv, int set_ns, Scheme_Object *name); void *scheme_module_start_start(struct Start_Module_Args *a, Scheme_Object *name); #endif void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env); +void *scheme_module_exprun_finish(Scheme_Env *menv, int set_ns); void *scheme_module_start_finish(struct Start_Module_Args *a); Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Info *rec, int drec);