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 */
}
Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
{
Scheme_Object *result = scheme_void;
#ifdef USE_TAGGED_ALLOCATION
void *initial_trace_root = NULL;
int (*inital_root_skip)(void *, size_t) = NULL;
#endif
scheme_start_atomic();
scheme_console_printf("Begin Dump\n");
if (scheme_external_dump_arg)
scheme_external_dump_arg(c ? p[0] : NULL);
#ifdef USE_TAGGED_ALLOCATION
trace_path_type = -1;
obj_type = -1;
if (c && SCHEME_SYMBOLP(p[0])) {
Scheme_Object *sym;
char *s;
int i, maxpos, just_objects;
sym = p[0];
s = scheme_symbol_val(sym);
maxpos = scheme_num_types();
if (maxpos > NUM_TYPE_SLOTS-1)
maxpos = NUM_TYPE_SLOTS-1;
just_objects = ((c > 1)
&& SCHEME_SYMBOLP(p[1])
&& !strcmp(SCHEME_SYM_VAL(p[1]), "objects"));
for (i = 0; i < maxpos; i++) {
void *tn = scheme_get_type_name(i);
if (tn && !strcmp(tn, s)) {
if (just_objects)
obj_type = i;
else
trace_path_type = i;
break;
}
}
if (SAME_OBJ(p[0], scheme_intern_symbol("stack"))) {
trace_path_type = -2;
}
if ((c > 2)
&& SCHEME_SYMBOLP(p[1])
&& !strcmp(SCHEME_SYM_VAL(p[1]), "from")) {
initial_trace_root = p[2];
if (SCHEME_THREADP(p[2])) {
local_thread = p[2];
local_thread_size = 0;
inital_root_skip = skip_foreign_thread;
}
}
}
{
int i;
int stack_c, roots_c, uncollectable_c, final_c;
long total_count = 0, total_size = 0;
long total_actual_count = 0, total_actual_size = 0;
long traced;
int no_walk = 0;
no_walk = 1 /* (!c || !SAME_OBJ(p[0], scheme_true)) */;
for (i = 0; i < NUM_TYPE_SLOTS; i++) {
scheme_memory_count[i] = scheme_memory_size[i] = 0;
scheme_memory_actual_size[i] = scheme_memory_actual_count[i] = 0;
scheme_memory_hi[i] = scheme_memory_lo[i] = 0;
}
scheme_envunbox_count = scheme_envunbox_size = 0;
bad_seeds = 0;
for (i = 0; i <= NUM_RECORDED_APP_SIZES; i++) {
app_sizes[i] = 0;
}
{
int j, k;
for (i = 0; i < NUM_RECORDED_APP_SIZES; i++) {
for (j = 0; j <= i; j++) {
for (k = 0; k <= 4; k++) {
app_arg_kinds[i][j][k] = 0;
}
}
}
}
traced = GC_trace_count(&stack_c, &roots_c, &uncollectable_c, &final_c);
GC_dump();
scheme_console_printf("\ntraced: %ld\n", traced);
tagged = tagged_while_counting;
if (!no_walk)
smc_ht = scheme_make_hash_table(SCHEME_hash_ptr);
if (tagged)
GC_for_each_element(real_tagged, count_tagged, NULL);
if (tagged_eternal)
GC_for_each_element(tagged_eternal, count_tagged, NULL);
if (tagged_uncollectable)
GC_for_each_element(tagged_uncollectable, count_tagged, NULL);
if (tagged_atomic)
GC_for_each_element(tagged_atomic, count_tagged, NULL);
if (envunbox)
GC_for_each_element(envunbox, count_envunbox, NULL);
tagged = real_tagged;
scheme_console_printf("Begin MzScheme\n");
scheme_console_printf("%30.30s %10s %10s %10s %8s - %8s\n",
"TYPE", "COUNT", "ESTM-SIZE", "TRACE-SIZE",
"LO-LOC", "HI-LOC");
for (i = 0; i < NUM_TYPE_SLOTS; i++) {
if (scheme_memory_count[i] || scheme_memory_actual_count[i]) {
scheme_console_printf("%30.30s %10ld %10ld %10ld %8lx - %8lx\n",
(i < NUM_TYPE_SLOTS-1)
? scheme_get_type_name(i)
: "other",
scheme_memory_actual_count[i],
scheme_memory_size[i],
scheme_memory_actual_size[i],
scheme_memory_lo[i],
scheme_memory_hi[i]);
if (scheme_memory_actual_count[i] != scheme_memory_count[i]) {
scheme_console_printf("%30.30s reach count: %10ld\n",
"", scheme_memory_count[i]);
}
total_count += scheme_memory_count[i];
total_size += scheme_memory_size[i];
total_actual_count += scheme_memory_actual_count[i];
total_actual_size += scheme_memory_actual_size[i];
}
}
scheme_console_printf("%30.30s %10ld %10ld -\n",
"envunbox", scheme_envunbox_count, scheme_envunbox_size);
total_count += scheme_envunbox_count;
total_size += scheme_envunbox_size;
scheme_console_printf("%30.30s - %10ld -\n",
"miscellaneous",
scheme_misc_count + scheme_type_table_count);
total_size += scheme_misc_count + scheme_type_table_count;
scheme_console_printf("%30.30s - - %10ld\n",
"roots", roots_c);
total_actual_size += roots_c;
scheme_console_printf("%30.30s - - %10ld\n",
"stack", stack_c);
total_actual_size += stack_c;
scheme_console_printf("%30.30s - - %10ld\n",
"unreached-uncollectable", uncollectable_c);
total_actual_size += uncollectable_c;
scheme_console_printf("%30.30s - - %10ld\n",
"finalization", final_c);
total_actual_size += final_c;
scheme_console_printf("%30.30s %10ld %10ld %10ld\n",
"total", total_count, total_size,
total_actual_size);
scheme_console_printf("End MzScheme\n");
scheme_console_printf("Begin Apps\n");
for (i = 0; i < NUM_RECORDED_APP_SIZES; i++) {
int j, k;
scheme_console_printf(" %d%s: %d", i,
(i == NUM_RECORDED_APP_SIZES ? "+" : ""),
app_sizes[i]);
for (j = 0; j <= i; j++) {
scheme_console_printf(" (");
for (k = 0; k <= 4; k++) {
if (k)
scheme_console_printf(",");
scheme_console_printf("%d", app_arg_kinds[i][j][k]);
}
scheme_console_printf(")");
}
scheme_console_printf("\n");
}
scheme_console_printf("End Apps\n");
{
Scheme_Custodian *m = (Scheme_Custodian *)scheme_get_param(scheme_current_config(), MZCONFIG_CUSTODIAN);
int c = 0, a = 0, u = 0, t = 0, ipt = 0, opt = 0, th = 0;
while (*m->parent)
m = *m->parent;
count_managed(m, &c, &a, &u, &t, &ipt, &opt, &th);
scheme_console_printf("custodians: %d managed: actual: %d breadth: %d room: %d\n"
" input-ports: %d output-ports: %d threads: %d\n"
"stacks: %d\n",
t, u, c, a, ipt, opt, th,
scheme_num_copied_stacks);
}
if (bad_seeds)
scheme_console_printf("ERROR: %ld illegal tags found\n", bad_seeds);
smc_ht = NULL;
}
#else
# if MZ_PRECISE_GC_TRACE
GC_trace_for_tag = -1;
if (c && SCHEME_SYMBOLP(p[0])) {
Scheme_Object *sym;
char *s;
int i, maxpos;
sym = p[0];
s = scheme_symbol_val(sym);
maxpos = scheme_num_types();
for (i = 0; i < maxpos; i++) {
void *tn;
tn = scheme_get_type_name(i);
if (tn && !strcmp(tn, s)) {
GC_trace_for_tag = i;
break;
}
}
} else if (SCHEME_INTP(p[0])) {
GC_trace_for_tag = SCHEME_INT_VAL(p[0]);
}
if ((c > 1) && SCHEME_INTP(p[1]))
GC_path_length_limit = SCHEME_INT_VAL(p[1]);
else
GC_path_length_limit = 1000;
#endif
GC_dump();
#endif
if (scheme_external_dump_info)
scheme_external_dump_info();
#ifdef USE_TAGGED_ALLOCATION
{
void **ps = NULL;
int l;
int max_w;
Scheme_Object *w;
GC_inital_root_skip = inital_root_skip;
GC_initial_trace_root = initial_trace_root;
GC_trace_path();
GC_inital_root_skip = NULL;
GC_initial_trace_root = NULL;
w = scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_WIDTH);
if (SCHEME_INTP(w))
max_w = SCHEME_INT_VAL(w);
else
max_w = 10000;
scheme_console_printf("Begin Paths\n");
while ((ps = GC_get_next_path(ps, &l))) {
int i, j;
if (l)
scheme_console_printf("$%s", ps[0]);
for (i = 1, j = 2; i < l; i++, j += 2) {
void *v = ps[j];
unsigned long diff = (unsigned long)ps[j + 1];
struct GC_Set *home;
home = GC_set(v);
if (home
&& ((home == real_tagged)
|| (home == tagged_atomic)
|| (home == tagged_uncollectable)
|| (home == tagged_eternal))) {
scheme_print_tagged_value("\n ->", v, 0, diff, max_w, "");
} else
scheme_print_tagged_value("\n ->", v, 1, diff, max_w, "");
}
scheme_console_printf("\n");
}
GC_clear_paths();
scheme_console_printf("End Paths\n");
}
scheme_console_printf("Begin Help\n");
scheme_console_printf(" (dump-memory-stats sym) - prints paths to instances of type named by sym.\n");
scheme_console_printf(" Examples: (dump-memory-stats '<pair>), (dump-memory-stats 'frame).\n");
scheme_console_printf(" If sym is 'stack, prints paths to thread stacks.\n");
scheme_console_printf(" (dump-memory-stats sym 'objects) - prints all instances of type named by sym.\n");
scheme_console_printf(" (dump-memory-stats sym 'from from-v) - prints paths, paths through from-v first.\n");
scheme_console_printf("End Help\n");
if (obj_type >= 0) {
result = scheme_null;
while (obj_buffer_pos--) {
result = scheme_make_pair((Scheme_Object *)(obj_buffer[obj_buffer_pos]), result);
}
}
#endif
# if MZ_PRECISE_GC_TRACE
scheme_console_printf("Begin Help\n");
scheme_console_printf(" (dump-memory-stats sym) - prints paths to instances of type named by sym.\n");
scheme_console_printf(" Example: (dump-memory-stats '<pair>)\n");
scheme_console_printf(" (dump-memory-stats num) - prints paths to objects with tag num.\n");
scheme_console_printf(" (dump-memory-stats -num) - prints paths to objects of size num.\n");
scheme_console_printf(" (dump-memory-stats sym/num len) - limits path to size len.\n");
scheme_console_printf("End Help\n");
# endif
scheme_console_printf("End Dump\n");
scheme_end_atomic();
return result;
}
int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
{
Scheme_Type t1, t2;
int cmp;
top:
if (eql->next_next) {
if (eql->next) {
Scheme_Object *a[2];
a[0] = obj1;
a[1] = obj2;
obj1 = _scheme_apply(eql->next, 2, a);
return SCHEME_TRUEP(obj1);
}
eql->next = eql->next_next;
}
cmp = is_eqv(obj1, obj2);
if (cmp > -1)
return cmp;
if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj1)
&& (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
|| (eql->for_chaperone > 1))) {
obj1 = ((Scheme_Chaperone *)obj1)->prev;
goto top;
}
t1 = SCHEME_TYPE(obj1);
t2 = SCHEME_TYPE(obj2);
if (NOT_SAME_TYPE(t1, t2)) {
if (!eql->for_chaperone) {
if (SCHEME_CHAPERONEP(obj1)) {
obj1 = ((Scheme_Chaperone *)obj1)->val;
goto top;
}
if (SCHEME_CHAPERONEP(obj2)) {
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top;
}
}
return 0;
} else if (t1 == scheme_pair_type) {
# include "mzeqchk.inc"
if ((eql->car_depth > 2) || !scheme_is_list(obj1)) {
if (union_check(obj1, obj2, eql))
return 1;
}
eql->car_depth += 2;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
eql->car_depth -= 2;
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
} else if (t1 == scheme_mutable_pair_type) {
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
} else if ((t1 == scheme_vector_type)
|| (t1 == scheme_fxvector_type)) {
# include "mzeqchk.inc"
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return vector_equal(obj1, obj2, eql);
} else if (t1 == scheme_flvector_type) {
intptr_t l1, l2, i;
l1 = SCHEME_FLVEC_SIZE(obj1);
l2 = SCHEME_FLVEC_SIZE(obj2);
if (l1 == l2) {
for (i = 0; i < l1; i++) {
if (!double_eqv(SCHEME_FLVEC_ELS(obj1)[i],
SCHEME_FLVEC_ELS(obj2)[i]))
return 0;
}
return 1;
}
return 0;
} else if ((t1 == scheme_byte_string_type)
|| ((t1 >= scheme_unix_path_type)
&& (t1 <= scheme_windows_path_type))) {
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
} else if (t1 == scheme_char_string_type) {
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
} else if (t1 == scheme_regexp_type) {
if (scheme_regexp_is_byte(obj1) != scheme_regexp_is_byte(obj2))
return 0;
if (scheme_regexp_is_pregexp(obj1) != scheme_regexp_is_pregexp(obj2))
return 0;
obj1 = scheme_regexp_source(obj1);
obj2 = scheme_regexp_source(obj2);
goto top;
} else if ((t1 == scheme_structure_type)
|| (t1 == scheme_proc_struct_type)) {
Scheme_Struct_Type *st1, *st2;
Scheme_Object *procs1, *procs2;
st1 = SCHEME_STRUCT_TYPE(obj1);
st2 = SCHEME_STRUCT_TYPE(obj2);
if (eql->for_chaperone == 1)
procs1 = NULL;
else
procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
if (procs1)
procs1 = apply_impersonator_of(eql->for_chaperone, procs1, obj1);
if (eql->for_chaperone)
procs2 = NULL;
else {
procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
if (procs2)
procs2 = apply_impersonator_of(eql->for_chaperone, procs2, obj2);
}
if (procs1 || procs2) {
/* impersonator-of property trumps other forms of checking */
if (procs1) obj1 = procs1;
if (procs2) obj2 = procs2;
goto top;
} else {
procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
if (procs1 && (st1 != st2)) {
procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
if (!procs2
|| !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
procs1 = NULL;
}
if (procs1) {
/* Has an equality property: */
Scheme_Object *a[3], *recur;
Equal_Info *eql2;
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
/* Create/cache closure to use for recursive equality checks: */
if (eql->recur) {
recur = eql->recur;
eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
} else {
eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
a[0] = (Scheme_Object *)eql2;
recur = scheme_make_prim_closure_w_arity(equal_recur,
1, a,
"equal?/recur",
2, 2);
eql->recur = recur;
}
memcpy(eql2, eql, sizeof(Equal_Info));
a[0] = obj1;
a[1] = obj2;
a[2] = recur;
procs1 = SCHEME_VEC_ELS(procs1)[1];
recur = _scheme_apply(procs1, 3, a);
memcpy(eql, eql2, sizeof(Equal_Info));
return SCHEME_TRUEP(recur);
} else if (st1 != st2) {
return 0;
} else if ((eql->for_chaperone == 1)
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
return 0;
} else {
/* Same types, but doesn't have an equality property
(or checking for chaperone), so check transparency: */
Scheme_Object *insp;
insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
if (scheme_inspector_sees_part(obj1, insp, -2)
&& scheme_inspector_sees_part(obj2, insp, -2)) {
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return struct_equal(obj1, obj2, eql);
} else
return 0;
}
}
} else if (t1 == scheme_box_type) {
SCHEME_USE_FUEL(1);
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
obj1 = SCHEME_BOX_VAL(obj1);
obj2 = SCHEME_BOX_VAL(obj2);
goto top;
} else if (t1 == scheme_hash_table_type) {
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, (Scheme_Hash_Table *)obj2, eql);
} else if (t1 == scheme_hash_tree_type) {
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, (Scheme_Hash_Tree *)obj2, eql);
} else if (t1 == scheme_bucket_table_type) {
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2, eql);
} else if (t1 == scheme_cpointer_type) {
return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1))
== ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2)));
} else if (t1 == scheme_wrap_chunk_type) {
return vector_equal(obj1, obj2, eql);
} else if (t1 == scheme_resolved_module_path_type) {
obj1 = SCHEME_PTR_VAL(obj1);
obj2 = SCHEME_PTR_VAL(obj2);
goto top;
} else if (t1 == scheme_place_bi_channel_type) {
Scheme_Place_Bi_Channel *bc1, *bc2;
bc1 = (Scheme_Place_Bi_Channel *)obj1;
bc2 = (Scheme_Place_Bi_Channel *)obj2;
return (SAME_OBJ(bc1->recvch, bc2->recvch)
&& SAME_OBJ(bc1->sendch, bc2->sendch));
} else if (!eql->for_chaperone && ((t1 == scheme_chaperone_type)
|| (t1 == scheme_proc_chaperone_type))) {
/* both chaperones */
obj1 = ((Scheme_Chaperone *)obj1)->val;
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top;
} else {
Scheme_Equal_Proc eqlp = scheme_type_equals[t1];
if (eqlp) {
if (union_check(obj1, obj2, eql))
return 1;
return eqlp(obj1, obj2, eql);
} else
return 0;
}
}
int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
{
Scheme_Type t1, t2;
int cmp;
Scheme_Object *orig_obj1, *orig_obj2;
top:
orig_obj1 = obj1;
orig_obj2 = obj2;
if (eql->next_next) {
if (eql->next) {
Scheme_Object *a[2];
a[0] = obj1;
a[1] = obj2;
obj1 = _scheme_apply(eql->next, 2, a);
return SCHEME_TRUEP(obj1);
}
eql->next = eql->next_next;
}
top_after_next:
cmp = is_fast_equal(obj1, obj2, eql->for_chaperone == 1);
if (cmp > -1)
return cmp;
if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj2)
&& scheme_is_noninterposing_chaperone(obj2)) {
obj2 = ((Scheme_Chaperone *)obj2)->prev;
goto top_after_next;
}
if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj1)
&& (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
|| (eql->for_chaperone > 1))) {
/* `obj1` and `obj2` are not eq, otherwise is_fast_equal()
would have returned true */
if (SCHEME_CHAPERONEP(obj2)) {
/* for immutable hashes, it's ok for the two objects to not be eq,
as long as the interpositions are the same and the underlying
values are `{impersonator,chaperone}-of?`: */
if (SCHEME_HASHTRP(((Scheme_Chaperone *)obj1)->val)
&& SCHEME_HASHTRP(((Scheme_Chaperone *)obj2)->val)
/* eq redirects means redirects were propagated: */
&& SAME_OBJ(((Scheme_Chaperone *)obj1)->redirects,
((Scheme_Chaperone *)obj2)->redirects))
obj2 = ((Scheme_Chaperone *)obj2)->prev;
}
obj1 = ((Scheme_Chaperone *)obj1)->prev;
goto top_after_next;
}
t1 = SCHEME_TYPE(obj1);
t2 = SCHEME_TYPE(obj2);
if (NOT_SAME_TYPE(t1, t2)) {
if (!eql->for_chaperone) {
if (SCHEME_CHAPERONEP(obj1)) {
obj1 = ((Scheme_Chaperone *)obj1)->val;
goto top_after_next;
} else if (t1 == scheme_hash_tree_indirection_type) {
obj1 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj1);
goto top_after_next;
}
if (SCHEME_CHAPERONEP(obj2)) {
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top_after_next;
} else if (t2 == scheme_hash_tree_indirection_type) {
obj2 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj2);
goto top_after_next;
}
}
return 0;
} else {
switch (t1) {
case scheme_pair_type:
{
# include "mzeqchk.inc"
if ((eql->car_depth > 2) || !scheme_is_list(obj1)) {
if (union_check(obj1, obj2, eql))
return 1;
}
eql->car_depth += 2;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
eql->car_depth -= 2;
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
}
case scheme_mutable_pair_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
}
case scheme_vector_type:
case scheme_fxvector_type:
{
# include "mzeqchk.inc"
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return vector_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
}
case scheme_byte_string_type:
case scheme_unix_path_type:
case scheme_windows_path_type:
{
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
}
case scheme_char_string_type:
{
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
}
case scheme_regexp_type:
{
if (scheme_regexp_is_byte(obj1) != scheme_regexp_is_byte(obj2))
return 0;
if (scheme_regexp_is_pregexp(obj1) != scheme_regexp_is_pregexp(obj2))
return 0;
obj1 = scheme_regexp_source(obj1);
obj2 = scheme_regexp_source(obj2);
goto top;
}
case scheme_structure_type:
case scheme_proc_struct_type:
{
Scheme_Struct_Type *st1, *st2;
Scheme_Object *procs1, *procs2;
st1 = SCHEME_STRUCT_TYPE(obj1);
st2 = SCHEME_STRUCT_TYPE(obj2);
if (eql->for_chaperone == 1)
procs1 = NULL;
else
procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
if (procs1)
procs1 = scheme_apply_impersonator_of(eql->for_chaperone, procs1, obj1);
if (eql->for_chaperone)
procs2 = NULL;
else {
procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
if (procs2)
procs2 = scheme_apply_impersonator_of(eql->for_chaperone, procs2, obj2);
}
if (procs1 || procs2) {
/* impersonator-of property trumps other forms of checking */
if (procs1) { obj1 = procs1; orig_obj1 = obj1; }
if (procs2) { obj2 = procs2; orig_obj2 = obj2; }
goto top_after_next;
} else {
procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
if (procs1 && (st1 != st2)) {
procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
if (!procs2
|| !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
procs1 = NULL;
}
if (procs1) {
/* Has an equality property: */
Scheme_Object *a[3], *recur;
Equal_Info *eql2;
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
/* Create/cache closure to use for recursive equality checks: */
if (eql->recur) {
recur = eql->recur;
eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
} else {
eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
a[0] = (Scheme_Object *)eql2;
recur = scheme_make_prim_closure_w_arity(equal_recur,
1, a,
"equal?/recur",
2, 2);
eql->recur = recur;
}
memcpy(eql2, eql, sizeof(Equal_Info));
a[0] = orig_obj1;
a[1] = orig_obj2;
a[2] = recur;
procs1 = SCHEME_VEC_ELS(procs1)[1];
recur = _scheme_apply(procs1, 3, a);
memcpy(eql, eql2, sizeof(Equal_Info));
return SCHEME_TRUEP(recur);
} else if (st1 != st2) {
return 0;
} else if ((eql->for_chaperone == 1)
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
return 0;
} else {
/* Same types, but doesn't have an equality property
(or checking for chaperone), so check transparency: */
Scheme_Object *insp;
if (scheme_struct_is_transparent(obj1))
insp = NULL;
else {
insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
}
if (!insp || scheme_inspector_sees_part(obj1, insp, -2)) {
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return struct_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
} else
return 0;
}
}
}
case scheme_box_type:
{
SCHEME_USE_FUEL(1);
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (SAME_OBJ(obj1, orig_obj1))
obj1 = SCHEME_BOX_VAL(obj1);
else
obj1 = scheme_unbox(orig_obj1);
if (SAME_OBJ(obj2, orig_obj2))
obj2 = SCHEME_BOX_VAL(obj2);
else
obj2 = scheme_unbox(orig_obj2);
goto top;
}
case scheme_hash_table_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, orig_obj1,
(Scheme_Hash_Table *)obj2, orig_obj2,
eql);
}
case scheme_hash_tree_type:
case scheme_eq_hash_tree_type:
case scheme_eqv_hash_tree_type:
case scheme_hash_tree_indirection_type:
{
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, orig_obj1,
(Scheme_Hash_Tree *)obj2, orig_obj2,
eql);
}
case scheme_bucket_table_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, orig_obj1,
(Scheme_Bucket_Table *)obj2, orig_obj2,
eql);
}
case scheme_wrap_chunk_type: {
return vector_equal(obj1, obj1, obj2, obj2, eql);
}
case scheme_resolved_module_path_type:
{
obj1 = SCHEME_PTR_VAL(obj1);
obj2 = SCHEME_PTR_VAL(obj2);
goto top;
}
case scheme_module_index_type:
{
Scheme_Modidx *midx1, *midx2;
# include "mzeqchk.inc"
midx1 = (Scheme_Modidx *)obj1;
midx2 = (Scheme_Modidx *)obj2;
if (eql->eq_for_modidx
&& (SCHEME_FALSEP(midx1->path)
|| SCHEME_FALSEP(midx2->path)))
return 0;
else if (is_equal(midx1->path, midx2->path, eql)) {
obj1 = midx1->base;
obj2 = midx2->base;
goto top;
}
}
case scheme_scope_table_type:
{
Scheme_Scope_Table *mt1 = (Scheme_Scope_Table *)obj1;
Scheme_Scope_Table *mt2 = (Scheme_Scope_Table *)obj2;
if (!is_equal((Scheme_Object *)mt1->simple_scopes, (Scheme_Object *)mt2->simple_scopes, eql))
return 0;
obj1 = mt1->multi_scopes;
obj2 = mt2->multi_scopes;
goto top;
}
default:
if (!eql->for_chaperone && ((t1 == scheme_chaperone_type)
|| (t1 == scheme_proc_chaperone_type))) {
/* both chaperones */
obj1 = ((Scheme_Chaperone *)obj1)->val;
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top_after_next;
} else {
Scheme_Equal_Proc eqlp = scheme_type_equals[t1];
if (eqlp) {
if (union_check(obj1, obj2, eql))
return 1;
return eqlp(obj1, obj2, eql);
} else
return 0;
}
}
}
}
