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; }