/** * Given some kind of Scheme string value, convert it to a C string * If scmval is not a string value, returns NULL. */ static char * scheme_object_to_string (Scheme_Object *scmval) { char *str = NULL; // Char strings are the normal Scheme strings. They need to be // converted to byte strings. if (SCHEME_CHAR_STRINGP (scmval)) { scmval = scheme_char_string_to_byte_string_locale (scmval); str = SCHEME_BYTE_STR_VAL (scmval); } // if it's a char string // Byte strings are easy, but not the typical Scheme strings. else if (SCHEME_BYTE_STRINGP (scmval)) { str = SCHEME_BYTE_STR_VAL (scmval); } // if it's a byte string // A design decision: We'll treat symbols as strings. (It certainly // makes things easier for the client.) else if (SCHEME_SYMBOLP (scmval)) { str = SCHEME_SYM_VAL (scmval); } // if it's a symbol // Everything else is not a string else { // Signal an error by setting the return value to NULL. str = NULL; } // if it's not a string return str; } // scheme_object_to_string
static Scheme_Object *write_compiled_closure(Scheme_Object *obj) { Scheme_Closure_Data *data; Scheme_Object *name, *l, *code, *ds, *tl_map; int svec_size, pos; Scheme_Marshal_Tables *mt; data = (Scheme_Closure_Data *)obj; if (data->name) { name = data->name; if (SCHEME_VECTORP(name)) { /* We can only save marshalable src names, which includes paths, symbols, and strings: */ Scheme_Object *src; src = SCHEME_VEC_ELS(name)[1]; if (!SCHEME_PATHP(src) && !SCHEME_PATHP(src) && !SCHEME_SYMBOLP(src)) { /* Just keep the name */ name = SCHEME_VEC_ELS(name)[0]; } } } else { name = scheme_null; } svec_size = data->closure_size; if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { svec_size += ((2 * (data->num_params + data->closure_size)) + BITS_PER_MZSHORT - 1) / BITS_PER_MZSHORT; } if (SCHEME_RPAIRP(data->code)) { /* This can happen if loaded bytecode is printed out and the procedure body has never been needed before. It's also possible in non-JIT mode if an empty closure is embedded as a 3-D value in compiled code. */ scheme_delay_load_closure(data); } /* If the body is simple enough, write it directly. Otherwise, create a delay indirection so that the body is loaded on demand. */ code = data->code; switch (SCHEME_TYPE(code)) { case scheme_toplevel_type: case scheme_local_type: case scheme_local_unbox_type: case scheme_integer_type: case scheme_true_type: case scheme_false_type: case scheme_void_type: case scheme_quote_syntax_type: ds = code; break; default: ds = NULL; break; } if (!ds) { mt = scheme_current_thread->current_mt; if (!mt->pass) { int key; pos = mt->cdata_counter; if ((!mt->cdata_map || (pos >= 32)) && !(pos & (pos - 1))) { /* Need to grow the array */ Scheme_Object **a; a = MALLOC_N(Scheme_Object *, (pos ? 2 * pos : 32)); memcpy(a, mt->cdata_map, pos * sizeof(Scheme_Object *)); mt->cdata_map = a; }
Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { Scheme_Place *place; Place_Start_Data *place_data; mz_proc_thread *proc_thread; Scheme_Object *collection_paths; mzrt_sema *ready; /* create place object */ place = MALLOC_ONE_TAGGED(Scheme_Place); place->so.type = scheme_place_type; mzrt_sema_create(&ready, 0); /* pass critical info to new place */ place_data = MALLOC_ONE(Place_Start_Data); place_data->ready = ready; if (argc == 2) { Scheme_Object *so; if (!scheme_is_module_path(args[0]) && !SCHEME_PATHP(args[0])) { scheme_wrong_type("place", "module-path or path", 0, argc, args); } if (!SCHEME_SYMBOLP(args[1])) { scheme_wrong_type("place", "symbol", 1, argc, args); } so = scheme_places_deep_copy_to_master(args[0]); place_data->module = so; so = scheme_places_deep_copy_to_master(args[1]); place_data->function = so; place_data->ready = ready; /* create channel */ { Scheme_Place_Bi_Channel *channel; channel = scheme_place_bi_channel_create(); place->channel = (Scheme_Object *) channel; channel = scheme_place_bi_peer_channel_create(channel); place_data->channel = (Scheme_Object *) channel; } } else { scheme_wrong_count_m("place", 2, 2, argc, args, 0); } collection_paths = scheme_current_library_collection_paths(0, NULL); collection_paths = scheme_places_deep_copy_to_master(collection_paths); place_data->current_library_collection_paths = collection_paths; /* create new place */ proc_thread = mz_proc_thread_create(place_start_proc, place_data); /* wait until the place has started and grabbed the value from `place_data'; it's important that a GC doesn't happen here until the other place is far enough. */ mzrt_sema_wait(ready); mzrt_sema_destroy(ready); place->proc_thread = proc_thread; return (Scheme_Object*) place; }
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; }