/** * 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 void *place_start_proc_after_stack(void *data_arg, void *stack_base) { Place_Start_Data *place_data; Scheme_Object *place_main; Scheme_Object *a[2], *channel; mzrt_thread_id ptid; intptr_t rc = 0; ptid = mz_proc_thread_self(); place_data = (Place_Start_Data *) data_arg; data_arg = NULL; /* printf("Startin place: proc thread id%u\n", ptid); */ /* create pristine THREAD_LOCAL variables*/ null_out_runtime_globals(); /* scheme_make_thread behaves differently if the above global vars are not null */ scheme_place_instance_init(stack_base); a[0] = scheme_places_deep_copy(place_data->current_library_collection_paths); scheme_current_library_collection_paths(1, a); a[0] = scheme_places_deep_copy(place_data->module); a[1] = scheme_places_deep_copy(place_data->function); a[1] = scheme_intern_exact_symbol(SCHEME_SYM_VAL(a[1]), SCHEME_SYM_LEN(a[1])); if (!SAME_TYPE(SCHEME_TYPE(place_data->channel), scheme_place_bi_channel_type)) { channel = scheme_places_deep_copy(place_data->channel); } else { channel = place_data->channel; } mzrt_sema_post(place_data->ready); place_data = NULL; # ifdef MZ_PRECISE_GC /* this prevents a master collection attempt from deadlocking with the place_data->ready semaphore above */ GC_allow_master_gc_check(); # endif /* at point point, don't refer to place_data or its content anymore, because it's allocated in the other place */ scheme_set_root_param(MZCONFIG_EXIT_HANDLER, scheme_def_place_exit_proc); { Scheme_Thread * volatile p; mz_jmp_buf * volatile saved_error_buf; mz_jmp_buf new_error_buf; p = scheme_get_current_thread(); saved_error_buf = p->error_buf; p->error_buf = &new_error_buf; if (!scheme_setjmp(new_error_buf)) { Scheme_Object *dynamic_require; dynamic_require = scheme_builtin_value("dynamic-require"); place_main = scheme_apply(dynamic_require, 2, a); a[0] = channel; scheme_apply(place_main, 1, a); } else { rc = 1; } p->error_buf = saved_error_buf; } /*printf("Leavin place: proc thread id%u\n", ptid);*/ scheme_place_instance_destroy(); return (void*) rc; }
void scheme_print_tagged_value(const char *prefix, void *v, int xtagged, unsigned long diff, int max_w, const char *suffix) { char *type, *sep, diffstr[30]; long len; sep = ""; scheme_check_print_is_obj = check_home; if (!xtagged) { type = scheme_write_to_string_w_max((Scheme_Object *)v, &len, max_w); if (!scheme_strncmp(type, "#<thread", 8)) { char buffer[256]; char *run, *sus, *kill, *clean, *deq, *all, *t2; int state = ((Scheme_Thread *)v)->running, len2; run = (state & MZTHREAD_RUNNING) ? "+run" : ""; sus = (state & MZTHREAD_SUSPENDED) ? "+suspended" : ""; kill = (state & MZTHREAD_KILLED) ? "+killed" : ""; clean = (state & MZTHREAD_NEED_KILL_CLEANUP) ? "+cleanup" : ""; deq = (((Scheme_Thread *)v)->next || ((Scheme_Thread *)v)->prev) ? "" : "+deq"; all = !state ? "defunct" : ""; sprintf(buffer, "[%d=%s%s%s%s%s%s]", state, run, sus, kill, clean, all, deq); len2 = strlen(buffer); t2 = (char *)scheme_malloc_atomic(len + len2 + 1); memcpy(t2, type, len); memcpy(t2 + len, buffer, len2 + 1); len += len2; type = t2; } else if (!scheme_strncmp(type, "#<namespace", 11)) { char buffer[256]; char *t2; int len2; sprintf(buffer, "[%ld:%.100s]", ((Scheme_Env *)v)->phase, (((Scheme_Env *)v)->module ? SCHEME_SYM_VAL(((Scheme_Env *)v)->module->modname) : "(toplevel)")); len2 = strlen(buffer); t2 = (char *)scheme_malloc_atomic(len + len2 + 1); memcpy(t2, type, len); memcpy(t2 + len, buffer, len2 + 1); len += len2; type = t2; } else if (!scheme_strncmp(type, "#<global-variable-code", 22)) { Scheme_Bucket *b = (Scheme_Bucket *)v; Scheme_Object *bsym = (Scheme_Object *)b->key; char *t2; int len2; len2 = SCHEME_SYM_LEN(bsym); t2 = scheme_malloc_atomic(len + len2 + 3); memcpy(t2, type, len); memcpy(t2 + len + 1, SCHEME_SYM_VAL(bsym), len2); t2[len] = '['; t2[len + 1 + len2] = ']'; t2[len + 1 + len2 + 1] = 0; len += len2; type = t2; } else if (!scheme_strncmp(type, "#<hash-table>", 13) || !scheme_strncmp(type, "#<hash-table:", 13)) { char buffer[256]; char *t2; int len2; int htype, size, count; if (SCHEME_HASHTP((Scheme_Object *)v)) { htype = 'n'; size = ((Scheme_Hash_Table *)v)->size; count = ((Scheme_Hash_Table *)v)->count; } else { htype = 'b'; size = ((Scheme_Bucket_Table *)v)->size; count = ((Scheme_Bucket_Table *)v)->count; } sprintf(buffer, "[%c:%d:%d]", htype, count, size); len2 = strlen(buffer); t2 = scheme_malloc_atomic(len + len2 + 1); memcpy(t2, type, len); memcpy(t2 + len, buffer, len2 + 1); len += len2; type = t2; } else if (!scheme_strncmp(type, "#<syntax", 8)) { char *t2, *t3; long len2, len3; t2 = scheme_write_to_string_w_max(SCHEME_STX_VAL(v), &len2, 32); len3 = len + len2 + 2; t3 = (char *)scheme_malloc_atomic(len3); memcpy(t3, type, len); t3[len] = '='; memcpy(t3 + len + 1, t2, len2); t3[len + len2 + 1] = 0; type = t3; len = len3; } sep = "="; } else if (scheme_external_dump_type) { type = scheme_external_dump_type(v); if (*type) sep = ":"; } else type = ""; if (diff) sprintf(diffstr, "%lx", diff); object_console_printf(stderr, "%s%p%s%s%s%s%s", prefix, v, sep, type, diff ? "+" : "", diff ? diffstr : "", suffix); scheme_check_print_is_obj = NULL; }
Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Table *ht) { Scheme_Object *new_so = so; if (SCHEME_INTP(so)) { return so; } if (ht) { Scheme_Object *r; if ((r = scheme_hash_get(ht, so))) { return r; } } switch (so->type) { case scheme_true_type: case scheme_false_type: case scheme_null_type: case scheme_void_type: /* place_bi_channels are allocated in the master and can be passed along as is */ case scheme_place_bi_channel_type: new_so = so; break; case scheme_place_type: new_so = ((Scheme_Place *) so)->channel; break; case scheme_char_type: new_so = scheme_make_char(SCHEME_CHAR_VAL(so)); break; case scheme_rational_type: { Scheme_Object *n; Scheme_Object *d; n = scheme_rational_numerator(so); d = scheme_rational_denominator(so); n = scheme_places_deep_copy_worker(n, ht); d = scheme_places_deep_copy_worker(d, ht); new_so = scheme_make_rational(n, d); } break; case scheme_float_type: new_so = scheme_make_float(SCHEME_FLT_VAL(so)); break; case scheme_double_type: new_so = scheme_make_double(SCHEME_DBL_VAL(so)); break; case scheme_complex_type: { Scheme_Object *r; Scheme_Object *i; r = scheme_complex_real_part(so); i = scheme_complex_imaginary_part(so); r = scheme_places_deep_copy_worker(r, ht); i = scheme_places_deep_copy_worker(i, ht); new_so = scheme_make_complex(r, i); } break; case scheme_char_string_type: new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1); break; case scheme_byte_string_type: if (SHARED_ALLOCATEDP(so)) { new_so = so; } else { new_so = scheme_make_sized_offset_byte_string(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1); } break; case scheme_unix_path_type: new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1); break; case scheme_symbol_type: if (SCHEME_SYM_UNINTERNEDP(so)) { scheme_log_abort("cannot copy uninterned symbol"); abort(); } else { new_so = scheme_make_sized_offset_byte_string(SCHEME_SYM_VAL(so), 0, SCHEME_SYM_LEN(so), 1); new_so->type = scheme_serialized_symbol_type; } break; case scheme_serialized_symbol_type: new_so = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(so), SCHEME_BYTE_STRLEN_VAL(so)); break; case scheme_pair_type: { Scheme_Object *car; Scheme_Object *cdr; Scheme_Object *pair; car = scheme_places_deep_copy_worker(SCHEME_CAR(so), ht); cdr = scheme_places_deep_copy_worker(SCHEME_CDR(so), ht); pair = scheme_make_pair(car, cdr); new_so = pair; } break; case scheme_vector_type: { Scheme_Object *vec; intptr_t i; intptr_t size = SCHEME_VEC_SIZE(so); vec = scheme_make_vector(size, 0); for (i = 0; i <size ; i++) { Scheme_Object *tmp; tmp = scheme_places_deep_copy_worker(SCHEME_VEC_ELS(so)[i], ht); SCHEME_VEC_ELS(vec)[i] = tmp; } SCHEME_SET_IMMUTABLE(vec); new_so = vec; } break; case scheme_fxvector_type: if (SHARED_ALLOCATEDP(so)) { new_so = so; } else { Scheme_Vector *vec; intptr_t i; intptr_t size = SCHEME_FXVEC_SIZE(so); vec = scheme_alloc_fxvector(size); for (i = 0; i < size; i++) { SCHEME_FXVEC_ELS(vec)[i] = SCHEME_FXVEC_ELS(so)[i]; } new_so = (Scheme_Object *) vec; } break; case scheme_flvector_type: if (SHARED_ALLOCATEDP(so)) { new_so = so; } else { Scheme_Double_Vector *vec; intptr_t i; intptr_t size = SCHEME_FLVEC_SIZE(so); vec = scheme_alloc_flvector(size); for (i = 0; i < size; i++) { SCHEME_FLVEC_ELS(vec)[i] = SCHEME_FLVEC_ELS(so)[i]; } new_so = (Scheme_Object *) vec; } break; case scheme_structure_type: { Scheme_Structure *st = (Scheme_Structure*)so; Scheme_Serialized_Structure *nst; Scheme_Struct_Type *stype = st->stype; Scheme_Struct_Type *ptype = stype->parent_types[stype->name_pos - 1]; Scheme_Object *nprefab_key; intptr_t size = stype->num_slots; int local_slots = stype->num_slots - (ptype ? ptype->num_slots : 0); int i = 0; if (!stype->prefab_key) { scheme_log_abort("cannot copy non prefab structure"); abort(); } { for (i = 0; i < local_slots; i++) { if (!stype->immutables || stype->immutables[i] != 1) { scheme_log_abort("cannot copy mutable prefab structure"); abort(); } } } nprefab_key = scheme_places_deep_copy_worker(stype->prefab_key, ht); nst = (Scheme_Serialized_Structure*) scheme_make_serialized_struct_instance(nprefab_key, size); for (i = 0; i <size ; i++) { Scheme_Object *tmp; tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht); nst->slots[i] = tmp; } new_so = (Scheme_Object*) nst; } break; case scheme_serialized_structure_type: { Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so; Scheme_Struct_Type *stype; Scheme_Structure *nst; intptr_t size; int i = 0; size = st->num_slots; stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size); nst = (Scheme_Structure*) scheme_make_blank_prefab_struct_instance(stype); for (i = 0; i <size ; i++) { Scheme_Object *tmp; tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht); nst->slots[i] = tmp; } new_so = (Scheme_Object*)nst; } break; case scheme_resolved_module_path_type: default: printf("places deep copy cannot copy object of type %hi at %p\n", so->type, so); scheme_log_abort("places deep copy cannot copy object"); abort(); break; } if (ht) { scheme_hash_set(ht, so, new_so); } return new_so; }
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; }