char *
scheme_strdup(const char *str)
{
char *naya;
long len;
len = strlen(str) + 1;
naya = (char *)scheme_malloc_atomic (len * sizeof (char));
memcpy (naya, str, len);
return naya;
}
SFS_Info *scheme_new_sfs_info(int depth)
{
SFS_Info *info;
int *max_used, *max_calls;
info = MALLOC_ONE_RT(SFS_Info);
SET_REQUIRED_TAG(info->type = scheme_rt_sfs_info);
info->depth = depth;
info->stackpos = depth;
info->tlpos = depth;
max_used = (int *)scheme_malloc_atomic(sizeof(int) * depth);
max_calls = (int *)scheme_malloc_atomic(sizeof(int) * depth);
memset(max_used, 0, sizeof(int) * depth);
memset(max_calls, 0, sizeof(int) * depth);
info->max_used = max_used;
info->max_calls = max_calls;
return info;
}
static void *prepare_retry_alloc(void *p, void *p2)
{
/* Allocate enough to trigger a new page */
intptr_t avail, algn;
algn = GC_alloc_alignment();
avail = algn - (GC_gen0_alloc_page_ptr & (algn - 1));
if (!avail)
avail = 1;
else if (avail == algn)
avail = 1;
if (avail > sizeof(intptr_t))
avail -= sizeof(intptr_t);
/* We assume that atomic memory and tagged go to the same nursery: */
scheme_malloc_atomic(avail);
retry_alloc_r1 = p2;
return p;
}
/* 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;
}
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;
}