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

optimizer tweaks, minor gc accounting corrections

Browse Source 
svn: r5792
This commit is contained in:
Matthew Flatt 2007-03-19 22:04:34 +00:00
parent ec5ba4f2c1
commit 3abc1bdfa4
15 changed files with 265 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/mzscheme/gc2/Makefile.in
View File

@ -292,7 +292,7 @@ gc2.@LTO@: $(srcdir)/gc2.c $(srcdir)/newgc.c $(srcdir)/compact.c $(srcdir)/newgc
$(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/vm.c\
$(srcdir)/vm_memalign.c $(srcdir)/alloc_cache.c \
$(srcdir)/page_range.c $(srcdir)/protect_range.c $(srcdir)/var_stack.c $(srcdir)/stack_comp.c \
$(srcdir)/../utils/splay.c $(srcdir)/my_qsort.c \
$(srcdir)/../utils/splay.c $(srcdir)/my_qsort.c $(srcdir)/backtrace.c \
$(srcdir)/weak.c $(srcdir)/fnls.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h
$(CC) $(CFLAGS) -c $(srcdir)/gc2.c -o gc2.@LTO@

1
src/mzscheme/gc2/backtrace.c
View File

@ -50,6 +50,7 @@ static void *print_out_pointer(const char *prefix, void *p,
GCPRINT(GCOUTF, "%s??? %p\n", prefix, p);
return NULL;
}
p = trace_pointer_start(page, p);
if (trace_page_type(page) == TRACE_PAGE_TAGGED) {
Type_Tag tag;

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

@ -2690,9 +2690,9 @@ static int record_stack_source = 0;
#define GC_X_variable_stack GC_mark_variable_stack
#if RECORD_MARK_SRC
# define X_source(p) if (record_stack_source) { mark_src = p; mark_type = MTYPE_STACK; }
# define X_source(stk, p) if (record_stack_source) { mark_src = (stk ? stk : p); mark_type = MTYPE_STACK; }
#else
# define X_source(p) /* */
# define X_source(stk, p) /* */
#endif
#define gcX(a) gcMARK(*a)
#include "var_stack.c"
@ -2702,7 +2702,7 @@ static int record_stack_source = 0;
#define GC_X_variable_stack GC_fixup_variable_stack
#define gcX(a) gcFIXUP(*a)
#define X_source(p) /* */
#define X_source(stk, p) /* */
#include "var_stack.c"
#undef GC_X_variable_stack
#undef gcX
@ -2748,7 +2748,7 @@ static void check_ptr(void **a)
#define GC_X_variable_stack GC_do_check_variable_stack
#define gcX(a) check_ptr(a)
#define X_source(p) /* */
#define X_source(stk, p) /* */
#include "var_stack.c"
#undef GC_X_variable_stack
#undef gcX
@ -2763,7 +2763,8 @@ void GC_check_variable_stack()
0,
(void **)(GC_get_thread_stack_base
? GC_get_thread_stack_base()
: stack_base));
: stack_base),
NULL);
# endif
}
#endif
@ -2863,7 +2864,8 @@ static void do_roots(int fixup)
0,
(void *)(GC_get_thread_stack_base
? GC_get_thread_stack_base()
: stack_base));
: stack_base),
NULL);
else {
#if RECORD_MARK_SRC
record_stack_source = 1;
@ -2872,7 +2874,8 @@ static void do_roots(int fixup)
0,
(void *)(GC_get_thread_stack_base
? GC_get_thread_stack_base()
: stack_base));
: stack_base),
NULL);
#if RECORD_MARK_SRC
record_stack_source = 0;
#endif
@ -4223,6 +4226,12 @@ static void *trace_backpointer(MPage *page, void *p)
# define trace_page_t MPage
# define trace_page_type(page) (page)->type
static void *trace_pointer_start(struct mpage *page, void *p) {
if (page->flags & MFLAG_BIGBLOCK)
return page->block_start;
else
return p;
}
# define TRACE_PAGE_TAGGED MTYPE_TAGGED
# define TRACE_PAGE_ARRAY MTYPE_ARRAY
# define TRACE_PAGE_TAGGED_ARRAY MTYPE_TAGGED_ARRAY

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

