Scheme_Object *scheme_jit_make_one_element_ivector(Scheme_Object *a)
{
Scheme_Object *vec;
vec = scheme_jit_make_one_element_vector(a);
SCHEME_SET_IMMUTABLE(vec);
return vec;
}
static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec, *ovec, *v;
intptr_t len, i;
vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_contract("vector->immutable-vector", "vector?", 0, argc, argv);
if (SCHEME_IMMUTABLEP(vec))
return argv[0];
ovec = vec;
len = SCHEME_VEC_SIZE(ovec);
vec = scheme_make_vector(len, NULL);
if (!SAME_OBJ(ovec, argv[0])) {
for (i = 0; i < len; i++) {
v = scheme_chaperone_vector_ref(argv[0], i);
SCHEME_VEC_ELS(vec)[i] = v;
}
} else {
for (i = 0; i < len; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(ovec)[i];
}
}
SCHEME_SET_IMMUTABLE(vec);
return vec;
}
Scheme_Object *scheme_jit_make_two_element_ivector(Scheme_Object *a, Scheme_Object *b)
{
Scheme_Object *vec;
vec = scheme_jit_make_two_element_vector(a, b);
SCHEME_SET_IMMUTABLE(vec);
return vec;
}
void scheme_make_list_immutable(Scheme_Object *l)
{
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
if (SCHEME_MUTABLEP(l))
SCHEME_SET_IMMUTABLE(l);
}
}
Scheme_Object *scheme_jit_make_ivector(intptr_t n)
{
Scheme_Object *vec;
vec = scheme_jit_make_vector(n);
SCHEME_SET_IMMUTABLE(vec);
return vec;
}
static Scheme_Object *make_immutable_hash_table(int argc, Scheme_Object *argv[])
{
Scheme_Object *l = argv[0], *a;
Scheme_Hash_Table *ht;
if (scheme_proper_list_length(l) >= 0) {
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
if (!SCHEME_PAIRP(a))
break;
}
}
if (!SCHEME_NULLP(l))
scheme_wrong_type("make-immutable-hash-table", "list of pairs", 0, argc, argv);
if (argc > 1) {
if (!SAME_OBJ(equal_symbol, argv[1]))
scheme_wrong_type("make-immutable-hash-table", "'equal", 1, argc, argv);
ht = scheme_make_hash_table_equal();
} else
ht = scheme_make_hash_table(SCHEME_hash_ptr);
for (l = argv[0]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
scheme_hash_set(ht, SCHEME_CAR(a), SCHEME_CDR(a));
}
SCHEME_SET_IMMUTABLE((Scheme_Object *)ht);
return (Scheme_Object *)ht;
}
static intptr_t initial_tag_word(Scheme_Type tag, int immut)
{
GC_CAN_IGNORE Scheme_Small_Object sp;
memset(&sp, 0, sizeof(Scheme_Small_Object));
sp.iso.so.type = tag;
if (immut) SCHEME_SET_IMMUTABLE(&sp);
return read_first_word((void *)&sp);
}
static Scheme_Object *immutable_box(int c, Scheme_Object *p[])
{
Scheme_Object *obj;
obj = scheme_box(p[0]);
SCHEME_SET_IMMUTABLE(obj);
return obj;
}
static Scheme_Object *
vector_immutable (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec;
vec = vector(argc, argv);
SCHEME_SET_IMMUTABLE(vec);
return vec;
}
static intptr_t initial_tag_word(Scheme_Type tag, int flags)
{
GC_CAN_IGNORE Scheme_Simple_Object sp;
memset(&sp, 0, sizeof(Scheme_Simple_Object));
sp.iso.so.type = tag;
if (flags) {
if (tag == scheme_pair_type)
SCHEME_PAIR_FLAGS(&sp) |= flags;
else
SCHEME_SET_IMMUTABLE(&sp);
}
return read_first_word((void *)&sp);
}
static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec, *ovec;
long len, i;
if (!SCHEME_VECTORP(argv[0]))
scheme_wrong_type("vector->immutable-vector", "vector", 0, argc, argv);
if (SCHEME_IMMUTABLEP(argv[0]))
return argv[0];
ovec = argv[0];
len = SCHEME_VEC_SIZE(ovec);
vec = scheme_make_vector(len, NULL);
for (i = 0; i < len; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(ovec)[i];
}
SCHEME_SET_IMMUTABLE(vec);
return vec;
}
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 */
}
Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Table *ht)
{
Scheme_Object *new_so = so;
if (SCHEME_INTP(so)) {
return so;
}
if (ht) {
Scheme_Object *r;
if ((r = scheme_hash_get(ht, so))) {
return r;
}
}
switch (so->type) {
case scheme_true_type:
case scheme_false_type:
case scheme_null_type:
case scheme_void_type:
/* place_bi_channels are allocated in the master and can be passed along as is */
case scheme_place_bi_channel_type:
new_so = so;
break;
case scheme_place_type:
new_so = ((Scheme_Place *) so)->channel;
break;
case scheme_char_type:
new_so = scheme_make_char(SCHEME_CHAR_VAL(so));
break;
case scheme_rational_type:
{
Scheme_Object *n;
Scheme_Object *d;
n = scheme_rational_numerator(so);
d = scheme_rational_denominator(so);
n = scheme_places_deep_copy_worker(n, ht);
d = scheme_places_deep_copy_worker(d, ht);
new_so = scheme_make_rational(n, d);
}
break;
case scheme_float_type:
new_so = scheme_make_float(SCHEME_FLT_VAL(so));
break;
case scheme_double_type:
new_so = scheme_make_double(SCHEME_DBL_VAL(so));
break;
case scheme_complex_type:
{
Scheme_Object *r;
Scheme_Object *i;
r = scheme_complex_real_part(so);
i = scheme_complex_imaginary_part(so);
r = scheme_places_deep_copy_worker(r, ht);
i = scheme_places_deep_copy_worker(i, ht);
new_so = scheme_make_complex(r, i);
}
break;
case scheme_char_string_type:
new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1);
break;
case scheme_byte_string_type:
if (SHARED_ALLOCATEDP(so)) {
new_so = so;
}
else {
new_so = scheme_make_sized_offset_byte_string(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
}
break;
case scheme_unix_path_type:
new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
break;
case scheme_symbol_type:
if (SCHEME_SYM_UNINTERNEDP(so)) {
scheme_log_abort("cannot copy uninterned symbol");
abort();
} else {
new_so = scheme_make_sized_offset_byte_string(SCHEME_SYM_VAL(so), 0, SCHEME_SYM_LEN(so), 1);
new_so->type = scheme_serialized_symbol_type;
}
break;
case scheme_serialized_symbol_type:
new_so = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(so), SCHEME_BYTE_STRLEN_VAL(so));
break;
case scheme_pair_type:
{
Scheme_Object *car;
Scheme_Object *cdr;
Scheme_Object *pair;
car = scheme_places_deep_copy_worker(SCHEME_CAR(so), ht);
cdr = scheme_places_deep_copy_worker(SCHEME_CDR(so), ht);
pair = scheme_make_pair(car, cdr);
new_so = pair;
}
break;
case scheme_vector_type:
{
Scheme_Object *vec;
intptr_t i;
intptr_t size = SCHEME_VEC_SIZE(so);
vec = scheme_make_vector(size, 0);
for (i = 0; i <size ; i++) {
Scheme_Object *tmp;
tmp = scheme_places_deep_copy_worker(SCHEME_VEC_ELS(so)[i], ht);
SCHEME_VEC_ELS(vec)[i] = tmp;
}
SCHEME_SET_IMMUTABLE(vec);
new_so = vec;
}
break;
case scheme_fxvector_type:
if (SHARED_ALLOCATEDP(so)) {
new_so = so;
}
else {
Scheme_Vector *vec;
intptr_t i;
intptr_t size = SCHEME_FXVEC_SIZE(so);
vec = scheme_alloc_fxvector(size);
for (i = 0; i < size; i++) {
SCHEME_FXVEC_ELS(vec)[i] = SCHEME_FXVEC_ELS(so)[i];
}
new_so = (Scheme_Object *) vec;
}
break;
case scheme_flvector_type:
if (SHARED_ALLOCATEDP(so)) {
new_so = so;
}
else {
Scheme_Double_Vector *vec;
intptr_t i;
intptr_t size = SCHEME_FLVEC_SIZE(so);
vec = scheme_alloc_flvector(size);
for (i = 0; i < size; i++) {
SCHEME_FLVEC_ELS(vec)[i] = SCHEME_FLVEC_ELS(so)[i];
}
new_so = (Scheme_Object *) vec;
}
break;
case scheme_structure_type:
{
Scheme_Structure *st = (Scheme_Structure*)so;
Scheme_Serialized_Structure *nst;
Scheme_Struct_Type *stype = st->stype;
Scheme_Struct_Type *ptype = stype->parent_types[stype->name_pos - 1];
Scheme_Object *nprefab_key;
intptr_t size = stype->num_slots;
int local_slots = stype->num_slots - (ptype ? ptype->num_slots : 0);
int i = 0;
if (!stype->prefab_key) {
scheme_log_abort("cannot copy non prefab structure");
abort();
}
{
for (i = 0; i < local_slots; i++) {
if (!stype->immutables || stype->immutables[i] != 1) {
scheme_log_abort("cannot copy mutable prefab structure");
abort();
}
}
}
nprefab_key = scheme_places_deep_copy_worker(stype->prefab_key, ht);
nst = (Scheme_Serialized_Structure*) scheme_make_serialized_struct_instance(nprefab_key, size);
for (i = 0; i <size ; i++) {
Scheme_Object *tmp;
tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht);
nst->slots[i] = tmp;
}
new_so = (Scheme_Object*) nst;
}
break;
case scheme_serialized_structure_type:
{
Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so;
Scheme_Struct_Type *stype;
Scheme_Structure *nst;
intptr_t size;
int i = 0;
size = st->num_slots;
stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size);
nst = (Scheme_Structure*) scheme_make_blank_prefab_struct_instance(stype);
for (i = 0; i <size ; i++) {
Scheme_Object *tmp;
tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht);
nst->slots[i] = tmp;
}
new_so = (Scheme_Object*)nst;
}
break;
case scheme_resolved_module_path_type:
default:
printf("places deep copy cannot copy object of type %hi at %p\n", so->type, so);
scheme_log_abort("places deep copy cannot copy object");
abort();
break;
}
if (ht) {
scheme_hash_set(ht, so, new_so);
}
return new_so;
}
