static void ext_get_into_line(Scheme_Object *ch, Scheme_Schedule_Info *sinfo)
{
Scheme_Channel_Syncer *w;
/* Get into line */
w = MALLOC_ONE_RT(Scheme_Channel_Syncer);
w->so.type = scheme_channel_syncer_type;
if (sinfo->false_positive_ok)
w->p = sinfo->false_positive_ok;
else
w->p = scheme_current_thread;
w->syncing = (Syncing *)sinfo->current_syncing;
w->obj = ch;
w->syncing_i = sinfo->w_i;
get_into_line((Scheme_Sema *)ch, w);
scheme_set_sync_target(sinfo, (Scheme_Object *)w, NULL, NULL, 0, 0, NULL);
}
SFS_Info *scheme_new_sfs_info(int depth)
{
SFS_Info *info;
int *max_used, *max_calls;
info = MALLOC_ONE_RT(SFS_Info);
SET_REQUIRED_TAG(info->type = scheme_rt_sfs_info);
info->depth = depth;
info->stackpos = depth;
info->tlpos = depth;
max_used = (int *)scheme_malloc_atomic(sizeof(int) * depth);
max_calls = (int *)scheme_malloc_atomic(sizeof(int) * depth);
memset(max_used, 0, sizeof(int) * depth);
memset(max_calls, 0, sizeof(int) * depth);
info->max_used = max_used;
info->max_calls = max_calls;
return info;
}
int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *syncing)
/* When syncing is supplied, o can contain Scheme_Channel_Syncer
and never-evt values, and just_try must be 0. */
{
Scheme_Sema **semas = (Scheme_Sema **)o;
int v, i, ii;
if (just_try) {
/* assert: n == 1, !syncing */
Scheme_Sema *sema = semas[0];
if (just_try > 0) {
if (sema->so.type == scheme_sema_type) {
v = scheme_try_plain_sema((Scheme_Object *)sema);
} else {
v = try_channel(sema, syncing, 0, NULL);
}
} else {
Scheme_Cont_Frame_Data cframe;
scheme_push_break_enable(&cframe, 1, 1);
scheme_wait_sema((Scheme_Object *)sema, 0);
scheme_pop_break_enable(&cframe, 0);
return 1;
}
} else {
int start_pos;
if (n > 1) {
if (syncing)
start_pos = syncing->start_pos;
else {
Scheme_Object *rand_state;
rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_SCHEDULER_RANDOM_STATE);
start_pos = scheme_rand((Scheme_Random_State *)rand_state);
}
} else
start_pos = 0;
/* 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->result = i + 1;
if (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) {
if (((Scheme_Channel_Syncer *)semas[i])->picked)
break;
} else if (try_channel(semas[i], syncing, i, NULL))
break;
}
if (ii >= n) {
if (!scheme_wait_until_suspend_ok()) {
break;
} else {
/* there may have been some action on one of the waitables;
try again, if no result, yet */
if (syncing && syncing->result) {
i = syncing->result - 1;
ii = 0;
break;
}
}
} else
break;
}
/* In the following, syncers get changed back to channels,
and channel puts */
if (ii >= n) {
Scheme_Channel_Syncer **ws, *w;
ws = MALLOC_N(Scheme_Channel_Syncer*, n);
for (i = 0; i < n; i++) {
if (semas[i]->so.type == scheme_channel_syncer_type) {
ws[i] = (Scheme_Channel_Syncer *)semas[i];
semas[i] = (Scheme_Sema *)ws[i]->obj;
} else {
w = MALLOC_ONE_RT(Scheme_Channel_Syncer);
ws[i] = w;
w->so.type = scheme_channel_syncer_type;
w->p = scheme_current_thread;
w->syncing = syncing;
w->obj = (Scheme_Object *)semas[i];
w->syncing_i = i;
}
}
while (1) {
int out_of_a_line;
/* Get into line */
for (i = 0; i < n; i++) {
if (!ws[i]->in_line) {
get_into_line(semas[i], ws[i]);
}
}
if (!scheme_current_thread->next) {
void **a;
/* We're not allowed to suspend the main thread. Delay
breaks so we get a chance to clean up. */
scheme_current_thread->suspend_break++;
a = MALLOC_N(void*, 3);
a[0] = scheme_make_integer(n);
a[1] = ws;
a[2] = scheme_current_thread;
scheme_main_was_once_suspended = 0;
scheme_block_until(out_of_line, NULL, (Scheme_Object *)a, (float)0.0);
--scheme_current_thread->suspend_break;
} else {
/* Mark the thread to indicate that we need to clean up
if the thread is killed. */
int old_nkc;
old_nkc = (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP);
if (!old_nkc)
scheme_current_thread->running += MZTHREAD_NEED_KILL_CLEANUP;
scheme_weak_suspend_thread(scheme_current_thread);
if (!old_nkc && (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP))
scheme_current_thread->running -= MZTHREAD_NEED_KILL_CLEANUP;
}
/* We've been resumed. But was it for the semaphore, or a signal? */
out_of_a_line = 0;
/* If we get the post, we must return WITHOUT BLOCKING.
GRacket, for example, depends on this special property, which
ensures that the thread can't be broken or killed between
receiving the post and returning. */
if (!syncing) {
/* Poster can't be sure that we really will get it,
so we have to decrement the sema count here. */
i = 0;
for (ii = 0; ii < n; ii++) {
i = (start_pos + ii) % n;
if (ws[i]->picked) {
out_of_a_line = 1;
if (semas[i]->value) {
if (semas[i]->value > 0)
--(semas[i]->value);
break;
}
}
}
if (ii >= n)
i = n;
} else {
if (syncing->result) {
out_of_a_line = 1;
i = syncing->result - 1;
} else {
out_of_a_line = 0;
i = n;
}
}
if (!out_of_a_line) {
/* We weren't woken by any semaphore/channel. Get out of line, block once
(to handle breaks/kills) and then loop to get back into line. */
for (i = 0; i < n; i++) {
if (ws[i]->in_line)
get_outof_line(semas[i], ws[i]);
}
scheme_thread_block(0); /* ok if it returns multiple times */
scheme_current_thread->ran_some = 1;
/* [but why would it return multiple times?! there must have been a reason...] */
} else {
if ((scheme_current_thread->running & MZTHREAD_KILLED)
|| ((scheme_current_thread->running & MZTHREAD_USER_SUSPENDED)
&& !(scheme_current_thread->running & MZTHREAD_NEED_SUSPEND_CLEANUP))) {
/* We've been killed or suspended! */
i = -1;
}
/* We got a post from semas[i], or we were killed.
Did any (other) semaphore pick us?
(This only happens when syncing == NULL.) */
if (!syncing) {
int j;
for (j = 0; j < n; j++) {
if (j != i) {
if (ws[j]->picked) {
if (semas[j]->value) {
/* Consume the value and repost, because no one else
has been told to go, and we're accepting a different post. */
if (semas[j]->value > 0)
--semas[j]->value;
scheme_post_sema((Scheme_Object *)semas[j]);
}
}
}
}
}
/* If we're done, get out of all lines that we're still in. */
if (i < n) {
int j;
for (j = 0; j < n; j++) {
if (ws[j]->in_line)
get_outof_line(semas[j], ws[j]);
}
}
if (i == -1) {
scheme_thread_block(0); /* dies or suspends */
scheme_current_thread->ran_some = 1;
}
if (i < n)
break;
}
/* Otherwise: !syncing and someone stole the post, or we were
suspended and we have to start over. Either way, poll then
loop to get back in line an try again. */
for (ii = 0; ii < n; ii++) {
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 (try_channel(semas[i], syncing, i, NULL))
break;
}
if (ii < n) {
/* Get out of any line that we still might be in: */
int j;
for (j = 0; j < n; j++) {
if (ws[j]->in_line)
get_outof_line(semas[j], ws[j]);
}
break;
}
if (!syncing) {
/* Looks like this thread is a victim of unfair semaphore access.
Go into fair mode by allocating a syncing: */
syncing = MALLOC_ONE_RT(Syncing);
#ifdef MZTAG_REQUIRED
syncing->type = scheme_rt_syncing;
#endif
syncing->start_pos = start_pos;
/* Get out of all lines, and set syncing field before we get back in line: */
{
int j;
for (j = 0; j < n; j++) {
if (ws[j]->in_line)
get_outof_line(semas[j], ws[j]);
ws[j]->syncing = syncing;
}
}
}
/* Back to top of loop to sync again */
}
static void add_finalizer(void *v, void (*f)(void*,void*), void *data,
int prim, int ext,
void (**ext_oldf)(void *p, void *data),
void **ext_olddata,
int no_dup, int rmve)
{
finalizer_function oldf;
void *olddata;
Finalizations *fns, **fns_ptr, *prealloced;
Finalization *fn;
if (!traversers_registered) {
#ifdef MZ_PRECISE_GC
GC_REG_TRAV(scheme_rt_finalization, mark_finalization);
GC_REG_TRAV(scheme_rt_finalizations, mark_finalizations);
traversers_registered = 1;
#endif
REGISTER_SO(save_fns_ptr);
}
#ifndef MZ_PRECISE_GC
if (v != GC_base(v))
return;
#endif
/* Allocate everything first so that we're not changing
finalizations when finalizations could run: */
if (save_fns_ptr) {
fns_ptr = save_fns_ptr;
save_fns_ptr = NULL;
} else
fns_ptr = MALLOC_ONE(Finalizations*);
if (!ext && !rmve) {
fn = MALLOC_ONE_RT(Finalization);
#ifdef MZTAG_REQUIRED
fn->type = scheme_rt_finalization;
#endif
fn->f = f;
fn->data = data;
} else
fn = NULL;
if (!rmve) {
prealloced = MALLOC_ONE_RT(Finalizations); /* may not need this... */
#ifdef MZTAG_REQUIRED
prealloced->type = scheme_rt_finalizations;
#endif
} else
prealloced = NULL;
GC_register_eager_finalizer(v, prim ? 2 : 1, do_next_finalization, fns_ptr, &oldf, &olddata);
if (oldf) {
if (oldf != do_next_finalization) {
/* This happens if an extenal use of GC_ routines conflicts with us. */
scheme_warning("warning: non-MzScheme finalization on object dropped!");
} else {
*fns_ptr = *(Finalizations **)olddata;
save_fns_ptr = (Finalizations **)olddata;
*save_fns_ptr = NULL;
}
} else if (rmve) {
GC_register_finalizer(v, NULL, NULL, NULL, NULL);
save_fns_ptr = fns_ptr;
return;
}
if (!(*fns_ptr)) {
prealloced->lifetime = current_lifetime;
*fns_ptr = prealloced;
}
fns = *fns_ptr;
if (ext) {
if (ext_oldf)
*ext_oldf = fns->ext_f;
fns->ext_f = f;
if (ext_olddata)
*ext_olddata = fns->ext_data;
fns->ext_data = data;
if (!f && !fns->prim_first && !fns->scheme_first) {
/* Removed all finalization */
GC_register_finalizer(v, NULL, NULL, NULL, NULL);
save_fns_ptr = fns_ptr;
*save_fns_ptr = NULL;
}
} else {
if (prim) {
if (no_dup) {
/* Make sure it's not already here */
Finalization *fnx;
for (fnx = fns->prim_first; fnx; fnx = fnx->next) {
if (fnx->f == f && fnx->data == data) {
if (rmve) {
if (fnx->prev)
fnx->prev->next = fnx->next;
else
fns->prim_first = fnx->next;
if (fnx->next)
fnx->next->prev = fnx->prev;
else
fns->prim_last = fnx->prev;
}
fn = NULL;
break;
}
}
}
if (fn) {
fn->next = fns->prim_first;
fns->prim_first = fn;
if (!fn->next)
fns->prim_last = fn;
else
fn->next->prev = fn;
}
/* Removed all finalization? */
if (!fns->ext_f && !fns->prim_first && !fns->scheme_first) {
GC_register_finalizer(v, NULL, NULL, NULL, NULL);
save_fns_ptr = fns_ptr;
*save_fns_ptr = NULL;
}
} else {
fn->next = fns->scheme_first;
fns->scheme_first = fn;
if (!fn->next)
fns->scheme_last = fn;
else
fn->next->prev = fn;
}
}
}