@ -314,10 +314,12 @@ GC2_EXTERN void GC_fixup(void *p);
GC2_EXTERN void GC_mark_variable_stack(void **var_stack,
long delta,
void *limit);
void *limit,
void *stack_mem);
GC2_EXTERN void GC_fixup_variable_stack(void **var_stack,
long delta,
void *limit);
void *limit,
void *stack_mem);
/*
Can be called by a mark or fixup traversal proc to traverse and
update a chunk of (atomically-allocated) memory containing an image
@ -331,7 +333,10 @@ GC2_EXTERN void GC_fixup_variable_stack(void **var_stack,
stack_address is the numerically lower bound for the copied stack
region, regardless of which direction the stack grows). The `limit'
argument corresponds to the value that would have been returned by
GC_get_thread_stack_base() at the time the stack was copied. */
GC_get_thread_stack_base() at the time the stack was copied.
The `stack_mem' argument indicates the start of the allocated memory
that contains `var_stack'. It is used for backtraces. */
# ifdef __cplusplus
};

8
src/mzscheme/gc2/gc2_dump.h
View File

@ -20,6 +20,14 @@ GC2_EXTERN void GC_dump_with_traces(int flags,
GC_print_tagged_value_proc print_tagged_value,
int path_length_limit);
GC2_EXTERN void GC_dump_variable_stack(void **var_stack,
long delta,
void *limit,
void *stack_mem,
GC_get_type_name_proc get_type_name,
GC_get_xtagged_name_proc get_xtagged_name,
GC_print_tagged_value_proc print_tagged_value);
# define GC_DUMP_SHOW_DETAILS 0x1
# define GC_DUMP_SHOW_TRACE 0x2
# define GC_DUMP_SHOW_FINALS 0x4

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

