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;
}
long scheme_count_memory(Scheme_Object *root, Scheme_Hash_Table *ht)
{
Scheme_Type type;
long s = sizeof(Scheme_Simple_Object), e = 0;
int need_align = 0;
struct GC_Set *home;
if (!root || SCHEME_INTP(root))
return 0;
type = SCHEME_TYPE(root);
if (type >= _scheme_last_type_)
return 0;
if (ht && scheme_hash_get(ht, root))
return 0;
home = GC_set(root);
#if CAN_TRACE_HOME
if ((home != real_tagged)
&& (home != tagged_atomic)
&& (home != tagged_uncollectable)
&& (home != tagged_eternal)) {
scheme_console_printf("Bad Scheme object: %lx\n", (unsigned long)root);
return 0;
}
#endif
if (ht)
scheme_hash_set(ht, root, scheme_true);
#define COUNT(x) (ht ? scheme_count_memory((Scheme_Object *)x, ht) : 0)
switch (type) {
case scheme_variable_type:
s = sizeof(Scheme_Bucket);
#if FORCE_SUBPARTS
e = COUNT(((Scheme_Bucket *)root)->key)
+ COUNT(((Scheme_Bucket *)root)->val);
#endif
break;
case scheme_local_type:
case scheme_local_unbox_type:
s = sizeof(Scheme_Local);
break;
case scheme_syntax_type:
#if FORCE_KNOWN_SUBPARTS
e = COUNT(SCHEME_IPTR_VAL(root));
#endif
break;
case scheme_application_type:
{
Scheme_App_Rec *app = (Scheme_App_Rec *)root;
int i;
s = sizeof(Scheme_App_Rec) + (app->num_args * sizeof(Scheme_Object *))
+ (app->num_args + 1);
need_align = 1;
#if FORCE_KNOWN_SUBPARTS
e = COUNT(app->args[0]);
for (i = 1; i <= app->num_args; i++) {
e += COUNT(app->args[i]);
}
#endif
}
break;
case scheme_sequence_type:
case scheme_case_lambda_sequence_type:
case scheme_begin0_sequence_type:
{
Scheme_Sequence *seq = (Scheme_Sequence *)root;
int i;
s = sizeof(Scheme_Sequence) + (seq->count - 1) * sizeof(Scheme_Object *);
#if FORCE_KNOWN_SUBPARTS
for (i = e = 0; i < seq->count; i++) {
e += COUNT(seq->array[i]);
}
#endif
}
break;
case scheme_branch_type:
{
Scheme_Branch_Rec *rec = (Scheme_Branch_Rec *)root;
s = sizeof(Scheme_Branch_Rec);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(rec->test) + COUNT(rec->tbranch) + COUNT(rec->fbranch);
#endif
}
break;
case scheme_unclosed_procedure_type:
case scheme_compiled_unclosed_procedure_type:
{
Scheme_Closure_Data *data =
(Scheme_Closure_Data *)root;
s = sizeof(Scheme_Closure_Data);
s += data->closure_size * sizeof(mzshort);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(data->code);
#endif
}
break;
case scheme_let_value_type:
{
Scheme_Let_Value *let = (Scheme_Let_Value *)root;
s = sizeof(Scheme_Let_Value);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(let->value) + COUNT(let->body);
#endif
}
break;
case scheme_compiled_let_value_type:
{
Scheme_Compiled_Let_Value *let = (Scheme_Compiled_Let_Value *)root;
s = sizeof(Scheme_Compiled_Let_Value);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(let->value) + COUNT(let->body);
#endif
}
break;
case scheme_let_void_type:
{
Scheme_Let_Void *let = (Scheme_Let_Void *)root;
s = sizeof(Scheme_Let_Void);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(let->body);
#endif
}
break;
case scheme_compiled_let_void_type:
{
Scheme_Let_Header *let = (Scheme_Let_Header *)root;
s = sizeof(Scheme_Let_Header);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(let->body);
#endif
}
break;
case scheme_letrec_type:
{
Scheme_Letrec *let = (Scheme_Letrec *)root;
int i;
s = sizeof(Scheme_Letrec);
s += let->count * sizeof(Scheme_Object *);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(let->body);
for (i = 0; i < let->count; i++) {
e += COUNT(let->procs[i]);
}
#endif
}
break;
case scheme_char_type:
s = sizeof(Scheme_Small_Object);
break;
case scheme_integer_type:
s = 0;
break;
case scheme_double_type:
s = sizeof(Scheme_Double);
break;
case scheme_float_type:
break;
case scheme_char_string_type:
s += (SCHEME_CHAR_STRTAG_VAL(root) + 1) * sizeof(mzchar);
need_align = 1;
break;
case scheme_byte_string_type:
s += SCHEME_BYTE_STRTAG_VAL(root) + 1;
need_align = 1;
break;
case scheme_symbol_type:
s = sizeof(Scheme_Symbol) + SCHEME_SYM_LEN(root) - 1;
need_align = 1;
break;
case scheme_null_type:
break;
case scheme_pair_type:
#if FORCE_KNOWN_SUBPARTS
e = COUNT(SCHEME_CAR(root)) + COUNT(SCHEME_CDR(root));
#endif
break;
case scheme_vector_type:
{
int count = SCHEME_VEC_SIZE(root), i;
Scheme_Object **array = SCHEME_VEC_ELS(root);
s += count * sizeof(Scheme_Object*);
#if FORCE_KNOWN_SUBPARTS
for (i = e = 0; i < count; i++) {
e += COUNT(array[i]);
}
#endif
}
break;
case scheme_prim_type:
{
if (((Scheme_Primitive_Proc *)root)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
s = sizeof(Scheme_Prim_W_Result_Arity);
else
s = sizeof(Scheme_Primitive_Proc);
}
break;
case scheme_closure_type:
{
Scheme_Closure_Data *data;
Scheme_Object **vals;
data = SCHEME_COMPILED_CLOS_CODE(root);
vals = SCHEME_COMPILED_CLOS_ENV(root);
s += (data->closure_size * sizeof(Scheme_Object *));
#if FORCE_KNOWN_SUBPARTS
e = COUNT(data) + scheme_count_closure(vals, data->closure_size, ht);
#endif
}
break;
case scheme_closed_prim_type:
{
if (((Scheme_Closed_Primitive_Proc *)root)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
s = sizeof(Scheme_Closed_Prim_W_Result_Arity);
else
s = sizeof(Scheme_Closed_Primitive_Proc);
}
break;
case scheme_cont_type:
{
Scheme_Cont *c = (Scheme_Cont *)root;
Scheme_Saved_Stack *rs;
s = sizeof(Scheme_Cont);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(c->home);
#endif
for (rs = c->runstack_copied; rs; rs = rs->prev) {
s += sizeof(Scheme_Saved_Stack);
scheme_count_closure(rs->runstack,
rs->runstack_size
- (rs->runstack
- rs->runstack_start),
ht);
}
}
break;
case scheme_input_port_type:
scheme_count_input_port(root, &s, &e, ht);
break;
case scheme_output_port_type:
scheme_count_output_port(root, &s, &e, ht);
break;
case scheme_eof_type:
case scheme_true_type:
case scheme_false_type:
case scheme_void_type:
case scheme_undefined_type:
/* Only one */
break;
case scheme_syntax_compiler_type:
break;
case scheme_macro_type:
case scheme_set_macro_type:
s = sizeof(Scheme_Small_Object);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(SCHEME_PTR_VAL(root));
#endif
break;
case scheme_box_type:
s = sizeof(Scheme_Small_Object);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(SCHEME_BOX_VAL(root));
#endif
break;
case scheme_will_executor_type:
s = sizeof(Scheme_Simple_Object);
break;
case scheme_custodian_type:
{
Scheme_Custodian *m = (Scheme_Custodian *)root;
s = sizeof(Scheme_Custodian);
e = m->alloc * (sizeof(Scheme_Object **)
+ sizeof(Scheme_Custodian_Reference *)
+ sizeof(void *)
+ sizeof(void *));
}
break;
case scheme_thread_type:
{
Scheme_Thread *p = (Scheme_Thread *)root;
Scheme_Saved_Stack *saved;
s = sizeof(Scheme_Thread)
+ ((p->runstack_size + p->tail_buffer_size) * sizeof(Scheme_Object *));
#if FORCE_KNOWN_SUBPARTS
e = COUNT(p->init_config);
#endif
/* Check stack: */
scheme_count_closure(p->runstack, /* p->runstack may be wrong, but count_closure is turned off */
p->runstack_size
- (p->runstack
- p->runstack_start),
ht);
for (saved = p->runstack_saved; saved; saved = saved->prev) {
s += (saved->runstack_size * sizeof(Scheme_Object *));
scheme_count_closure(saved->runstack,
saved->runstack_size
- (saved->runstack
- saved->runstack_start),
ht);
}
}
break;
case scheme_namespace_type:
{
Scheme_Env *env = (Scheme_Env *)root;
s = sizeof(Scheme_Env);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(env->toplevel);
#endif
}
break;
case scheme_config_type:
{
s = sizeof(Scheme_Config) + (sizeof(Scheme_Object *) * __MZCONFIG_BUILTIN_COUNT__);
#if FORCE_SUBPARTS
{
Scheme_Config *c = (Scheme_Config *)root;
int i;
e = COUNT(c->extensions) + COUNT(c->base);
for (i = 0; i < __MZCONFIG_BUILTIN_COUNT__; i++) {
e += COUNT(*c->configs[i]);
}
}
#endif
}
break;
case scheme_proc_struct_type:
case scheme_structure_type:
{
Scheme_Object **slots = ((Scheme_Structure *)root)->slots;
int i, count = SCHEME_STRUCT_NUM_SLOTS(root);
s = sizeof(Scheme_Structure) + (count - 1) * sizeof(Scheme_Object *);
#if FORCE_KNOWN_SUBPARTS
for (i = e = 0; i < count; i++) {
e += COUNT(slots[i]);
}
e += COUNT(((Scheme_Structure *)root)->stype);
#endif
}
break;
case scheme_bignum_type:
{
int count = SCHEME_BIGLEN(root);
if (count < 0)
count = -count;
s = sizeof(Small_Bignum) + (count - 1) * sizeof(bigdig);
}
break;
case scheme_escaping_cont_type:
s = sizeof(Scheme_Escaping_Cont);
break;
case scheme_sema_type:
s = sizeof(Scheme_Sema);
break;
case scheme_compilation_top_type:
s = sizeof(Scheme_Compilation_Top);
break;
case scheme_hash_table_type:
{
Scheme_Hash_Table *ht = (Scheme_Hash_Table *)root;
s = sizeof(Scheme_Hash_Table)
+ ht->size * sizeof(Scheme_Object *);
#if FORCE_SUBPARTS
{
int i;
for (i = e = 0; i < ht->size; i++) {
if (ht->buckets[i]) {
if (ht->by_address)
e += COUNT(ht->buckets[i]);
else
e += COUNT(ht->buckets[i]->val);
}
}
}
#endif
}
break;
case scheme_weak_box_type:
s = sizeof(Scheme_Small_Object);
e = COUNT(SCHEME_BOX_VAL(root));
break;
case scheme_complex_type:
case scheme_complex_izi_type:
s = sizeof(Scheme_Complex);
e = COUNT(((Scheme_Complex *)root)->r) + COUNT(((Scheme_Complex *)root)->i);
break;
case scheme_rational_type:
s = sizeof(Scheme_Rational);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(((Scheme_Rational *)root)->num)
+ COUNT(((Scheme_Rational *)root)->denom);
#endif
break;
case scheme_struct_type_type:
{
Scheme_Struct_Type *st = (Scheme_Struct_Type *)root;
s = sizeof(Scheme_Struct_Type) + st->name_pos * sizeof(Scheme_Object*);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(st->name);
if (st->name_pos)
e += COUNT(st->parent_types[st->name_pos - 1]);
#endif
}
break;
case scheme_listener_type:
s = sizeof(Scheme_Small_Object);
break;
case scheme_random_state_type:
s = 130; /* wild guess */
break;
case scheme_eval_waiting_type:
case scheme_tail_call_waiting_type:
/* Only one */
break;
case scheme_multiple_values_type:
/* Only one */
break;
case scheme_placeholder_type:
s = 0; /* Infrequent */
break;
default:
s = 0;
break;
}
if (need_align) {
/* Round up to sizeof(void*) boundary: */
if (s & (sizeof(void*) - 1))
s += sizeof(void*) - (s & (sizeof(void*) - 1));
}
scheme_memory_count[type]++;
scheme_memory_size[type] += s;
return s;
}
