static Scheme_Object *make_sema_repost(int n, Scheme_Object **p)
{
if (!SCHEME_SEMAP(p[0]))
scheme_wrong_contract("semaphore-peek-evt", "semaphore?", 0, n, p);
return scheme_make_sema_repost(p[0]);
}
static Scheme_Object *hit_sema(int n, Scheme_Object **p)
{
if (!SCHEME_SEMAP(p[0]))
scheme_wrong_contract("semaphore-post", "semaphore?", 0, n, p);
scheme_post_sema(p[0]);
return scheme_void;
}
static void get_outof_line(Scheme_Sema *sema, Scheme_Channel_Syncer *w)
{
Scheme_Channel_Syncer *last, *first;
if (!w->in_line)
return;
w->in_line = 0;
if (SAME_TYPE(SCHEME_TYPE(sema), scheme_never_evt_type)) {
return; /* !!!! skip everything else */
} else if (SCHEME_SEMAP(sema)) {
last = sema->last;
first = sema->first;
} else if (SCHEME_CHANNELP(sema)) {
last = ((Scheme_Channel *)sema)->get_last;
first = ((Scheme_Channel *)sema)->get_first;
} else {
last = ((Scheme_Channel_Put *)sema)->ch->put_last;
first = ((Scheme_Channel_Put *)sema)->ch->put_first;
}
if (w->prev)
w->prev->next = w->next;
else
first = w->next;
if (w->next)
w->next->prev = w->prev;
else
last = w->prev;
if (SCHEME_SEMAP(sema)) {
sema->last = last;
sema->first = first;
} else if (SCHEME_CHANNELP(sema)) {
((Scheme_Channel *)sema)->get_last = last;
((Scheme_Channel *)sema)->get_first = first;
} else {
((Scheme_Channel_Put *)sema)->ch->put_last = last;
((Scheme_Channel_Put *)sema)->ch->put_first = first;
}
}
static void get_into_line(Scheme_Sema *sema, Scheme_Channel_Syncer *w)
/* Can be called multiple times. */
{
Scheme_Channel_Syncer *last, *first;
w->in_line = 1;
w->picked = 0;
if (SAME_TYPE(SCHEME_TYPE(sema), scheme_never_evt_type)) {
return; /* !!!! skip everything else */
} else if (SCHEME_SEMAP(sema)) {
last = sema->last;
first = sema->first;
} else if (SCHEME_CHANNELP(sema)) {
last = ((Scheme_Channel *)sema)->get_last;
first = ((Scheme_Channel *)sema)->get_first;
} else {
last = ((Scheme_Channel_Put *)sema)->ch->put_last;
first = ((Scheme_Channel_Put *)sema)->ch->put_first;
}
w->prev = last;
if (last)
last->next = w;
else
first = w;
last = w;
w->next = NULL;
if (SCHEME_SEMAP(sema)) {
sema->last = last;
sema->first = first;
} else if (SCHEME_CHANNELP(sema)) {
((Scheme_Channel *)sema)->get_last = last;
((Scheme_Channel *)sema)->get_first = first;
} else {
((Scheme_Channel_Put *)sema)->ch->put_last = last;
((Scheme_Channel_Put *)sema)->ch->put_first = first;
}
}
static Scheme_Object *semap(int n, Scheme_Object **p)
{
return SCHEME_SEMAP(p[0]) ? scheme_true : scheme_false;
}
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 0
/* Use the "immutable" flag bit on a semaphore to check for
inconsistent use in atomic and non-atomic modes, which
can lead to an attempt to suspend in atomic mode. */
if ((n == 1) && SCHEME_SEMAP(o[0])) {
if (!do_atomic) {
SCHEME_SET_IMMUTABLE(o[0]);
} else if (SCHEME_IMMUTABLEP(o[0])) {
if (!on_atomic_timeout
|| (do_atomic > atomic_timeout_atomic_level)) {
scheme_signal_error("using a seaphore in both atomic and non-atomic mode");
}
}
}
#endif
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 */
}
