diff --git a/collects/ffi/unsafe/try-atomic.rkt b/collects/ffi/unsafe/try-atomic.rkt index 1de4186456..c1c44f2ddf 100644 --- a/collects/ffi/unsafe/try-atomic.rkt +++ b/collects/ffi/unsafe/try-atomic.rkt @@ -11,7 +11,7 @@ (define scheme_call_with_composable_no_dws (get-ffi-obj 'scheme_call_with_composable_no_dws #f (_fun _scheme _scheme -> _scheme))) (define scheme_set_on_atomic_timeout - (get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun (_fun -> _void) -> _pointer))) + (get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun (_fun _int -> _void) -> _pointer))) (define scheme_restore_on_atomic_timeout (get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun _pointer -> _pointer))) @@ -59,8 +59,10 @@ [else ;; try to do some work: (let* ([ready? #f] - [handler (lambda () - (when (and ready? (should-give-up?)) + [handler (lambda (must-give-up) + (when (and ready? + (or (positive? must-give-up) + (should-give-up?))) (scheme_call_with_composable_no_dws (lambda (proc) (set-box! b (cons proc (unbox b))) diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h index 949f9f2dcc..2d3283e0a9 100644 --- a/src/racket/include/scheme.h +++ b/src/racket/include/scheme.h @@ -1710,7 +1710,7 @@ extern void *scheme_malloc_envunbox(size_t); /* embedding configuration and hooks */ /*========================================================================*/ -typedef void (*Scheme_On_Atomic_Timeout_Proc)(void); +typedef void (*Scheme_On_Atomic_Timeout_Proc)(int must_give_up); #if SCHEME_DIRECT_EMBEDDED diff --git a/src/racket/src/mzmark.c b/src/racket/src/mzmark.c index a9ce6020f5..9c0b9f06c5 100644 --- a/src/racket/src/mzmark.c +++ b/src/racket/src/mzmark.c @@ -4550,39 +4550,6 @@ static int mark_thread_cell_FIXUP(void *p, struct NewGC *gc) { #define mark_thread_cell_IS_CONST_SIZE 1 -static int mark_frozen_tramp_SIZE(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(FrozenTramp)); -} - -static int mark_frozen_tramp_MARK(void *p, struct NewGC *gc) { - FrozenTramp *f = (FrozenTramp *)p; - - gcMARK2(f->do_data, gc); - gcMARK2(f->old_param, gc); - gcMARK2(f->config, gc); - gcMARK2(f->progress_cont, gc); - - return - gcBYTES_TO_WORDS(sizeof(FrozenTramp)); -} - -static int mark_frozen_tramp_FIXUP(void *p, struct NewGC *gc) { - FrozenTramp *f = (FrozenTramp *)p; - - gcFIXUP2(f->do_data, gc); - gcFIXUP2(f->old_param, gc); - gcFIXUP2(f->config, gc); - gcFIXUP2(f->progress_cont, gc); - - return - gcBYTES_TO_WORDS(sizeof(FrozenTramp)); -} - -#define mark_frozen_tramp_IS_ATOMIC 0 -#define mark_frozen_tramp_IS_CONST_SIZE 1 - - #endif /* THREAD */ /**********************************************************************/ diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index eeb1a32bca..2c7a5a138e 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -1852,19 +1852,6 @@ mark_thread_cell { gcBYTES_TO_WORDS(sizeof(Thread_Cell)); } -mark_frozen_tramp { - mark: - FrozenTramp *f = (FrozenTramp *)p; - - gcMARK2(f->do_data, gc); - gcMARK2(f->old_param, gc); - gcMARK2(f->config, gc); - gcMARK2(f->progress_cont, gc); - - size: - gcBYTES_TO_WORDS(sizeof(FrozenTramp)); -} - END thread; /**********************************************************************/ diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 86af9ddf4b..df3abad0df 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -463,6 +463,8 @@ void scheme_suspend_remembered_threads(void); void scheme_resume_remembered_threads(void); #endif +int scheme_wait_until_suspend_ok(void); + #ifdef MZ_USE_MZRT extern void scheme_check_foreign_work(void); #endif diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index 81f05695d2..b4f6fd217d 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.0.99.3" +#define MZSCHEME_VERSION "5.0.99.4" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 99 -#define MZSCHEME_VERSION_W 3 +#define MZSCHEME_VERSION_W 4 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/racket/src/sema.c b/src/racket/src/sema.c index fb00d00c48..df7f15e7f7 100644 --- a/src/racket/src/sema.c +++ b/src/racket/src/sema.c @@ -25,6 +25,7 @@ READ_ONLY Scheme_Object *scheme_always_ready_evt; THREAD_LOCAL_DECL(Scheme_Object *scheme_system_idle_channel); +extern int scheme_assert_atomic; static Scheme_Object *make_sema(int n, Scheme_Object **p); static Scheme_Object *semap(int n, Scheme_Object **p); @@ -93,7 +94,7 @@ void scheme_init_sema(Scheme_Env *env) scheme_add_global_constant("make-semaphore", scheme_make_prim_w_arity(make_sema, "make-semaphore", - 0, 1), + 0, 2), env); scheme_add_global_constant("semaphore?", scheme_make_folding_prim(semap, @@ -226,6 +227,7 @@ Scheme_Object *scheme_make_sema(long v) static Scheme_Object *make_sema(int n, Scheme_Object **p) { long v; + Scheme_Object *s; if (n) { if (!SCHEME_INTP(p[0])) { @@ -242,7 +244,12 @@ static Scheme_Object *make_sema(int n, Scheme_Object **p) } else v = 0; - return scheme_make_sema(v); + s = scheme_make_sema(v); + + if (n > 1) + SCHEME_CPTR_FLAGS(s) |= 0x1; + + return s; } static Scheme_Object *make_sema_repost(int n, Scheme_Object **p) @@ -315,6 +322,10 @@ void scheme_post_sema(Scheme_Object *o) } else consumed = 0; + if (!consumed) + if (SCHEME_CPTR_FLAGS(o) & 0x1) + printf("here\n"); + w->in_line = 0; w->prev = NULL; w->next = NULL; @@ -633,26 +644,47 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci } else start_pos = 0; - /* Initial poll */ - i = 0; - for (ii = 0; ii < n; ii++) { - /* Randomized start position for poll ensures fairness: */ - i = (start_pos + ii) % n; + scheme_assert_atomic++; - if (semas[i]->so.type == scheme_sema_type) { - if (semas[i]->value) { - if ((semas[i]->value > 0) && (!syncing || !syncing->reposts || !syncing->reposts[i])) - --semas[i]->value; - if (syncing && syncing->accepts && syncing->accepts[i]) - scheme_accept_sync(syncing, i); - break; - } - } else if (semas[i]->so.type == scheme_never_evt_type) { - /* Never ready. */ - } else if (semas[i]->so.type == scheme_channel_syncer_type) { - /* Probably no need to poll */ - } else if (try_channel(semas[i], syncing, i, NULL)) - break; + /* Initial poll */ + while (1) { + i = 0; + for (ii = 0; ii < n; ii++) { + /* Randomized start position for poll ensures fairness: */ + i = (start_pos + ii) % n; + + if (semas[i]->so.type == scheme_sema_type) { + if (semas[i]->value) { + if ((semas[i]->value > 0) && (!syncing || !syncing->reposts || !syncing->reposts[i])) + --semas[i]->value; + if (syncing && syncing->accepts && syncing->accepts[i]) + scheme_accept_sync(syncing, i); + break; + } + } else if (semas[i]->so.type == scheme_never_evt_type) { + /* Never ready. */ + } else if (semas[i]->so.type == scheme_channel_syncer_type) { + /* Probably no need to poll */ + } else if (try_channel(semas[i], syncing, i, NULL)) + break; + } + + if (ii >= n) { + if (!scheme_current_thread->next) + break; + else { + --scheme_assert_atomic; + if (!scheme_wait_until_suspend_ok()) { + scheme_assert_atomic++; + break; + } else { + /* there may have been some action on one of the waitables; + try again */ + scheme_assert_atomic++; + } + } + } else + break; } /* In the following, syncers get changed back to channels, @@ -700,7 +732,9 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci scheme_main_was_once_suspended = 0; + scheme_assert_atomic--; scheme_block_until(out_of_line, NULL, (Scheme_Object *)a, (float)0.0); + scheme_assert_atomic++; --scheme_current_thread->suspend_break; } else { @@ -710,7 +744,9 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci old_nkc = (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP); if (!old_nkc) scheme_current_thread->running += MZTHREAD_NEED_KILL_CLEANUP; + scheme_assert_atomic--; scheme_weak_suspend_thread(scheme_current_thread); + scheme_assert_atomic++; if (!old_nkc && (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP)) scheme_current_thread->running -= MZTHREAD_NEED_KILL_CLEANUP; } @@ -758,7 +794,9 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci get_outof_line(semas[i], ws[i]); } + scheme_assert_atomic--; scheme_thread_block(0); /* ok if it returns multiple times */ + scheme_assert_atomic++; scheme_current_thread->ran_some = 1; /* [but why would it return multiple times?! there must have been a reason...] */ } else { @@ -800,6 +838,8 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci } } + scheme_assert_atomic--; + if (i == -1) { scheme_thread_block(0); /* dies or suspends */ scheme_current_thread->ran_some = 1; @@ -807,6 +847,8 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci if (i < n) break; + + scheme_assert_atomic++; } /* Otherwise: !syncing and someone stole the post, or we were @@ -837,6 +879,7 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci get_outof_line(semas[j], ws[j]); } + scheme_assert_atomic--; break; } @@ -861,7 +904,8 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci } /* Back to top of loop to sync again */ } - } + } else + scheme_assert_atomic--; v = i + 1; } diff --git a/src/racket/src/stypes.h b/src/racket/src/stypes.h index 889bb6ae16..0eb0c795e8 100644 --- a/src/racket/src/stypes.h +++ b/src/racket/src/stypes.h @@ -257,8 +257,7 @@ enum { scheme_rt_sfs_info, /* 233 */ scheme_rt_validate_clearing, /* 234 */ scheme_rt_rb_node, /* 235 */ - scheme_rt_frozen_tramp, /* 236 */ - scheme_rt_lightweight_cont, /* 237 */ + scheme_rt_lightweight_cont, /* 236 */ #endif diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index 60a828d734..e73a2bcecf 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -128,6 +128,8 @@ extern int scheme_jit_malloced; # define scheme_jit_malloced 0 #endif +int scheme_assert_atomic; + /*========================================================================*/ /* local variables and prototypes */ /*========================================================================*/ @@ -206,7 +208,7 @@ HOOK_SHARED_OK void (*scheme_sleep)(float seconds, void *fds); HOOK_SHARED_OK void (*scheme_notify_multithread)(int on); HOOK_SHARED_OK void (*scheme_wakeup_on_input)(void *fds); HOOK_SHARED_OK int (*scheme_check_for_break)(void); -HOOK_SHARED_OK void (*scheme_on_atomic_timeout)(void); +HOOK_SHARED_OK Scheme_On_Atomic_Timeout_Proc scheme_on_atomic_timeout; HOOK_SHARED_OK static int atomic_timeout_auto_suspend; HOOK_SHARED_OK static int atomic_timeout_atomic_level; @@ -214,7 +216,6 @@ THREAD_LOCAL_DECL(struct Scheme_GC_Pre_Post_Callback_Desc *gc_prepost_callback_d ROSYM static Scheme_Object *read_symbol, *write_symbol, *execute_symbol, *delete_symbol, *exists_symbol; ROSYM static Scheme_Object *client_symbol, *server_symbol; -ROSYM static Scheme_Object *froz_key; THREAD_LOCAL_DECL(static int do_atomic = 0); THREAD_LOCAL_DECL(static int missed_context_switch = 0); @@ -380,7 +381,6 @@ static void make_initial_config(Scheme_Thread *p); static int do_kill_thread(Scheme_Thread *p); static void suspend_thread(Scheme_Thread *p); -static void wait_until_suspend_ok(int for_stack); static int check_sleep(int need_activity, int sleep_now); @@ -471,9 +471,6 @@ void scheme_init_thread(Scheme_Env *env) client_symbol = scheme_intern_symbol("client"); server_symbol = scheme_intern_symbol("server"); - REGISTER_SO(froz_key); - froz_key = scheme_make_symbol("frozen"); /* uninterned */ - scheme_add_global_constant("dump-memory-stats", scheme_make_prim_w_arity(scheme_dump_gc_stats, "dump-memory-stats", @@ -2627,6 +2624,9 @@ static void do_swap_thread() swapping = 1; #endif + if (scheme_assert_atomic) + *(long *)0x0 = 1; + if (!swap_no_setjmp && SETJMP(scheme_current_thread)) { /* We're back! */ /* See also initial swap in in start_child() */ @@ -3311,10 +3311,6 @@ Scheme_Object *scheme_thread_w_details(Scheme_Object *thunk, if (scheme_is_stack_too_shallow()) { Scheme_Thread *p = scheme_current_thread; - /* Don't mangle the stack if we're in atomic mode, because that - probably means a stack-freeze trampoline, etc. */ - wait_until_suspend_ok(1); - p->ku.k.p1 = thunk; p->ku.k.p2 = config; p->ku.k.p3 = mgr; @@ -3379,7 +3375,7 @@ Scheme_Object *scheme_call_as_nested_thread(int argc, Scheme_Object *argv[], voi SCHEME_USE_FUEL(25); - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); np = MALLOC_ONE_TAGGED(Scheme_Thread); np->so.type = scheme_thread_type; @@ -4051,6 +4047,43 @@ void scheme_break_thread(Scheme_Thread *p) # endif } +static void call_on_atomic_timeout(int must) +{ + Scheme_Thread *p = scheme_current_thread; + int running; + double sleep_end; + int block_descriptor; + Scheme_Object *blocker; + Scheme_Ready_Fun block_check; + Scheme_Needs_Wakeup_Fun block_needs_wakeup; + + /* Save any state that has to do with the thread blocking or + sleeping, in case scheme_on_atomic_timeout() runs Racket code. */ + + running = p->running; + sleep_end = p->sleep_end; + block_descriptor = p->block_descriptor; + blocker = p->blocker; + block_check = p->block_check; + block_needs_wakeup = p->block_needs_wakeup; + + p->running = MZTHREAD_RUNNING; + p->sleep_end = 0.0; + p->block_descriptor = 0; + p->blocker = NULL; + p->block_check = NULL; + p->block_needs_wakeup = NULL; + + scheme_on_atomic_timeout(must); + + p->running = running; + p->sleep_end = sleep_end; + p->block_descriptor = block_descriptor; + p->blocker = blocker; + p->block_check = block_check; + p->block_needs_wakeup = block_needs_wakeup; +} + static void find_next_thread(Scheme_Thread **return_arg) { Scheme_Thread *next; Scheme_Thread *p = scheme_current_thread; @@ -4212,7 +4245,7 @@ void scheme_thread_block(float sleep_time) if ((p->running & MZTHREAD_USER_SUSPENDED) && !(p->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) { /* This thread was suspended. */ - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); if (!p->next) { /* Suspending the main thread... */ select_thread(); @@ -4311,9 +4344,9 @@ void scheme_thread_block(float sleep_time) } #endif -/*####################################*/ -/* THREAD CONTEXT SWITCH HAPPENS HERE */ -/*####################################*/ + /*####################################*/ + /* THREAD CONTEXT SWITCH HAPPENS HERE */ + /*####################################*/ if (next) { /* Swap in `next', but first clear references to other threads. */ @@ -4329,7 +4362,7 @@ void scheme_thread_block(float sleep_time) scheme_fuel_counter = p->engine_weight; scheme_jit_stack_boundary = scheme_stack_boundary; } - scheme_on_atomic_timeout(); + call_on_atomic_timeout(0); if (atomic_timeout_auto_suspend > 1) --atomic_timeout_auto_suspend; } @@ -4360,7 +4393,7 @@ void scheme_thread_block(float sleep_time) /* Suspended while I was asleep? */ if ((p->running & MZTHREAD_USER_SUSPENDED) && !(p->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) { - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); if (!p->next) scheme_thread_block(0.0); /* main thread handled at top of this function */ else @@ -4592,22 +4625,24 @@ void scheme_end_atomic_can_break(void) scheme_check_break_now(); } -static void wait_until_suspend_ok(int for_stack) +int scheme_wait_until_suspend_ok(void) { - if (scheme_on_atomic_timeout && atomic_timeout_auto_suspend) { + int did = 0; + + if (scheme_on_atomic_timeout) { /* new-style atomic timeout */ - if (for_stack) { - /* a stack overflow is ok for the new-style timeout */ - return; - } else if (do_atomic > atomic_timeout_atomic_level) { + if (do_atomic > atomic_timeout_atomic_level) { scheme_log_abort("attempted to wait for suspend in nested atomic mode"); abort(); } } while (do_atomic && scheme_on_atomic_timeout) { - scheme_on_atomic_timeout(); + did = 1; + call_on_atomic_timeout(1); } + + return did; } Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p) @@ -4631,10 +4666,6 @@ void scheme_weak_suspend_thread(Scheme_Thread *r) if (r->running & MZTHREAD_SUSPENDED) return; - if (r == scheme_current_thread) { - wait_until_suspend_ok(0); - } - if (r->prev) { r->prev->next = r->next; r->next->prev = r->prev; @@ -4679,7 +4710,6 @@ void scheme_weak_resume_thread(Scheme_Thread *r) void scheme_about_to_move_C_stack(void) { - wait_until_suspend_ok(1); } static Scheme_Object * @@ -4791,7 +4821,7 @@ void scheme_kill_thread(Scheme_Thread *p) { if (do_kill_thread(p)) { /* Suspend/kill self: */ - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); if (p->suspend_to_kill) suspend_thread(p); else @@ -4921,7 +4951,7 @@ static void suspend_thread(Scheme_Thread *p) p->running |= MZTHREAD_USER_SUSPENDED; } else { if (p == scheme_current_thread) { - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); } p->running |= MZTHREAD_USER_SUSPENDED; scheme_weak_suspend_thread(p); /* ok if p is scheme_current_thread */ @@ -8081,269 +8111,6 @@ void scheme_free_gmp(void *p, void **mem_pool) *mem_pool = SCHEME_CDR(*mem_pool); } -/*========================================================================*/ -/* stack freezer */ -/*========================================================================*/ - -/* When interacting with certain libraries that can lead to Scheme - callbacks, the stack region used by the library should not be - modified by Scheme thread swaps. In that case, the callback must be - constrained. Completely disallowing synchornization with ther - threads or unbounded computation, however, is sometimes too - difficult. A stack-freezer sequence offer a compromise, where the - callback is run as much as possible, but it can be suspended to - allow the library call to return so that normal Scheme-thread - scheduling can resume. The callback is then completed in a normal - scheduling context, where it is no longer specially constrained. - - The call process is - scheme_with_stack_freeze(f, data) - -> f(data) in frozen mode - -> ... frozen_run_some(g, data2) \ - -> Scheme code, may finish or may not | maybe loop - froz->in_progress inicates whether done / - -> continue scheme if not finished - - In this process, it's the call stack between f(data) and the call - to frozen_run_some() that won't be copied in or out until f(data) - returns. - - Nesting scheme_with_stack_freeze() calls should be safe, but it - won't achieve the goal, which is to limit the amount of work done - before returning (because the inner scheme_with_stack_freeze() will - have to run to completion). */ - -static unsigned long get_deeper_base(); - -typedef struct FrozenTramp { - MZTAG_IF_REQUIRED - Scheme_Frozen_Stack_Proc do_f; - void *do_data; - int val; - int in_progress; - int progress_is_resumed; - Scheme_Object *old_param; - Scheme_Config *config; - void *progress_base_addr; - mz_jmp_buf progress_base; - Scheme_Jumpup_Buf_Holder *progress_cont; - int timer_on; - double continue_until; -#ifdef MZ_PRECISE_GC - void *fixup_var_stack_chain; -#endif -} FrozenTramp; - -int scheme_with_stack_freeze(Scheme_Frozen_Stack_Proc wha_f, void *wha_data) -{ - FrozenTramp *froz; - Scheme_Cont_Frame_Data cframe; - Scheme_Object *bx; - int retval; - Scheme_Jumpup_Buf_Holder *pc; - - froz = MALLOC_ONE_RT(FrozenTramp); - SET_REQUIRED_TAG(froz->type = scheme_rt_frozen_tramp); - - bx = scheme_make_raw_pair((Scheme_Object *)froz, NULL); - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(froz_key, bx); - - pc = scheme_new_jmpupbuf_holder(); - froz->progress_cont = pc; - - scheme_init_jmpup_buf(&froz->progress_cont->buf); - - scheme_start_atomic(); - retval = wha_f(wha_data); - froz->val = retval; - - if (froz->in_progress) { - /* We have leftover work; jump and finish it (non-atomically). - But don't swap until we've jumped back in, because the jump-in - point might be trying to suspend the thread (and that should - complete before any swap). */ - scheme_end_atomic_no_swap(); - SCHEME_CAR(bx) = NULL; - froz->in_progress = 0; - froz->progress_is_resumed = 1; - if (!scheme_setjmp(froz->progress_base)) { -#ifdef MZ_PRECISE_GC - froz->fixup_var_stack_chain = &__gc_var_stack__; -#endif - scheme_longjmpup(&froz->progress_cont->buf); - } - } else { - scheme_end_atomic(); - } - - scheme_pop_continuation_frame(&cframe); - - froz->old_param = NULL; - froz->progress_cont = NULL; - froz->do_data = NULL; - - return froz->val; -} - -static void suspend_froz_progress(void) -{ - FrozenTramp * volatile froz; - double msecs; - Scheme_Object *v; - - v = scheme_extract_one_cc_mark(NULL, froz_key); - froz = (FrozenTramp *)SCHEME_CAR(v); - v = NULL; - - msecs = scheme_get_inexact_milliseconds(); - if (msecs < froz->continue_until) - return; - - scheme_on_atomic_timeout = NULL; - - froz->in_progress = 1; - if (scheme_setjmpup(&froz->progress_cont->buf, (void*)froz->progress_cont, froz->progress_base_addr)) { - /* we're back */ - scheme_reset_jmpup_buf(&froz->progress_cont->buf); -#ifdef MZ_PRECISE_GC - /* Base addr points to the last valid gc_var_stack address. - Fixup that link to skip over the part of the stack we're - not using right now. */ - ((void **)froz->progress_base_addr)[0] = froz->fixup_var_stack_chain; - ((void **)froz->progress_base_addr)[1] = NULL; -#endif - } else { - /* we're leaving */ - scheme_longjmp(froz->progress_base, 1); - } -} - -static void froz_run_new(FrozenTramp * volatile froz, int run_msecs) -{ - double msecs; - - /* We're willing to start new work that is specific to this thread */ - froz->progress_is_resumed = 0; - - msecs = scheme_get_inexact_milliseconds(); - froz->continue_until = msecs + run_msecs; - - if (!scheme_setjmp(froz->progress_base)) { - Scheme_Frozen_Stack_Proc do_f; - scheme_start_atomic(); - scheme_on_atomic_timeout = suspend_froz_progress; - atomic_timeout_atomic_level = -1; - do_f = froz->do_f; - do_f(froz->do_data); - } - - if (froz->progress_is_resumed) { - /* we've already returned once; jump out to new progress base */ - scheme_longjmp(froz->progress_base, 1); - } else { - scheme_on_atomic_timeout = NULL; - scheme_end_atomic_no_swap(); - } -} - -static void froz_do_run_new(FrozenTramp * volatile froz, int *iteration, int run_msecs) -{ - /* This function just makes room on the stack, eventually calling - froz_run_new(). */ - int new_iter[32]; - - if (iteration[0] == 3) { -#ifdef MZ_PRECISE_GC - froz->progress_base_addr = (void *)&__gc_var_stack__; -#else - froz->progress_base_addr = (void *)new_iter; -#endif - froz_run_new(froz, run_msecs); - } else { - new_iter[0] = iteration[0] + 1; - froz_do_run_new(froz, new_iter, run_msecs); - } -} - -int scheme_frozen_run_some(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs) -{ - FrozenTramp * volatile froz; - int more = 0; - Scheme_Object *v; - - v = scheme_extract_one_cc_mark(NULL, froz_key); - if (v) - froz = (FrozenTramp *)SCHEME_CAR(v); - else - froz = NULL; - v = NULL; - - if (froz) { - if (froz->in_progress) { - /* We have work in progress. */ - if ((unsigned long)froz->progress_base_addr < get_deeper_base()) { - /* We have stack space to resume the old work: */ - double msecs; - froz->in_progress = 0; - froz->progress_is_resumed = 1; - msecs = scheme_get_inexact_milliseconds(); - froz->continue_until = msecs + run_msecs; - scheme_start_atomic(); - scheme_on_atomic_timeout = suspend_froz_progress; - atomic_timeout_atomic_level = -1; - if (!scheme_setjmp(froz->progress_base)) { -#ifdef MZ_PRECISE_GC - froz->fixup_var_stack_chain = &__gc_var_stack__; -#endif - scheme_longjmpup(&froz->progress_cont->buf); - } else { - scheme_on_atomic_timeout = NULL; - scheme_end_atomic_no_swap(); - } - } - } else { - int iter[1]; - iter[0] = 0; - froz->do_f = do_f; - froz->do_data = do_data; - froz_do_run_new(froz, iter, run_msecs); - } - - more = froz->in_progress; - } - - return more; -} - -int scheme_is_in_frozen_stack() -{ - Scheme_Object *v; - - v = scheme_extract_one_cc_mark(NULL, froz_key); - if (v) - return 1; - else - return 0; -} - -/* Disable warning for returning address of local variable: */ -#ifdef _MSC_VER -#pragma warning (disable:4172) -#endif - -static unsigned long get_deeper_base() -{ - long here; - unsigned long here_addr = (unsigned long)&here; - return here_addr; -} - -#ifdef _MSC_VER -#pragma warning (default:4172) -#endif - /*========================================================================*/ /* precise GC */ /*========================================================================*/ @@ -8396,7 +8163,6 @@ static void register_traversers(void) GC_REG_TRAV(scheme_rt_evt, mark_evt); GC_REG_TRAV(scheme_rt_syncing, mark_syncing); GC_REG_TRAV(scheme_rt_parameterization, mark_parameterization); - GC_REG_TRAV(scheme_rt_frozen_tramp, mark_frozen_tramp); } END_XFORM_SKIP;