suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r9765
This commit is contained in:
Matthew Flatt 2008-05-09 13:20:36 +00:00
parent 70a3b20f8b
commit 134b04395f
12 changed files with 162 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/mzcom/mzobj.cxx
View File

@ -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

26
src/mzscheme/cmdline.inc
View File

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

8
src/mzscheme/gc2/compact.c
View File

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

6
src/mzscheme/gc2/gc2.h
View File

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

36
src/mzscheme/gc2/newgc.c
View File

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

31
src/mzscheme/gc2/sighand.c
View File

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

1
src/mzscheme/include/scheme.h
View File

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

19
src/mzscheme/src/dynext.c
View File

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

24
src/mzscheme/src/env.c
View File

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

28
src/mzscheme/src/module.c
View File

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

3
src/mzscheme/src/schpriv.h
View File

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

23
src/mzscheme/src/thread.c
View File

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