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

Move kernel to master

Browse Source 
svn: r17623
This commit is contained in:
Kevin Tew 2010-01-12 23:53:01 +00:00
parent a1d7945958
commit 4977211ee7
12 changed files with 295 additions and 274 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/mzscheme/gc2/mem_account.c
View File

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

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

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

6
src/mzscheme/include/schthread.h
View File

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

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

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

4
src/mzscheme/src/error.c
View File

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

10
src/mzscheme/src/fun.c
View File

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

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

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

18
src/mzscheme/src/portfun.c
View File

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

118
src/mzscheme/src/salloc.c
View File

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

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

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

64
src/mzscheme/src/struct.c
View File

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

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

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