fix scheme_basic_env() as a reset mechanism; add scheme_free_all(), which is useful to one user who needs to unload the MzScheme DLL within a longer-running program

svn: r9765

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");
+  scheme_namespace_require(scheme_intern_symbol("scheme"));
-  a[0] = scheme_intern_symbol("scheme");
-  scheme_apply(nsreq, 1, a);
 
   // set up exception trapping
 

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;

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)
+{
+}
+

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                                                              */
 /***************************************************************************/

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();
+}

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
+}

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);

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)

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);
 
-  {
+  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_save_initial_module_set(env);
 

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,
+  scheme_init_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_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))

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);
 

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);
   }