Scheme_Object *scheme_places_deep_copy(Scheme_Object *so) {
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
Scheme_Object *new_so = so;
if (SCHEME_INTP(so)) {
return so;
}
switch (so->type) {
case scheme_pair_type:
case scheme_vector_type:
case scheme_struct_type_type:
case scheme_structure_type:
{
Scheme_Hash_Table *ht;
ht = scheme_make_hash_table(SCHEME_hash_ptr);
new_so = scheme_places_deep_copy_worker(so, ht);
}
break;
default:
new_so = scheme_places_deep_copy_worker(so, NULL);
break;
}
return new_so;
#else
return so;
#endif
}
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 Scheme_Object *make_hash_table(int argc, Scheme_Object *argv[])
{
int flags[2] = { 0 /* weak */ , 0 /* equal */ };
check_hash_table_flags("make-hash-table", 0, argc, argv, flags);
if (flags[0]) {
/* Weak */
Scheme_Bucket_Table *t;
t = scheme_make_bucket_table(20, SCHEME_hash_weak_ptr);
if (flags[1]) {
Scheme_Object *sema;
sema = scheme_make_sema(1);
t->mutex = sema;
t->compare = compare_equal;
t->make_hash_indices = make_hash_indices_for_equal;
}
return (Scheme_Object *)t;
} else {
/* Normal */
if (flags[1])
return (Scheme_Object *)scheme_make_hash_table_equal();
else
return (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr);
}
}
Scheme_Hash_Table *scheme_make_hash_table_equal()
{
Scheme_Hash_Table *t;
Scheme_Object *sema;
t = scheme_make_hash_table(SCHEME_hash_ptr);
sema = scheme_make_sema(1);
t->mutex = sema;
t->compare = compare_equal;
t->make_hash_indices = make_hash_indices_for_equal;
return t;
}
Scheme_Hash_Table *force_hash(Scheme_Object *so) {
if (SCHEME_INTP(so)) {
return NULL;
}
switch (so->type) {
case scheme_pair_type:
case scheme_vector_type:
case scheme_struct_type_type:
case scheme_structure_type:
{
Scheme_Hash_Table *ht;
ht = scheme_make_hash_table(SCHEME_hash_ptr);
force_hash_worker(so, ht);
return ht;
}
break;
default:
break;
}
return NULL;
}
static int union_check(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
{
if (eql->depth < 50) {
if (!eql->next_next)
eql->depth += 2;
return 0;
} else {
Scheme_Hash_Table *ht = eql->ht;
if (!ht) {
ht = scheme_make_hash_table(SCHEME_hash_ptr);
eql->ht = ht;
}
obj1 = union_find(obj1, ht);
obj2 = union_find(obj2, ht);
if (SAME_OBJ(obj1, obj2))
return 1;
scheme_hash_set(ht, obj2, obj1);
return 0;
}
}
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;
}
