diff --git a/src/mzcom/mzobj.cxx b/src/mzcom/mzobj.cxx index f329b7ac0e..0ec5ece739 100644 --- a/src/mzcom/mzobj.cxx +++ b/src/mzcom/mzobj.cxx @@ -130,7 +130,6 @@ void setupSchemeEnv(Scheme_Env *in_env) char exeBuff[260]; HMODULE mod; static BOOL registered; - Scheme_Object *nsreq, *a[1]; if (!registered) { scheme_register_static(&env,sizeof(env)); @@ -159,9 +158,7 @@ void setupSchemeEnv(Scheme_Env *in_env) // initialize namespace - nsreq = scheme_builtin_value("namespace-require"); - a[0] = scheme_intern_symbol("scheme"); - scheme_apply(nsreq, 1, a); + scheme_namespace_require(scheme_intern_symbol("scheme")); // set up exception trapping diff --git a/src/mzscheme/cmdline.inc b/src/mzscheme/cmdline.inc index 5a82470a05..eafec6f24f 100644 --- a/src/mzscheme/cmdline.inc +++ b/src/mzscheme/cmdline.inc @@ -100,32 +100,6 @@ static int is_number_arg(const char *s) return 1; } -static char *protect_quote_backslash(const char *file) -{ - int i, c; - - for (i = c = 0; file[i]; i++) { - if ((file[i] == '"') || (file[i] == '\\')) - c++; - } - - if (c) { - char *s; - - s = (char *)malloc(i + c + 1); - - for (i = c = 0; file[i]; i++) { - if ((file[i] == '"') || (file[i] == '\\')) - s[c++] = '\\'; - s[c++] = file[i]; - } - s[c] = 0; - - return s; - } else - return (char *)file; -} - static char *make_embedded_load(const char *start, const char *end) { char *s; diff --git a/src/mzscheme/gc2/compact.c b/src/mzscheme/gc2/compact.c index af9f35dc20..f0328bc02f 100644 --- a/src/mzscheme/gc2/compact.c +++ b/src/mzscheme/gc2/compact.c @@ -4759,3 +4759,11 @@ void GC_dump(void) GC_dump_with_traces(0, NULL, NULL, NULL, 0, NULL, 0); } +/******************************************************************************/ +/* GC free all */ +/******************************************************************************/ + +void GC_free_all(void) +{ +} + diff --git a/src/mzscheme/gc2/gc2.h b/src/mzscheme/gc2/gc2.h index 7d34d403cc..b225bc4b61 100644 --- a/src/mzscheme/gc2/gc2.h +++ b/src/mzscheme/gc2/gc2.h @@ -118,6 +118,12 @@ GC2_EXTERN void GC_gcollect(void); /* Performs an immediate (full) collection. */ +GC2_EXTERN void GC_free_all(void); +/* + Releases all memory, removes all signal handlers, etc. + This is mainly useful for unloading a DLL within an embedding + program tht will keep running. */ + /***************************************************************************/ /* Allocation */ /***************************************************************************/ diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 6acc6fe067..1c214708b2 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -3265,3 +3265,39 @@ void GC_dump_variable_stack(void **var_stack, } #endif + +/******************************************************************************/ +/* GC free all */ +/******************************************************************************/ + +void GC_free_all(void) +{ + int i; + struct mpage *work, *next; + + remove_signal_handler(); + + for (work = gen0_big_pages; work; work = next) { + next = work->next; + free_pages(work->addr, round_to_apage_size(work->size)); + free_mpage(work); + } + + for(i = 0; i < PAGE_TYPES; i++) { + for (work = pages[i]; work; work = next) { + next = work->next; + + if (work->mprotected) + protect_pages(work->addr, + work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, + 1); + + pagemap_remove(work); + free_backtrace(work); + free_pages(work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE); + free_mpage(work); + } + } + + flush_freed_pages(); +} diff --git a/src/mzscheme/gc2/sighand.c b/src/mzscheme/gc2/sighand.c index 2232a03d82..23dc036530 100644 --- a/src/mzscheme/gc2/sighand.c +++ b/src/mzscheme/gc2/sighand.c @@ -1,6 +1,7 @@ /* Provides: initialize_signal_handler(); + remove_signal_handler(); Requires: generations_available - mutable int, Windows only designate_modified @@ -131,3 +132,33 @@ static void initialize_signal_handler() } # endif } + +static void remove_signal_handler() +{ +# ifdef NEED_OSX_MACH_HANDLER +# endif +# ifdef NEED_SIGACTION + { + struct sigaction act, oact; + memset(&act, 0, sizeof(sigaction)); + act.sa_sahandler = SIG_DFL; + sigemptyset(&act.sa_mask); + act.sa_flags = SA_SIGINFO; + sigaction(USE_SIGACTON_SIGNAL_KIND, &act, &oact); + } +# endif +# ifdef NEED_SIGWIN + if (generations_available) { + HMODULE hm; + ULONG (WINAPI*rveh)(gcPVECTORED_EXCEPTION_HANDLER); + + hm = LoadLibrary("kernel32.dll"); + if (hm) + rveh = (ULONG (WINAPI*)(gcPVECTORED_EXCEPTION_HANDLER))GetProcAddress(hm, "RemoveVectoredExceptionHandler"); + else + rveh = NULL; + if (rveh) + rveh(fault_handler); + } +# endif +} diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index d6a1e59983..13da0bb179 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -1677,6 +1677,7 @@ MZ_EXTERN void scheme_init_collection_paths(Scheme_Env *global_env, Scheme_Objec /* Initialization */ MZ_EXTERN Scheme_Env *scheme_basic_env(void); MZ_EXTERN void scheme_reset_overflow(void); +MZ_EXTERN void scheme_free_all(void); #ifdef USE_MSVC_MD_LIBRARY MZ_EXTERN void GC_pre_init(void); diff --git a/src/mzscheme/src/dynext.c b/src/mzscheme/src/dynext.c index 3ebaed5d8c..745e8313f4 100644 --- a/src/mzscheme/src/dynext.c +++ b/src/mzscheme/src/dynext.c @@ -508,6 +508,25 @@ Scheme_Object *scheme_load_extension(const char *filename, Scheme_Env *env) return load_extension(1, a); } +void scheme_free_dynamic_extensions() +{ + if (loaded_extensions) { + int i; + ExtensionData *ed; + for (i = 0; i < loaded_extensions->size; i++) { + if (loaded_extensions->vals[i]) { + ed = (ExtensionData *)loaded_extensions->vals[i]; +# ifdef UNIX_DYNAMIC_LOAD + dlclose(ed->handle); +# endif +# ifdef WINDOWS_DYNAMIC_LOAD + FreeLibrary(ed->handle); +# endif + } + } + } +} + #if defined(CODEFRAGMENT_DYNAMIC_LOAD) static Boolean get_ext_file_spec(FSSpec *spec, const char *filename) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 1f83cbdfc5..aaa3875b26 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -180,6 +180,17 @@ static void init_dummy_foreign(Scheme_Env *env) } #endif +static void boot_module_resolver() +{ + Scheme_Object *boot, *a[2]; + a[0] = scheme_make_pair(scheme_intern_symbol("quote"), + scheme_make_pair(scheme_intern_symbol("#%boot"), + scheme_null)); + a[1] = scheme_intern_symbol("boot"); + boot = scheme_dynamic_require(2, a); + scheme_apply(boot, 0, NULL); +} + Scheme_Env *scheme_basic_env() { Scheme_Env *env; @@ -198,6 +209,7 @@ Scheme_Env *scheme_basic_env() scheme_make_thread(); scheme_init_error_escape_proc(NULL); + scheme_init_module_resolver(); env = scheme_make_empty_env(); scheme_install_initial_module_set(env); @@ -211,6 +223,8 @@ Scheme_Env *scheme_basic_env() scheme_init_exn_config(); #endif + boot_module_resolver(); + return env; } @@ -387,15 +401,7 @@ Scheme_Env *scheme_basic_env() scheme_add_embedded_builtins(env); - { - Scheme_Object *boot, *a[2]; - a[0] = scheme_make_pair(scheme_intern_symbol("quote"), - scheme_make_pair(scheme_intern_symbol("#%boot"), - scheme_null)); - a[1] = scheme_intern_symbol("boot"); - boot = scheme_dynamic_require(2, a); - scheme_apply(boot, 0, NULL); - } + boot_module_resolver(); scheme_save_initial_module_set(env); diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index d47bc7d456..e8161e50c9 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -259,8 +259,6 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob void scheme_init_module(Scheme_Env *env) { - Scheme_Object *o; - scheme_register_syntax(MODULE_EXPD, module_optimize, module_resolve, module_sfs, module_validate, @@ -321,12 +319,7 @@ void scheme_init_module(Scheme_Env *env) scheme_install_type_writer(scheme_module_type, write_module); scheme_install_type_reader(scheme_module_type, read_module); - o = scheme_make_prim_w_arity(default_module_resolver, - "default-module-name-resolver", - 1, 4); - scheme_set_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_RESOLVER, o); - - scheme_set_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_NAME, scheme_false); + scheme_init_module_resolver(); scheme_add_global_constant("current-module-name-resolver", scheme_register_parameter(current_module_name_resolver, @@ -460,6 +453,22 @@ void scheme_init_module(Scheme_Env *env) env); } +void scheme_init_module_resolver(void) +{ + Scheme_Object *o; + Scheme_Config *config; + + config = scheme_current_config(); + + o = scheme_make_prim_w_arity(default_module_resolver, + "default-module-name-resolver", + 1, 4); + + scheme_set_param(config, MZCONFIG_CURRENT_MODULE_RESOLVER, o); + + scheme_set_param(config, MZCONFIG_CURRENT_MODULE_NAME, scheme_false); +} + void scheme_finish_kernel(Scheme_Env *env) { /* When this function is called, the initial namespace has all the @@ -787,6 +796,9 @@ static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv) { Scheme_Object *p = argv[0]; + if (argc == 1) + return scheme_void; /* ignore notify */ + if (SCHEME_PAIRP(p) && SAME_OBJ(SCHEME_CAR(p), quote_symbol) && SCHEME_PAIRP(SCHEME_CDR(p)) diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 39f98b1db5..71ab847871 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -199,6 +199,8 @@ void scheme_init_getenv(void); void scheme_init_foreign(Scheme_Env *env); #endif +void scheme_free_dynamic_extensions(void); + /* Type readers & writers for compiled code data */ typedef Scheme_Object *(*Scheme_Type_Reader)(Scheme_Object *list); typedef Scheme_Object *(*Scheme_Type_Writer)(Scheme_Object *obj); @@ -220,6 +222,7 @@ void scheme_init_exn_config(void); #ifdef WINDOWS_PROCESSES void scheme_init_thread_memory(void); #endif +void scheme_init_module_resolver(void); void scheme_finish_kernel(Scheme_Env *env); diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index b5ddeb4049..ccb97ddb84 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -186,6 +186,8 @@ static Scheme_Custodian *main_custodian; static Scheme_Custodian *last_custodian; static Scheme_Hash_Table *limited_custodians = NULL; +static Scheme_Object *initial_inspector; + #ifndef MZ_PRECISE_GC static int cust_box_count, cust_box_alloc; static Scheme_Custodian_Box **cust_boxes; @@ -1918,6 +1920,15 @@ static void check_current_custodian_allows(const char *who, Scheme_Thread *p) (Scheme_Object *)p); } +void scheme_free_all(void) +{ + scheme_do_close_managed(NULL, NULL); + scheme_free_dynamic_extensions(); +#ifdef MZ_PRECISE_GC + GC_free_all(); +#endif +} + /*========================================================================*/ /* thread sets */ /*========================================================================*/ @@ -6439,7 +6450,17 @@ static void make_initial_config(Scheme_Thread *p) { Scheme_Object *ins; - ins = scheme_make_initial_inspectors(); + if (initial_inspector) { + ins = initial_inspector; + } else { + ins = scheme_make_initial_inspectors(); + /* Keep the initial inspector in case someone resets Scheme (by + calling scheme_basic_env() a second time. Using the same + inspector after a reset lets us use the same initial module + instances. */ + REGISTER_SO(initial_inspector); + initial_inspector = ins; + } init_param(cells, paramz, MZCONFIG_INSPECTOR, ins); init_param(cells, paramz, MZCONFIG_CODE_INSPECTOR, ins); }