diff --git a/src/mzscheme/gc2/mem_account.c b/src/mzscheme/gc2/mem_account.c index 8d3039170a..a77527b93e 100644 --- a/src/mzscheme/gc2/mem_account.c +++ b/src/mzscheme/gc2/mem_account.c @@ -220,7 +220,7 @@ inline static unsigned long custodian_usage(NewGC*gc, void *custodian) if(!gc->really_doing_accounting) { gc->park[0] = custodian; gc->really_doing_accounting = 1; - garbage_collect(gc, 1); + garbage_collect(gc, 1, 0); custodian = gc->park[0]; gc->park[0] = NULL; } @@ -440,7 +440,7 @@ inline static void BTC_add_account_hook(int type,void *c1,void *c2,unsigned long gc->park[0] = c1; gc->park[1] = c2; gc->really_doing_accounting = 1; - garbage_collect(gc, 1); + garbage_collect(gc, 1, 0); c1 = gc->park[0]; gc->park[0] = NULL; c2 = gc->park[1]; gc->park[1] = NULL; } diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 4eb4627bef..2517b314cb 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -224,7 +224,7 @@ void GC_set_collect_inform_callback(void (*func)(int major_gc, long pre_used, lo /*****************************************************************************/ /* OS-Level Memory Management Routines */ /*****************************************************************************/ -static void garbage_collect(NewGC*, int); +static void garbage_collect(NewGC*, int, int); static void out_of_memory() { @@ -263,9 +263,9 @@ inline static void check_used_against_max(NewGC *gc, size_t len) gc->unsafe_allocation_abort(gc); } else { if(gc->used_pages > gc->max_pages_for_use) { - garbage_collect(gc, 0); /* hopefully this will free enough space */ + garbage_collect(gc, 0, 0); /* hopefully this will free enough space */ if(gc->used_pages > gc->max_pages_for_use) { - garbage_collect(gc, 1); /* hopefully *this* will free enough space */ + garbage_collect(gc, 1, 0); /* hopefully *this* will free enough space */ if(gc->used_pages > gc->max_pages_for_use) { /* too much memory allocated. * Inform the thunk and then die semi-gracefully */ @@ -599,7 +599,7 @@ static inline void gc_if_needed_account_alloc_size(NewGC *gc, size_t allocate_si else { #endif if (!gc->dumping_avoid_collection) - garbage_collect(gc, 0); + garbage_collect(gc, 0, 0); #ifdef MZ_USE_PLACES } #endif @@ -830,7 +830,7 @@ unsigned long GC_make_jit_nursery_page(int count) { if((gc->gen0.current_size + size) >= gc->gen0.max_size) { if (!gc->dumping_avoid_collection) - garbage_collect(gc, 0); + garbage_collect(gc, 0, 0); } gc->gen0.current_size += size; @@ -931,7 +931,7 @@ inline static void *allocate(const size_t request_size, const int type) LOG_PRIM_START(((void*)garbage_collect)); #endif - garbage_collect(gc, 0); + garbage_collect(gc, 0, 0); #ifdef INSTRUMENT_PRIMITIVES LOG_PRIM_END(((void*)garbage_collect)); @@ -1876,7 +1876,7 @@ static void Master_collect() { printf("START MASTER COLLECTION\n"); fprintf(gcdebugOUT(), "START MASTER COLLECTION\n"); MASTERGC->major_places_gc = 0; - garbage_collect(MASTERGC, 1); + garbage_collect(MASTERGC, 1, 0); printf("END MASTER COLLECTION\n"); fprintf(gcdebugOUT(), "END MASTER COLLECTION\n"); } @@ -2028,7 +2028,7 @@ void GC_switch_out_master_gc() { if(!initialized) { NewGC *gc = GC_get_GC(); initialized = 1; - garbage_collect(gc, 1); + garbage_collect(gc, 1, 1); #ifdef MZ_USE_PLACES GC_gen0_alloc_page_ptr = 2; @@ -2089,7 +2089,7 @@ void GC_switch_back_from_master(void *gc) { void GC_gcollect(void) { NewGC *gc = GC_get_GC(); - garbage_collect(gc, 1); + garbage_collect(gc, 1, 0); } static inline int atomic_mark(void *p) { return 0; } @@ -3393,7 +3393,7 @@ extern double scheme_get_inexact_milliseconds(void); really clean up. The full_needed_for_finalization flag triggers the second full GC. */ -static void garbage_collect(NewGC *gc, int force_full) +static void garbage_collect(NewGC *gc, int force_full, int switching_master) { unsigned long old_mem_use; unsigned long old_gen0; @@ -3543,7 +3543,7 @@ static void garbage_collect(NewGC *gc, int force_full) clean_up_heap(gc); TIME_STEP("cleaned heap"); #ifdef MZ_USE_PLACES - if (premaster_or_place_gc(gc)) + if (premaster_or_place_gc(gc) && !switching_master) #endif reset_nursery(gc); TIME_STEP("reset nursurey"); @@ -3554,7 +3554,7 @@ static void garbage_collect(NewGC *gc, int force_full) TIME_STEP("accounted"); if (gc->generations_available) { #ifdef MZ_USE_PLACES - if (postmaster_and_master_gc(gc)) { + if (postmaster_and_master_gc(gc) || switching_master) { unprotect_old_pages(gc); } else { diff --git a/src/mzscheme/include/schthread.h b/src/mzscheme/include/schthread.h index 0e3c9763da..5d53e414b8 100644 --- a/src/mzscheme/include/schthread.h +++ b/src/mzscheme/include/schthread.h @@ -249,7 +249,6 @@ typedef struct Thread_Local_Variables { int current_lifetime_; int scheme_main_was_once_suspended_; int buffer_init_size_; - Scheme_Object *initial_inspector_; long scheme_total_gc_time_; long start_this_gc_time_; long end_this_gc_time_; @@ -259,6 +258,8 @@ typedef struct Thread_Local_Variables { int locale_on_; const mzchar *current_locale_name_; int gensym_counter_; + Scheme_Object *dummy_input_port_; + Scheme_Object *dummy_output_port_; /*KPLAKE1*/ } Thread_Local_Variables; @@ -493,7 +494,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define current_lifetime XOA (scheme_get_thread_local_variables()->current_lifetime_) #define scheme_main_was_once_suspended XOA (scheme_get_thread_local_variables()->scheme_main_was_once_suspended_) #define buffer_init_size XOA (scheme_get_thread_local_variables()->buffer_init_size_) -#define initial_inspector XOA (scheme_get_thread_local_variables()->initial_inspector_) #define scheme_total_gc_time XOA (scheme_get_thread_local_variables()->scheme_total_gc_time_) #define start_this_gc_time XOA (scheme_get_thread_local_variables()->start_this_gc_time_) #define end_this_gc_time XOA (scheme_get_thread_local_variables()->end_this_gc_time_) @@ -503,6 +503,8 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define locale_on XOA (scheme_get_thread_local_variables()->locale_on_) #define current_locale_name XOA (scheme_get_thread_local_variables()->current_locale_name_) #define gensym_counter XOA (scheme_get_thread_local_variables()->gensym_counter_) +#define dummy_input_port XOA (scheme_get_thread_local_variables()->dummy_input_port_) +#define dummy_output_port XOA (scheme_get_thread_local_variables()->dummy_output_port_) /*KPLAKE2*/ /* **************************************** */ diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 1f3bdced94..8bfe025c08 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -143,8 +143,7 @@ int scheme_is_module_begin_env(Scheme_Comp_Env *env); Scheme_Env *scheme_engine_instance_init(); Scheme_Env *scheme_place_instance_init(); -static void place_instance_init_pre_kernel(); -static Scheme_Env *place_instance_init_post_kernel(int initial_main_os_thread); +static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thread); #ifdef MZ_PRECISE_GC static void register_traversers(void); @@ -358,6 +357,7 @@ Scheme_Env *scheme_engine_instance_init() { #ifdef MZ_USE_JIT scheme_init_jit(); #endif + make_kernel_env(); #if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) scheme_places_block_child_signal(); @@ -366,14 +366,11 @@ Scheme_Env *scheme_engine_instance_init() { scheme_spawn_master_place(); #endif - place_instance_init_pre_kernel(stack_base); - make_kernel_env(); - scheme_init_parameterization_readonly_globals(); - env = place_instance_init_post_kernel(1); + env = place_instance_init(stack_base, 1); #if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) { - int *signal_fd; + void *signal_fd; signal_fd = scheme_get_signal_handle(); GC_set_put_external_event_fd(signal_fd); } @@ -382,37 +379,6 @@ Scheme_Env *scheme_engine_instance_init() { return env; } -static void place_instance_init_pre_kernel(void *stack_base) { - -#ifdef TIME_STARTUP_PROCESS - printf("place_init @ %ld\n", scheme_get_process_milliseconds()); -#endif - scheme_set_current_os_thread_stack_base(stack_base); - -#ifndef MZ_PRECISE_GC - scheme_init_setjumpup(); -#endif - - scheme_init_stack_check(); - scheme_init_overflow(); - - init_toplevel_local_offsets_hashtable_caches(); - - -#ifdef TIME_STARTUP_PROCESS - printf("pre-process @ %ld\n", scheme_get_process_milliseconds()); -#endif - - scheme_make_thread(stack_base); - - scheme_init_module_resolver(); - -#ifdef TIME_STARTUP_PROCESS - printf("process @ %ld\n", scheme_get_process_milliseconds()); -#endif -} - - static void init_unsafe(Scheme_Env *env) { Scheme_Module_Phase_Exports *pt; @@ -474,8 +440,43 @@ Scheme_Env *scheme_get_flfxnum_env() { return flfxnum_env; } -static Scheme_Env *place_instance_init_post_kernel(int initial_main_os_thread) { + +static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thread) { Scheme_Env *env; + +#ifdef TIME_STARTUP_PROCESS + printf("place_init @ %ld\n", scheme_get_process_milliseconds()); +#endif + scheme_set_current_os_thread_stack_base(stack_base); + +#ifndef MZ_PRECISE_GC + scheme_init_setjumpup(); +#endif + + scheme_init_stack_check(); + scheme_init_overflow(); + + init_toplevel_local_offsets_hashtable_caches(); + + +#ifdef TIME_STARTUP_PROCESS + printf("pre-process @ %ld\n", scheme_get_process_milliseconds()); +#endif + + scheme_make_thread(stack_base); + + { + Scheme_Object *sym; + sym = scheme_intern_symbol("mzscheme"); + scheme_current_thread->name = sym; + } + + scheme_init_module_resolver(); + +#ifdef TIME_STARTUP_PROCESS + printf("process @ %ld\n", scheme_get_process_milliseconds()); +#endif + /* error handling and buffers */ /* this check prevents initializing orig ports twice for the first initial * place. The kernel initializes orig_ports early. */ @@ -505,6 +506,7 @@ static Scheme_Env *place_instance_init_post_kernel(int initial_main_os_thread) { #ifndef NO_SCHEME_EXNS scheme_init_exn_config(); #endif + scheme_init_error_config(); scheme_init_memtrace(env); #ifndef NO_TCP_SUPPORT @@ -548,8 +550,7 @@ Scheme_Env *scheme_place_instance_init(void *stack_base) { int *signal_fd; GC_construct_child_gc(); #endif - place_instance_init_pre_kernel(stack_base); - env = place_instance_init_post_kernel(0); + env = place_instance_init(stack_base, 0); #if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) signal_fd = scheme_get_signal_handle(); GC_set_put_external_event_fd(signal_fd); @@ -573,8 +574,6 @@ static void make_kernel_env(void) env = make_empty_inited_env(GLOBAL_TABLE_SIZE); - scheme_set_param(scheme_current_config(), MZCONFIG_ENV, - (Scheme_Object *)env); REGISTER_SO(kernel_env); kernel_env = env; @@ -620,6 +619,7 @@ static void make_kernel_env(void) MZTIMEIT(exn, scheme_init_exn(env)); #endif MZTIMEIT(process, scheme_init_thread(env)); + scheme_init_inspector(); MZTIMEIT(reduced, scheme_init_reduced_proc_struct(env)); #ifndef NO_SCHEME_THREADS MZTIMEIT(sema, scheme_init_sema(env)); @@ -685,12 +685,7 @@ static void make_kernel_env(void) GLOBAL_PRIM_W_ARITY("syntax-local-lift-require", local_lift_require, 2, 2, env); GLOBAL_PRIM_W_ARITY("syntax-local-lift-provide", local_lift_provide, 1, 1, env); - { - Scheme_Object *sym; - sym = scheme_intern_symbol("mzscheme"); - scheme_current_thread->name = sym; - } - + REGISTER_SO(unshadowable_symbol); unshadowable_symbol = scheme_intern_symbol("unshadowable"); diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 108f285679..6f41f371ec 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -618,8 +618,6 @@ void scheme_init_error(Scheme_Env *env) } scheme_add_global_constant("prop:arity-string", arity_property, env); - - scheme_init_error_config(); } void scheme_init_logger() @@ -3504,8 +3502,6 @@ void scheme_init_exn(Scheme_Env *env) "raise", 1, 2), env); - - scheme_init_exn_config(); } void scheme_init_exn_config(void) diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index 64bc06922f..ef9801c5b5 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -3639,16 +3639,16 @@ static int is_arity(Scheme_Object *a, int at_least_ok, int list_ok) void scheme_init_reduced_proc_struct(Scheme_Env *env) { if (!scheme_reduced_procedure_struct) { - Scheme_Object *pr; + Scheme_Inspector *insp; REGISTER_SO(scheme_reduced_procedure_struct); - pr = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR); - while (((Scheme_Inspector *)pr)->superior->superior) { - pr = (Scheme_Object *)((Scheme_Inspector *)pr)->superior; + insp = (Scheme_Inspector *) scheme_get_current_inspector(); + while (insp->superior->superior) { + insp = insp->superior; } scheme_reduced_procedure_struct = scheme_make_proc_struct_type(NULL, NULL, - pr, + (Scheme_Object *)insp, 3, 0, scheme_false, scheme_make_integer(0), diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index ff52949ee2..def9089fcd 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -425,21 +425,21 @@ void scheme_finish_kernel(Scheme_Env *env) /* When this function is called, the initial namespace has all the primitive bindings for syntax and procedures. This function fills in the module wrapper for #%kernel. */ - Scheme_Bucket_Table *ht; - int i, j, count, syntax_start = 0; - Scheme_Bucket **bs; - Scheme_Object **exs, *w, *rn; - Scheme_Object *insp; + Scheme_Object *w; REGISTER_SO(kernel); kernel = MALLOC_ONE_TAGGED(Scheme_Module); kernel->so.type = scheme_module_type; - - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - env->module = kernel; - env->insp = insp; + + { + Scheme_Object *insp; + insp = scheme_get_current_inspector(); + + env->insp = insp; + kernel->insp = insp; + } kernel->modname = kernel_modname; kernel->requires = scheme_null; @@ -448,69 +448,76 @@ void scheme_finish_kernel(Scheme_Env *env) kernel->dt_requires = scheme_null; kernel->other_requires = NULL; - kernel->insp = insp; - /* Provide all syntax and variables: */ - count = 0; - for (j = 0; j < 2; j++) { - if (!j) - ht = env->toplevel; - else { - ht = env->syntax; - syntax_start = count; - } - - bs = ht->buckets; - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) - count++; - } - } - - exs = MALLOC_N(Scheme_Object *, count); - count = 0; - for (j = 0; j < 2; j++) { - if (!j) - ht = env->toplevel; - else - ht = env->syntax; - - bs = ht->buckets; - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) - exs[count++] = (Scheme_Object *)b->key; - } - } - - kernel->no_cert = 1; - { - Scheme_Module_Exports *me; - me = make_module_exports(); - kernel->me = me; + Scheme_Bucket_Table *ht; + int i, j, count, syntax_start = 0; + Scheme_Bucket **bs; + Scheme_Object **exs; + Scheme_Object *rn; + /* Provide all syntax and variables: */ + count = 0; + for (j = 0; j < 2; j++) { + if (!j) + ht = env->toplevel; + else { + ht = env->syntax; + syntax_start = count; + } + + bs = ht->buckets; + for (i = ht->size; i--; ) { + Scheme_Bucket *b = bs[i]; + if (b && b->val) + count++; + } + } + + exs = MALLOC_N(Scheme_Object *, count); + count = 0; + for (j = 0; j < 2; j++) { + if (!j) + ht = env->toplevel; + else + ht = env->syntax; + + bs = ht->buckets; + for (i = ht->size; i--; ) { + Scheme_Bucket *b = bs[i]; + if (b && b->val) + exs[count++] = (Scheme_Object *)b->key; + } + } + + kernel->no_cert = 1; + + { + Scheme_Module_Exports *me; + me = make_module_exports(); + kernel->me = me; + } + + kernel->me->rt->provides = exs; + kernel->me->rt->provide_srcs = NULL; + kernel->me->rt->provide_src_names = exs; + kernel->me->rt->num_provides = count; + kernel->me->rt->num_var_provides = syntax_start; + scheme_populate_pt_ht(kernel->me->rt); + + env->running = 1; + env->et_running = 1; + env->attached = 1; + + /* Since this is the first module rename, it's registered as + the kernel module rename: */ + rn = scheme_make_module_rename(scheme_make_integer(0), mzMOD_RENAME_NORMAL, NULL); + for (i = kernel->me->rt->num_provides; i--; ) { + scheme_extend_module_rename(rn, kernel_modidx, exs[i], exs[i], kernel_modidx, exs[i], + 0, scheme_make_integer(0), NULL, NULL, 0); + } + scheme_seal_module_rename(rn, STX_SEAL_ALL); } - kernel->me->rt->provides = exs; - kernel->me->rt->provide_srcs = NULL; - kernel->me->rt->provide_src_names = exs; - kernel->me->rt->num_provides = count; - kernel->me->rt->num_var_provides = syntax_start; - - env->running = 1; - env->et_running = 1; - env->attached = 1; - - /* Since this is the first module rename, it's registered as - the kernel module rename: */ - rn = scheme_make_module_rename(scheme_make_integer(0), mzMOD_RENAME_NORMAL, NULL); - for (i = kernel->me->rt->num_provides; i--; ) { - scheme_extend_module_rename(rn, kernel_modidx, exs[i], exs[i], kernel_modidx, exs[i], - 0, scheme_make_integer(0), NULL, NULL, 0); - } - scheme_seal_module_rename(rn, STX_SEAL_ALL); - REGISTER_SO(scheme_sys_wraps0); REGISTER_SO(scheme_sys_wraps1); @@ -4488,14 +4495,20 @@ Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env) env = scheme_new_module_env(for_env, m, 0); - config = scheme_current_config(); - prefix = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_NAME); - if (SCHEME_MODNAMEP(prefix)) - name = prefix; - else + if (!scheme_defining_primitives) { + config = scheme_current_config(); + prefix = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_NAME); + if (SCHEME_MODNAMEP(prefix)) + name = prefix; + else + name = scheme_intern_resolved_module_path(name); + insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR); + } + else { name = scheme_intern_resolved_module_path(name); - insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR); + insp = scheme_get_current_inspector(); + } m->modname = name; m->requires = scheme_null; diff --git a/src/mzscheme/src/portfun.c b/src/mzscheme/src/portfun.c index 0bf467e847..19b3d81d90 100644 --- a/src/mzscheme/src/portfun.c +++ b/src/mzscheme/src/portfun.c @@ -157,8 +157,8 @@ READ_ONLY Scheme_Object *scheme_write_proc; READ_ONLY Scheme_Object *scheme_display_proc; READ_ONLY Scheme_Object *scheme_print_proc; -READ_ONLY static Scheme_Object *dummy_input_port; -READ_ONLY static Scheme_Object *dummy_output_port; +THREAD_LOCAL_DECL(static Scheme_Object *dummy_input_port); +THREAD_LOCAL_DECL(static Scheme_Object *dummy_output_port); #define fail_err_symbol scheme_false @@ -209,14 +209,6 @@ scheme_init_port_fun(Scheme_Env *env) default_write_handler = scheme_make_prim_w_arity(sch_default_write_handler, "default-port-write-handler", 2, 2); default_print_handler = scheme_make_prim_w_arity(sch_default_print_handler, "default-port-print-handler", 2, 2); - /* Use dummy port: */ - REGISTER_SO(dummy_input_port); - REGISTER_SO(dummy_output_port); - dummy_input_port = scheme_make_byte_string_input_port(""); - dummy_output_port = scheme_make_null_output_port(1); - - scheme_init_port_fun_config(); - scheme_add_global_constant("eof", scheme_eof, env); GLOBAL_PARAMETER("current-input-port", current_input_port, MZCONFIG_INPUT_PORT, env); @@ -352,6 +344,12 @@ void scheme_init_port_fun_config(void) scheme_default_global_print_handler = scheme_make_prim_w_arity(sch_default_global_port_print_handler, "default-global-port-print-handler", 2, 2); scheme_set_root_param(MZCONFIG_PORT_PRINT_HANDLER, scheme_default_global_print_handler); + + /* Use dummy port: */ + REGISTER_SO(dummy_input_port); + REGISTER_SO(dummy_output_port); + dummy_input_port = scheme_make_byte_string_input_port(""); + dummy_output_port = scheme_make_null_output_port(1); } /*========================================================================*/ diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c index 12c8247c73..0994a20ba8 100644 --- a/src/mzscheme/src/salloc.c +++ b/src/mzscheme/src/salloc.c @@ -975,69 +975,69 @@ void scheme_free_code(void *p) /* it was a large object on its own page(s) */ scheme_code_page_total -= size; LOG_CODE_MALLOC(1, printf("freeing large %p (%ld) [%ld left]\n", - p, size, scheme_code_page_total)); + p, size, scheme_code_page_total)); free_page((char *)p - CODE_HEADER_SIZE, size); - return; } + else { + bucket = size; - bucket = size; - - if ((bucket < 0) || (bucket >= free_list_bucket_count)) { - printf("bad free: %p\n", (char *)p + CODE_HEADER_SIZE); - abort(); - } - - size2 = free_list[bucket].size; - - LOG_CODE_MALLOC(0, printf("freeing %ld / %ld\n", size2, bucket)); - - /* decrement alloc count for this page: */ - per_page = (page_size - CODE_HEADER_SIZE) / size2; - n = ((long *)CODE_PAGE_OF(p))[1]; - /* double-check: */ - if ((n < 1) || (n > per_page)) { - printf("bad free: %p\n", (char *)p + CODE_HEADER_SIZE); - abort(); - } - n--; - ((long *)CODE_PAGE_OF(p))[1] = n; - - /* add to free list: */ - prev = free_list[bucket].elems; - ((void **)p)[0] = prev; - ((void **)p)[1] = NULL; - if (prev) - ((void **)prev)[1] = p; - free_list[bucket].elems = p; - free_list[bucket].count++; - - /* Free whole page if it's completely on the free list, and if there - are enough buckets on other pages. */ - if ((n == 0) && ((free_list[bucket].count - per_page) >= (per_page / 2))) { - /* remove same-page elements from free list, then free page */ - int i; - long sz; - void *pg; - - sz = page_size - size2; - pg = CODE_PAGE_OF(p); - for (i = CODE_HEADER_SIZE; i <= sz; i += size2) { - p = ((char *)pg) + i; - prev = ((void **)p)[1]; - if (prev) - ((void **)prev)[0] = ((void **)p)[0]; - else - free_list[bucket].elems = ((void **)p)[0]; - prev = ((void **)p)[0]; - if (prev) - ((void **)prev)[1] = ((void **)p)[1]; - --free_list[bucket].count; + if ((bucket < 0) || (bucket >= free_list_bucket_count)) { + printf("bad free: %p\n", (char *)p + CODE_HEADER_SIZE); + abort(); + } + + size2 = free_list[bucket].size; + + LOG_CODE_MALLOC(0, printf("freeing %ld / %ld\n", size2, bucket)); + + /* decrement alloc count for this page: */ + per_page = (page_size - CODE_HEADER_SIZE) / size2; + n = ((long *)CODE_PAGE_OF(p))[1]; + /* double-check: */ + if ((n < 1) || (n > per_page)) { + printf("bad free: %p\n", (char *)p + CODE_HEADER_SIZE); + abort(); + } + n--; + ((long *)CODE_PAGE_OF(p))[1] = n; + + /* add to free list: */ + prev = free_list[bucket].elems; + ((void **)p)[0] = prev; + ((void **)p)[1] = NULL; + if (prev) + ((void **)prev)[1] = p; + free_list[bucket].elems = p; + free_list[bucket].count++; + + /* Free whole page if it's completely on the free list, and if there + are enough buckets on other pages. */ + if ((n == 0) && ((free_list[bucket].count - per_page) >= (per_page / 2))) { + /* remove same-page elements from free list, then free page */ + int i; + long sz; + void *pg; + + sz = page_size - size2; + pg = CODE_PAGE_OF(p); + for (i = CODE_HEADER_SIZE; i <= sz; i += size2) { + p = ((char *)pg) + i; + prev = ((void **)p)[1]; + if (prev) + ((void **)prev)[0] = ((void **)p)[0]; + else + free_list[bucket].elems = ((void **)p)[0]; + prev = ((void **)p)[0]; + if (prev) + ((void **)prev)[1] = ((void **)p)[1]; + --free_list[bucket].count; + } + + scheme_code_page_total -= page_size; + LOG_CODE_MALLOC(2, printf("freeing page at %p [%ld left]\n", + CODE_PAGE_OF(p), scheme_code_page_total)); + free_page(CODE_PAGE_OF(p), page_size); } - - scheme_code_page_total -= page_size; - LOG_CODE_MALLOC(2, printf("freeing page at %p [%ld left]\n", - CODE_PAGE_OF(p), scheme_code_page_total)); - free_page(CODE_PAGE_OF(p), page_size); } # ifdef MZ_USE_PLACES mzrt_mutex_unlock(free_list_mutex); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 4f875eddf8..bbcc046f43 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -238,9 +238,9 @@ void scheme_init_salloc(void); void scheme_init_jit(void); #endif void scheme_init_memtrace(Scheme_Env *env); -void scheme_init_parameterization_readonly_globals(); void scheme_init_parameterization(Scheme_Env *env); void scheme_init_getenv(void); +void scheme_init_inspector(void); #ifndef DONT_USE_FOREIGN void scheme_init_foreign_globals(); @@ -263,6 +263,7 @@ void scheme_init_print_global_constants(void); void scheme_init_variable_references_constants(void); void scheme_init_logger(void); void scheme_init_file_places(void); + Scheme_Logger *scheme_get_main_logger(void); void scheme_init_logger_config(void); @@ -297,6 +298,7 @@ void scheme_init_module_resolver(void); void scheme_finish_kernel(Scheme_Env *env); Scheme_Object *scheme_make_initial_inspectors(void); +Scheme_Object *scheme_get_current_inspector(void); extern int scheme_builtin_ref_counter; @@ -2825,7 +2827,10 @@ typedef struct Scheme_Module_Exports MZTAG_IF_REQUIRED /* Most common phases: */ - Scheme_Module_Phase_Exports *rt, *et, *dt; + Scheme_Module_Phase_Exports *rt; /* run time? phase 0*/ + Scheme_Module_Phase_Exports *et; /* expansion time? phase 1 */ + Scheme_Module_Phase_Exports *dt; /* */ + /* All others: */ Scheme_Hash_Table *other_phases; diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 2655e086d0..876102c473 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -79,6 +79,8 @@ static Scheme_Object *current_inspector(int argc, Scheme_Object *argv[]); static Scheme_Object *current_code_inspector(int argc, Scheme_Object *argv[]); static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[]); +static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *argv[], + Scheme_Object **predout, Scheme_Object **accessout ); static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[]); static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *argv[]); @@ -264,10 +266,7 @@ scheme_init_struct (Scheme_Env *env) a[0] = scheme_intern_symbol("custom-write"); a[1] = guard; - make_struct_type_property(2, a); - write_property = scheme_current_thread->ku.multiple.array[0]; - pred = scheme_current_thread->ku.multiple.array[1]; - access = scheme_current_thread->ku.multiple.array[2]; + write_property = make_struct_type_property_from_c(2, a, &pred, &access); scheme_add_global_constant("prop:custom-write", write_property, env); scheme_add_global_constant("custom-write?", pred, env); scheme_add_global_constant("custom-write-accessor", access, env); @@ -796,10 +795,11 @@ static Scheme_Object *prop_accessor(int argc, Scheme_Object **args, Scheme_Objec return v; } -static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[]) -{ +static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *argv[], + Scheme_Object **predout, Scheme_Object **accessout ) { + Scheme_Struct_Property *p; - Scheme_Object *a[3], *v, *supers = scheme_null; + Scheme_Object *a[1], *v, *supers = scheme_null; char *name; int len; @@ -853,35 +853,35 @@ static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[]) name[len] = '?'; name[len+1] = 0; - v = scheme_make_folding_prim_closure(prop_pred, - 1, a, - name, - 1, 1, 0); - a[1] = v; + v = scheme_make_folding_prim_closure(prop_pred, 1, a, name, 1, 1, 0); + *predout = v; name = MALLOC_N_ATOMIC(char, len + 10); memcpy(name, SCHEME_SYM_VAL(argv[0]), len); memcpy(name + len, "-accessor", 10); - v = scheme_make_folding_prim_closure(prop_accessor, - 1, a, - name, - 1, 1, 0); - a[2] = v; + v = scheme_make_folding_prim_closure(prop_accessor, 1, a, name, 1, 1, 0); + *accessout = v; + return a[0]; +} + +static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *a[3]; + a[0] = make_struct_type_property_from_c(argc, argv, &a[1], &a[2]); return scheme_values(3, a); } Scheme_Object *scheme_make_struct_type_property_w_guard(Scheme_Object *name, Scheme_Object *guard) { - Scheme_Thread *p = scheme_current_thread; Scheme_Object *a[2]; + Scheme_Object *pred = NULL; + Scheme_Object *access = NULL; a[0] = name; a[1] = guard; - - (void)make_struct_type_property(2, a); - return p->ku.multiple.array[0]; + return make_struct_type_property_from_c(2, a, &pred, &access); } Scheme_Object *scheme_make_struct_type_property(Scheme_Object *name) @@ -963,17 +963,21 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche } else { /* Normal guard handling: */ if (p->guard) { - Scheme_Object *a[2], *info[mzNUM_ST_INFO], *l; + if(!scheme_defining_primitives) { + Scheme_Object *a[2], *info[mzNUM_ST_INFO], *l; - a[0] = (Scheme_Object *)t; - get_struct_type_info(1, a, info, 1); + a[0] = (Scheme_Object *)t; + get_struct_type_info(1, a, info, 1); - l = scheme_build_list(mzNUM_ST_INFO, info); + l = scheme_build_list(mzNUM_ST_INFO, info); - a[0] = v; - a[1] = l; - - return _scheme_apply(p->guard, 2, a); + a[0] = v; + a[1] = l; + + return _scheme_apply(p->guard, 2, a); + } + else + return v; } else return v; } @@ -1866,7 +1870,7 @@ static Scheme_Object *check_type_and_inspector(const char *who, int always, int stype = (Scheme_Struct_Type *)argv[0]; - insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR); + insp = scheme_get_current_inspector(); if (!always && !scheme_is_subinspector(stype->inspector, insp)) { scheme_arg_mismatch(who, diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 4cd742a66e..cb9b9a78ac 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -174,7 +174,7 @@ THREAD_LOCAL_DECL(MZ_MARK_POS_TYPE scheme_current_cont_mark_pos); THREAD_LOCAL_DECL(static Scheme_Custodian *main_custodian); THREAD_LOCAL_DECL(static Scheme_Custodian *last_custodian); THREAD_LOCAL_DECL(static Scheme_Hash_Table *limited_custodians = NULL); -THREAD_LOCAL_DECL(static Scheme_Object *initial_inspector); +READ_ONLY static Scheme_Object *initial_inspector; #ifndef MZ_PRECISE_GC static int cust_box_count, cust_box_alloc; @@ -434,6 +434,10 @@ unsigned long scheme_get_current_thread_stack_start(void); void scheme_init_thread(Scheme_Env *env) { +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif + REGISTER_SO(read_symbol); REGISTER_SO(write_symbol); REGISTER_SO(execute_symbol); @@ -803,6 +807,8 @@ void scheme_init_thread(Scheme_Env *env) void scheme_init_thread_places(void) { buffer_init_size = INIT_TB_SIZE; + REGISTER_SO(recycle_cell); + REGISTER_SO(maybe_recycle_cell); } void scheme_init_memtrace(Scheme_Env *env) @@ -824,14 +830,24 @@ void scheme_init_memtrace(Scheme_Env *env) scheme_finish_primitive_module(newenv); } -void scheme_init_parameterization_readonly_globals() +void scheme_init_inspector() { + REGISTER_SO(initial_inspector); + initial_inspector = 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. */ +} + +Scheme_Object *scheme_get_current_inspector() + XFORM_SKIP_PROC { - REGISTER_SO(scheme_exn_handler_key); - REGISTER_SO(scheme_parameterization_key); - REGISTER_SO(scheme_break_enabled_key); - scheme_exn_handler_key = scheme_make_symbol("exnh"); - scheme_parameterization_key = scheme_make_symbol("paramz"); - scheme_break_enabled_key = scheme_make_symbol("break-on?"); + if (scheme_defining_primitives) + return initial_inspector; + + Scheme_Config *c; + c = scheme_current_config(); + return scheme_get_param(c, MZCONFIG_INSPECTOR); } void scheme_init_parameterization(Scheme_Env *env) @@ -839,8 +855,12 @@ void scheme_init_parameterization(Scheme_Env *env) Scheme_Object *v; Scheme_Env *newenv; - REGISTER_SO(recycle_cell); - REGISTER_SO(maybe_recycle_cell); + REGISTER_SO(scheme_exn_handler_key); + REGISTER_SO(scheme_parameterization_key); + REGISTER_SO(scheme_break_enabled_key); + scheme_exn_handler_key = scheme_make_symbol("exnh"); + scheme_parameterization_key = scheme_make_symbol("paramz"); + scheme_break_enabled_key = scheme_make_symbol("break-on?"); v = scheme_intern_symbol("#%paramz"); newenv = scheme_primitive_module(v, env); @@ -2164,9 +2184,6 @@ static Scheme_Thread *make_thread(Scheme_Config *config, if (!scheme_main_thread) { /* Creating the first thread... */ -#ifdef MZ_PRECISE_GC - register_traversers(); -#endif REGISTER_SO(scheme_current_thread); REGISTER_SO(scheme_main_thread); REGISTER_SO(scheme_first_thread); @@ -3629,6 +3646,8 @@ void scheme_wake_up(void) void scheme_out_of_fuel(void) { + if (scheme_defining_primitives) return; + scheme_thread_block((float)0); scheme_current_thread->ran_some = 1; } @@ -6690,18 +6709,7 @@ static void make_initial_config(Scheme_Thread *p) } { - Scheme_Object *ins; - 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; - } + Scheme_Object *ins = initial_inspector; init_param(cells, paramz, MZCONFIG_INSPECTOR, ins); init_param(cells, paramz, MZCONFIG_CODE_INSPECTOR, ins); }