static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
{
void *v;
if (!(SCHEME_HASHTP(argv[0]) || SCHEME_BUCKTP(argv[0])))
scheme_wrong_type("hash-table-get", "hash-table", 0, argc, argv);
if (SCHEME_BUCKTP(argv[0])){
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex, 0);
v = scheme_lookup_in_table(t, (char *)argv[1]);
if (t->mutex) scheme_post_sema(t->mutex);
} else {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex, 0);
v = scheme_hash_get(t, argv[1]);
if (t->mutex) scheme_post_sema(t->mutex);
}
if (v)
return (Scheme_Object *)v;
else if (argc == 3)
return _scheme_tail_apply(argv[2], 0, NULL);
else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"hash-table-get: no value found for key: %V",
argv[1]);
return scheme_void;
}
}
static Scheme_Object *hash_table_put(int argc, Scheme_Object *argv[])
{
if (!(SCHEME_HASHTP(argv[0]) || SCHEME_BUCKTP(argv[0])) || SCHEME_IMMUTABLEP(argv[0]))
scheme_wrong_type("hash-table-put!", "mutable hash-table", 0, argc, argv);
if (SCHEME_BUCKTP(argv[0])) {
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex,0);
scheme_add_to_table(t, (char *)argv[1], (void *)argv[2], 0);
if (t->mutex) scheme_post_sema(t->mutex);
} else{
Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex, 0);
scheme_hash_set(t, argv[1], argv[2]);
if (t->mutex) scheme_post_sema(t->mutex);
}
return scheme_void;
}
static Scheme_Object *hash_table_copy(int argc, Scheme_Object *argv[])
{
if (SCHEME_HASHTP(argv[0])) {
Scheme_Object *o;
Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex,0);
o = (Scheme_Object *)scheme_clone_hash_table(t);
if (t->mutex) scheme_post_sema(t->mutex);
return o;
} else if (SCHEME_BUCKTP(argv[0])) {
Scheme_Object *o;
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex,0);
o = (Scheme_Object *)scheme_clone_bucket_table(t);
if (t->mutex) scheme_post_sema(t->mutex);
return o;
} else {
scheme_wrong_type("hash-table-copy", "hash-table", 0, argc, argv);
return NULL;
}
}
static Scheme_Object *hash_table_remove(int argc, Scheme_Object *argv[])
{
if (!(SCHEME_HASHTP(argv[0]) || SCHEME_BUCKTP(argv[0])) || SCHEME_IMMUTABLEP(argv[0]))
scheme_wrong_type("hash-table-remove!", "mutable hash-table", 0, argc, argv);
if (SCHEME_BUCKTP(argv[0])) {
Scheme_Bucket *b;
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex, 0);
b = scheme_bucket_or_null_from_table((Scheme_Bucket_Table *)argv[0], (char *)argv[1], 0);
if (b) {
HT_EXTRACT_WEAK(b->key) = NULL;
b->val = NULL;
}
if (t->mutex) scheme_post_sema(t->mutex);
} else{
Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex, 0);
scheme_hash_set(t, argv[1], NULL);
if (t->mutex) scheme_post_sema(t->mutex);
}
return scheme_void;
}
/* For object-sync: */
static int sema_ready(Scheme_Object *s)
{
return scheme_wait_sema(s, 1);
}
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 */
}
