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