@ -888,7 +888,7 @@ unsigned long GC_get_stack_base()
#define GC_X_variable_stack GC_mark_variable_stack
#define gcX(a) gcMARK(*a)
#define X_source(p) set_backtrace_source(p, BT_STACK)
#define X_source(stk, p) set_backtrace_source((stk ? stk : p), BT_STACK)
#include "var_stack.c"
#undef GC_X_variable_stack
#undef gcX
@ -896,7 +896,7 @@ unsigned long GC_get_stack_base()
#define GC_X_variable_stack GC_fixup_variable_stack
#define gcX(a) gcFIXUP(*a)
#define X_source(p) /* */
#define X_source(stk, p) /* */
#include "var_stack.c"
#undef GC_X_variable_stack
#undef gcX
@ -1219,7 +1219,7 @@ inline static void mark_threads(int owner)
if (((Scheme_Thread *)work->thread)->running) {
normal_thread_mark(work->thread);
if (work->thread == scheme_current_thread) {
GC_mark_variable_stack(GC_variable_stack, 0, gc_stack_base);
GC_mark_variable_stack(GC_variable_stack, 0, gc_stack_base, NULL);
}
}
}
@ -1977,6 +1977,8 @@ long GC_get_memory_use(void *o)
one that we export out, and it does a metric crapload of work. The second
we use internally, and it doesn't do nearly as much. */
void *watch_for; /* REMOVEME */
/* This is the first mark routine. It's a bit complicated. */
void GC_mark(const void *const_p)
{
@ -1987,6 +1989,10 @@ void GC_mark(const void *const_p)
GCDEBUG((DEBUGOUTF, "Not marking %p (bad ptr)\n", p));
return;
}
if (watch_for && (p == watch_for)) {
GCPRINT(GCOUTF, "Found it\n");
}
if((page = find_page(p))) {
/* toss this over to the BTC mark routine if we're doing accounting */
@ -2243,6 +2249,12 @@ static unsigned long num_major_collects = 0;
#ifdef MZ_GC_BACKTRACE
# define trace_page_t struct mpage
# define trace_page_type(page) (page)->page_type
static void *trace_pointer_start(struct mpage *page, void *p) {
if (page->big_page)
return PTR(NUM(page) + HEADER_SIZEB + WORD_SIZE);
else
return p;
}
# define TRACE_PAGE_TAGGED PAGE_TAGGED
# define TRACE_PAGE_ARRAY PAGE_ARRAY
# define TRACE_PAGE_TAGGED_ARRAY PAGE_TARRAY
@ -2386,7 +2398,7 @@ int GC_is_tagged(void *p)
int GC_is_tagged_start(void *p)
{
return 0;
return 1; /* REMOVEME */
}
void *GC_next_tagged_start(void *p)
@ -2849,7 +2861,7 @@ static void garbage_collect(int force_full)
mark_roots();
mark_immobiles();
TIME_STEP("rooted");
GC_mark_variable_stack(GC_variable_stack, 0, gc_stack_base);
GC_mark_variable_stack(GC_variable_stack, 0, gc_stack_base, NULL);
TIME_STEP("stacked");
@ -2897,7 +2909,7 @@ static void garbage_collect(int force_full)
repair_weak_finalizer_structs();
repair_roots();
repair_immobiles();
GC_fixup_variable_stack(GC_variable_stack, 0, gc_stack_base);
GC_fixup_variable_stack(GC_variable_stack, 0, gc_stack_base, NULL);
TIME_STEP("reparied roots");
repair_heap();
TIME_STEP("repaired");
@ -2968,5 +2980,38 @@ static void garbage_collect(int force_full)
DUMP_HEAP(); CLOSE_DEBUG_FILE();
}
#if MZ_GC_BACKTRACE
static GC_get_type_name_proc stack_get_type_name;
static GC_get_xtagged_name_proc stack_get_xtagged_name;
static GC_print_tagged_value_proc stack_print_tagged_value;
static void dump_stack_pos(void *a)
{
GCPRINT(GCOUTF, " @%p: ", a);
print_out_pointer("", *(void **)a, stack_get_type_name, stack_get_xtagged_name, stack_print_tagged_value);
}
# define GC_X_variable_stack GC_do_dump_variable_stack
# define gcX(a) dump_stack_pos(a)
# define X_source(stk, p) /* */
# include "var_stack.c"
# undef GC_X_variable_stack
# undef gcX
# undef X_source
void GC_dump_variable_stack(void **var_stack,
long delta,
void *limit,
void *stack_mem,
GC_get_type_name_proc get_type_name,
GC_get_xtagged_name_proc get_xtagged_name,
GC_print_tagged_value_proc print_tagged_value)
{
stack_get_type_name = get_type_name;
stack_get_xtagged_name = get_xtagged_name;
stack_print_tagged_value = print_tagged_value;
GC_do_dump_variable_stack(var_stack, delta, limit, stack_mem);
}
#endif

10
src/mzscheme/gc2/var_stack.c
View File

@ -1,5 +1,5 @@
void GC_X_variable_stack(void **var_stack, long delta, void *limit)
void GC_X_variable_stack(void **var_stack, long delta, void *limit, void *stack_mem)
{
long size, count;
void ***p, **a;
@ -35,7 +35,7 @@ void GC_X_variable_stack(void **var_stack, long delta, void *limit)
a = (void **)((char *)a + delta);
if (SHALLOWER_STACK_ADDRESS(a, limit)) {
while (count--) {
X_source(a);
X_source(stack_mem, a);
gcX(a);
a++;
}
@ -43,7 +43,7 @@ void GC_X_variable_stack(void **var_stack, long delta, void *limit)
} else {
a = (void **)((char *)a + delta);
if (SHALLOWER_STACK_ADDRESS(a, limit)) {
X_source(a);
X_source(stack_mem, a);
gcX(a);
}
}
@ -63,13 +63,13 @@ void GC_X_variable_stack(void **var_stack, long delta, void *limit)
size -= 2;
a = (void **)((char *)a + delta);
while (count--) {
X_source(a);
X_source(stack_mem, a);
gcX(a);
a++;
}
} else {
a = (void **)((char *)a + delta);
X_source(a);
X_source(stack_mem, a);
gcX(a);
}
p++;

30
src/mzscheme/src/eval.c
View File

