static void MrEdSchemeMessages(char *msg, ...) { GC_CAN_IGNORE va_list args; scheme_start_atomic(); XFORM_HIDE_EXPR(va_start(args, msg)); if (!console_out) { AllocConsole(); console_out = GetStdHandle(STD_OUTPUT_HANDLE); if (!wx_in_terminal) { has_stdio = 1; waiting_sema = CreateSemaphore(NULL, 0, 1, NULL); orig_signal_handle = scheme_get_signal_handle(); orig_break_handle = scheme_get_main_thread_break_handle(); SetConsoleCtrlHandler(ConsoleHandler, TRUE); { HMODULE hm; gcw_proc gcw; hm = LoadLibrary("kernel32.dll"); if (hm) gcw = (gcw_proc)GetProcAddress(hm, "GetConsoleWindow"); else gcw = NULL; if (gcw) console_hwnd = gcw(); } if (console_hwnd) { EnableMenuItem(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE, MF_BYCOMMAND | MF_GRAYED); RemoveMenu(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE, MF_BYCOMMAND); } } } if (!msg) { char *s; intptr_t l, d; DWORD wrote; s = va_arg(args, char*); d = va_arg(args, intptr_t); l = va_arg(args, intptr_t); WriteConsole(console_out, s XFORM_OK_PLUS d, l, &wrote, NULL); } else {
Scheme_Object *scheme_places_deep_copy_to_master(Scheme_Object *so) { #if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) Scheme_Object *o; void *original_gc; Scheme_Hash_Table *ht; ht = force_hash(so); original_gc = GC_switch_to_master_gc(); scheme_start_atomic(); o = scheme_places_deep_copy_worker(so, ht); scheme_end_atomic_no_swap(); GC_switch_back_from_master(original_gc); return o; #else return so; #endif }
/* unused code, may be useful when/if we revive shared symbol and prefab key tables */ Scheme_Struct_Type *scheme_make_prefab_struct_type_in_master(Scheme_Object *base, Scheme_Object *parent, int num_fields, int num_uninit_fields, Scheme_Object *uninit_val, char *immutable_array) { # ifdef MZ_PRECISE_GC void *original_gc; # endif Scheme_Object *cname; Scheme_Object *cuninit_val; char *cimm_array = NULL; int local_slots = num_fields + num_uninit_fields; Scheme_Struct_Type *stype; # ifdef MZ_PRECISE_GC original_gc = GC_switch_to_master_gc(); scheme_start_atomic(); # endif cname = scheme_places_deep_copy(base); cuninit_val = scheme_places_deep_copy(uninit_val); if (local_slots) { cimm_array = (char *)scheme_malloc_atomic(local_slots); memcpy(cimm_array, immutable_array, local_slots); } stype = scheme_make_prefab_struct_type_raw(cname, parent, num_fields, num_uninit_fields, cuninit_val, cimm_array); # ifdef MZ_PRECISE_GC scheme_end_atomic_no_swap(); GC_switch_back_from_master(original_gc); # endif return stype; }
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; }