@ -833,8 +833,32 @@ int scheme_omittable_expr(Scheme_Object *o, int vals)
}
if ((vtype == scheme_application_type)) {
/* Look for multiple values */
/* Look for multiple values, or for `make-struct-type'.
(The latter is especially useful to Honu.) */
Scheme_App_Rec *app = (Scheme_App_Rec *)o;
if (((vals == 5) || (vals < 0))
&& (app->num_args >= 4) && (app->num_args <= 10)
&& SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) {
/* Look for (make-struct-type sym #f non-neg-int non-neg-int [omitable null]) */
if (SCHEME_SYMBOLP(app->args[1])
&& SCHEME_FALSEP(app->args[2])
&& SCHEME_INTP(app->args[3])
&& (SCHEME_INT_VAL(app->args[3]) >= 0)
&& SCHEME_INTP(app->args[4])
&& (SCHEME_INT_VAL(app->args[4]) >= 0)
&& ((app->num_args < 5)
|| scheme_omittable_expr(app->args[5], 1))
&& ((app->num_args < 6)
|| SCHEME_NULLP(app->args[6]))
&& ((app->num_args < 7)
|| SCHEME_FALSEP(app->args[7]))
&& ((app->num_args < 8)
|| SCHEME_FALSEP(app->args[8]))
&& ((app->num_args < 9)
|| SCHEME_NULLP(app->args[9]))) {
return 1;
}
}
if ((app->num_args == vals) || (vals < 0)) {
if (SAME_OBJ(scheme_values_func, app->args[0])) {
int i;
@ -4082,7 +4106,8 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
return form;
}
} else {
scheme_wrong_syntax(NULL, NULL, SCHEME_PTR1_VAL(var), "expanded syntax not in its original context");
scheme_wrong_syntax(NULL, NULL, SCHEME_PTR1_VAL(var),
"expanded syntax not in its original context");
}
}
@ -7116,6 +7141,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
obj = p->ku.apply.tail_rator;
num_rands = p->ku.apply.tail_num_rands;
rands = p->ku.apply.tail_rands;
p->ku.apply.tail_rator = NULL;
p->ku.apply.tail_rands = NULL;
RUNSTACK = old_runstack;
RUNSTACK_CHANGED();

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

@ -1985,7 +1985,9 @@ force_values(Scheme_Object *obj, int multi_ok)
{
if (SAME_OBJ(obj, SCHEME_TAIL_CALL_WAITING)) {
Scheme_Thread *p = scheme_current_thread;
GC_CAN_IGNORE Scheme_Object *rator;
GC_CAN_IGNORE Scheme_Object **rands;
/* Watch out for use of tail buffer: */
if (p->ku.apply.tail_rands == p->tail_buffer) {
GC_CAN_IGNORE Scheme_Object **tb;
@ -1994,14 +1996,20 @@ force_values(Scheme_Object *obj, int multi_ok)
p->tail_buffer = tb;
}
if (multi_ok)
return _scheme_apply_multi(p->ku.apply.tail_rator,
rator = p->ku.apply.tail_rator;
rands = p->ku.apply.tail_rands;
p->ku.apply.tail_rator = NULL;
p->ku.apply.tail_rands = NULL;
if (multi_ok) {
return _scheme_apply_multi(rator,
p->ku.apply.tail_num_rands,
p->ku.apply.tail_rands);
else
return _scheme_apply(p->ku.apply.tail_rator,
rands);
} else {
return _scheme_apply(rator,
p->ku.apply.tail_num_rands,
p->ku.apply.tail_rands);
rands);
}
} else if (SAME_OBJ(obj, SCHEME_EVAL_WAITING)) {
Scheme_Thread *p = scheme_current_thread;
if (multi_ok)

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

@ -1034,7 +1034,7 @@ static void print_tagged_value(const char *prefix,
memcpy(t2 + len, buffer, len2 + 1);
len += len2;
type = t2;
} else if (!scheme_strncmp(type, "#<continuation", 13)) {
} else if (!scheme_strncmp(type, "#<continuation>", 15)) {
char buffer[256];
char *t2;
int len2;
@ -1457,7 +1457,36 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
} else if (SCHEME_INTP(p[0])) {
trace_for_tag = SCHEME_INT_VAL(p[0]);
flags |= GC_DUMP_SHOW_TRACE;
} else if (SCHEME_THREADP(p[0])) {
Scheme_Thread *t = (Scheme_Thread *)p[0];
void **var_stack, *limit;
long delta;
scheme_console_printf("Thread: %p\n", t);
if (t->running) {
if (scheme_current_thread == t) {
scheme_console_printf(" swapped in\n");
var_stack = GC_variable_stack;
delta = 0;
limit = (void *)GC_get_thread_stack_base();
} else {
scheme_console_printf(" swapped out\n");
var_stack = (void **)t->jmpup_buf.gc_var_stack;
delta = (long)t->jmpup_buf.stack_copy - (long)t->jmpup_buf.stack_from;
/* FIXME: stack direction */
limit = (void *)t->jmpup_buf.stack_copy + t->jmpup_buf.stack_size;
}
GC_dump_variable_stack(var_stack, delta, limit, NULL,
scheme_get_type_name,
GC_get_xtagged_name,
print_tagged_value);
} else {
scheme_console_printf(" done\n");
}
scheme_end_atomic();
return scheme_void;
}
if ((c > 1) && SCHEME_INTP(p[1]))
path_length_limit = SCHEME_INT_VAL(p[1]);
else if ((c > 1) && SCHEME_SYMBOLP(p[1]) && !strcmp("cons", SCHEME_SYM_VAL(p[1]))) {
@ -1560,6 +1589,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
scheme_console_printf(" (dump-memory-stats 'peek num v) - returns value if num is address of object, v otherwise.\n");
scheme_console_printf(" (dump-memory-stats 'next v) - next tagged object after v, #f if none; start with #f.\n");
scheme_console_printf(" (dump-memory-stats 'addr v) - returns the address of v.\n");
scheme_console_printf(" (dump-memory-stats thread) - shows information about the thread.\n");
scheme_console_printf("End Help\n");
result = cons_accum_result;

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

@ -237,6 +237,7 @@ void scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym,
extern Scheme_Object *scheme_values_func;
extern Scheme_Object *scheme_void_proc;
extern Scheme_Object *scheme_call_with_values_proc;
extern Scheme_Object *scheme_make_struct_type_proc;
extern Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax;
extern Scheme_Object *scheme_lambda_syntax;

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

@ -27,6 +27,7 @@ Scheme_Object *scheme_arity_at_least, *scheme_date;
Scheme_Object *scheme_make_arity_at_least;
Scheme_Object *scheme_source_property;
Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
Scheme_Object *scheme_make_struct_type_proc;
/* locals */
@ -316,11 +317,14 @@ scheme_init_struct (Scheme_Env *env)
/*** basic interface ****/
REGISTER_SO(scheme_make_struct_type_proc);
scheme_make_struct_type_proc = scheme_make_prim_w_arity2(make_struct_type,
"make-struct-type",
4, 10,
5, 5);
scheme_add_global_constant("make-struct-type",
scheme_make_prim_w_arity2(make_struct_type,
"make-struct-type",
4, 10,
5, 5),
scheme_make_struct_type_proc,
env);
scheme_add_global_constant("make-struct-type-property",

50
src/mzscheme/src/syntax.c
View File

@ -2630,7 +2630,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
Scheme_Let_Header *head = (Scheme_Let_Header *)form;
Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start;
Scheme_Object *body, *value;
int i, j, pos, is_rec, all_simple = 1, skipped = 0;
int i, j, pos, is_rec, all_simple = 1;
int size_before_opt, did_set_value;
/* Special case: (let ([x E]) x) where E is lambda, case-lambda, or
@ -2677,8 +2677,6 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
pos = 0;
for (i = head->num_clauses; i--; ) {
pre_body = (Scheme_Compiled_Let_Value *)body;
if (pre_body->count != 1)
all_simple = 0;
for (j = pre_body->count; j--; ) {
if (pre_body->flags[j] & SCHEME_WAS_SET_BANGED) {
scheme_optimize_mutated(body_info, pos + j);
@ -2817,15 +2815,25 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
body = head->body;
pos = 0;
for (i = head->num_clauses; i--; ) {
int used = 0, j;
pre_body = (Scheme_Compiled_Let_Value *)body;
if (!scheme_optimize_is_used(body_info, pos)
&& scheme_omittable_expr(pre_body->value, 1)) {
skipped++;
if (pre_body->flags[0] & SCHEME_WAS_USED) {
pre_body->flags[0] -= SCHEME_WAS_USED;
}
for (j = pre_body->count; j--; ) {
if (scheme_optimize_is_used(body_info, pos+j)) {
used = 1;
break;
}
}
if (!used
&& scheme_omittable_expr(pre_body->value, pre_body->count)) {
for (j = pre_body->count; j--; ) {
if (pre_body->flags[j] & SCHEME_WAS_USED) {
pre_body->flags[j] -= SCHEME_WAS_USED;
}
}
} else {
pre_body->flags[0] |= SCHEME_WAS_USED;
for (j = pre_body->count; j--; ) {
pre_body->flags[j] |= SCHEME_WAS_USED;
}
}
pos += pre_body->count;
body = pre_body->body;
@ -3152,6 +3160,28 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
info->max_let_depth = max_let_depth;
return first;
} else {
/* Maybe some multi-binding lets, but all of them are unused
and the RHSes are omittable? This can happen with auto-generated
code. */
int total = 0, j;
clv = (Scheme_Compiled_Let_Value *)head->body;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
total += clv->count;
for (j = clv->count; j--; ) {
if (clv->flags[j] & SCHEME_WAS_USED)
break;
}
if (j >= 0)
break;
if (!scheme_omittable_expr(clv->value, clv->count))
break;
}
if (i < 0) {
/* All unused and omittable */
linfo = scheme_resolve_info_extend(info, 0, total, 0);
return scheme_resolve_expr((Scheme_Object *)clv, linfo);
}
}
}

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

@ -23,7 +23,7 @@
Usually, MzScheme threads are implemented by copying the stack.
The scheme_thread_block() function is called occassionally by the
evaluator so that the current thread can be swapped out.
scheme_swap_thread() performs the actual swap. Threads can also be
do_swap_thread() performs the actual swap. Threads can also be
implemented by the OS; the bottom part of this file contains
OS-specific thread code.
@ -175,6 +175,11 @@ MZ_MARK_POS_TYPE scheme_current_cont_mark_pos;
static Scheme_Custodian *main_custodian;
static Scheme_Custodian *last_custodian;
/* On swap, put target in a static variable, instead of on the stack,
so that the swapped-out thread is less likely to have a pointer
to the target thread. */
static Scheme_Thread *swap_target;
static Scheme_Object *scheduled_kills;
Scheme_Object *scheme_parameterization_key;
@ -1906,6 +1911,7 @@ static Scheme_Thread *make_thread(Scheme_Config *config,
REGISTER_SO(scheme_main_thread);
REGISTER_SO(scheme_first_thread);
REGISTER_SO(thread_swap_callbacks);
REGISTER_SO(swap_target);
scheme_current_thread = process;
scheme_first_thread = scheme_main_thread = process;
@ -2215,7 +2221,7 @@ int scheme_in_main_thread(void)
return !scheme_current_thread->next;
}
void scheme_swap_thread(Scheme_Thread *new_thread)
static void do_swap_thread()
{
scheme_zero_unneeded_rands(scheme_current_thread);
@ -2257,6 +2263,8 @@ void scheme_swap_thread(Scheme_Thread *new_thread)
scheme_takeover_stacks(scheme_current_thread);
}
} else {
Scheme_Thread *new_thread = swap_target;
swap_no_setjmp = 0;
/* We're leaving... */
@ -2289,6 +2297,13 @@ void scheme_swap_thread(Scheme_Thread *new_thread)
}
}
void scheme_swap_thread(Scheme_Thread *new_thread)
{
swap_target = new_thread;
new_thread = NULL;
do_swap_thread();
}
static void select_thread()
{
Scheme_Thread *new_thread;
@ -2352,7 +2367,11 @@ static void select_thread()
o = NULL;
} while (!new_thread);
scheme_swap_thread(new_thread);
swap_target = new_thread;
new_thread = NULL;
o = NULL;
t_set = NULL;
do_swap_thread();
}
static void thread_is_dead(Scheme_Thread *r)
@ -2461,6 +2480,12 @@ static void remove_thread(Scheme_Thread *r)
r->cont_mark_stack_owner = NULL;
r->cont_mark_stack_swapped = NULL;
r->ku.apply.tail_rator = NULL;
r->ku.apply.tail_rands = NULL;
r->tail_buffer = NULL;
r->ku.multiple.array = NULL;
r->values_buffer = NULL;
#ifndef SENORA_GC_NO_FREE
if (r->list_stack)
GC_free(r->list_stack);
@ -2707,10 +2732,18 @@ static Scheme_Object *thread_dead_p(int argc, Scheme_Object *args[])
return MZTHREAD_STILL_RUNNING(running) ? scheme_false : scheme_true;
}
static int thread_wait_done(Scheme_Object *p)
static int thread_wait_done(Scheme_Object *p, Scheme_Schedule_Info *sinfo)
{
int running = ((Scheme_Thread *)p)->running;
return !MZTHREAD_STILL_RUNNING(running);
if (MZTHREAD_STILL_RUNNING(running)) {
/* Replace the direct thread reference with an event, so that
the blocking thread can be dequeued: */
Scheme_Object *evt;
evt = scheme_get_thread_dead((Scheme_Thread *)p);
scheme_set_sync_target(sinfo, evt, p, NULL, 0, 0);
return 0;
} else
return 1;
}
static Scheme_Object *thread_wait(int argc, Scheme_Object *args[])
@ -2723,7 +2756,7 @@ static Scheme_Object *thread_wait(int argc, Scheme_Object *args[])
p = (Scheme_Thread *)args[0];
if (MZTHREAD_STILL_RUNNING(p->running)) {
scheme_block_until(thread_wait_done, NULL, (Scheme_Object *)p, 0);
sch_sync(1, args);
}
return scheme_void;
@ -2732,8 +2765,8 @@ static Scheme_Object *thread_wait(int argc, Scheme_Object *args[])
static void register_thread_sync()
{
scheme_add_evt(scheme_thread_type,
thread_wait_done,
NULL, NULL, 0);
(Scheme_Ready_Fun)thread_wait_done,
NULL, NULL, 0);
}
void scheme_add_swap_callback(Scheme_Closure_Func f, Scheme_Object *data)
@ -3743,7 +3776,12 @@ void scheme_thread_block(float sleep_time)
#endif
if (next) {
scheme_swap_thread(next);
/* Swap in `next', but first clear references to other threads. */
next_in_set = NULL;
t_set = NULL;
swap_target = next;
next = NULL;
do_swap_thread();
} else if (do_atomic && scheme_on_atomic_timeout) {
scheme_on_atomic_timeout();
} else {
@ -5894,7 +5932,7 @@ static Scheme_Object *do_param(void *data, int argc, Scheme_Object *argv[])
pos[1] = ((ParamData *)data)->defcell;
return scheme_param_config("parameter-procedure",
(Scheme_Object *)pos,
(Scheme_Object *)(void *)pos,
argc, argv2,
-2, NULL, NULL, 0);
}

6
src/mzscheme/src/type.c
View File

@ -424,7 +424,8 @@ static void MARK_jmpup(Scheme_Jumpup_Buf *buf)
GC_mark_variable_stack(buf->gc_var_stack,
(long)buf->stack_copy - (long)buf->stack_from,
/* FIXME: stack direction */
(char *)buf->stack_copy + buf->stack_size);
(char *)buf->stack_copy + buf->stack_size,
buf->stack_copy);
}
static void FIXUP_jmpup(Scheme_Jumpup_Buf *buf)
@ -440,7 +441,8 @@ static void FIXUP_jmpup(Scheme_Jumpup_Buf *buf)
GC_fixup_variable_stack(buf->gc_var_stack,
(long)new_stack - (long)buf->stack_from,
/* FIXME: stack direction */
(char *)new_stack + buf->stack_size);
(char *)new_stack + buf->stack_size,
new_stack);
}
#define MARKS_FOR_TYPE_C