static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec, *ovec, *v;
intptr_t len, i;
vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_contract("vector->immutable-vector", "vector?", 0, argc, argv);
if (SCHEME_IMMUTABLEP(vec))
return argv[0];
ovec = vec;
len = SCHEME_VEC_SIZE(ovec);
vec = scheme_make_vector(len, NULL);
if (!SAME_OBJ(ovec, argv[0])) {
for (i = 0; i < len; i++) {
v = scheme_chaperone_vector_ref(argv[0], i);
SCHEME_VEC_ELS(vec)[i] = v;
}
} else {
for (i = 0; i < len; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(ovec)[i];
}
}
SCHEME_SET_IMMUTABLE(vec);
return vec;
}
Scheme_Object *scheme_jit_make_two_element_vector(Scheme_Object *a, Scheme_Object *b)
{
Scheme_Object *vec;
vec = scheme_make_vector(2, a);
SCHEME_VEC_ELS(vec)[1] = b;
return vec;
}
static Scheme_Object *clone_inline_variant(Scheme_Object *obj, Scheme_Object *naya)
{
Scheme_Object *naya2;
naya2 = scheme_make_vector(3, scheme_false);
naya2->type = scheme_inline_variant_type;
SCHEME_VEC_ELS(naya2)[0] = naya;
SCHEME_VEC_ELS(naya2)[1] = SCHEME_VEC_ELS(obj)[1];
return naya2;
}
static Scheme_Object *with_immed_mark_sfs(Scheme_Object *o, SFS_Info *info)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *k, *v, *b, *vec;
int pos, save_mnt;
scheme_sfs_start_sequence(info, 3, 1);
k = scheme_sfs_expr(wcm->key, info, -1);
v = scheme_sfs_expr(wcm->val, info, -1);
scheme_sfs_push(info, 1, 1);
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(3, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (SCHEME_VEC_SIZE(vec) != 3)
scheme_signal_error("internal error: bad vector length");
info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
}
b = scheme_sfs_expr(wcm->body, info, -1);
wcm->key = k;
wcm->val = v;
wcm->body = b;
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
info->max_calls[pos] = info->max_nontail;
n = info->max_used[pos];
SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
n = info->max_calls[pos];
SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
} else {
info->max_nontail = save_mnt;
}
return o;
}
static Scheme_Object *
vector (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec;
int i;
vec = scheme_make_vector (argc, 0);
for (i = 0; i < argc ; i++) {
SCHEME_VEC_ELS(vec)[i] = argv[i];
}
return vec;
}
static void test_air(int interior, int stack)
{
size_t n_finalized = 0;
size_t i, j;
obj_t *s[OBJ_COUNT] = {0};
mps_root_t root = NULL;
if (!stack) {
mps_addr_t *p = (void *)s;
die(mps_root_create_table(&root, scheme_arena, mps_rank_ambig(), 0, p,
OBJ_COUNT), "mps_root_create_table");
}
mps_message_type_enable(scheme_arena, mps_message_type_finalization());
for (j = 0; j < OBJ_COUNT; ++j) {
obj_t n = scheme_make_integer(obj_ap, (long)j);
obj_t obj = scheme_make_vector(obj_ap, OBJ_LEN, n);
mps_addr_t ref = obj;
mps_finalize(scheme_arena, &ref);
s[j] = obj->vector.vector;
}
for (i = 1; i < OBJ_LEN; ++i) {
obj_t n = scheme_make_integer(obj_ap, (long)i);
mps_message_t msg;
for (j = 0; j + 1 < OBJ_COUNT; ++j) {
*++s[j] = n;
}
mps_arena_collect(scheme_arena);
mps_arena_release(scheme_arena);
if (mps_message_get(&msg, scheme_arena, mps_message_type_finalization())) {
mps_addr_t ref;
mps_message_finalization_ref(&ref, scheme_arena, msg);
++ n_finalized;
if (interior) {
obj_t o;
o = ref;
error("wrongly finalized vector %ld at %p",
o->vector.vector[0]->integer.integer, (void *)o);
}
}
}
if (!interior && n_finalized < OBJ_COUNT) {
error("only finalized %"PRIuLONGEST" out of %"PRIuLONGEST" vectors.",
(ulongest_t)n_finalized, (ulongest_t)OBJ_COUNT);
}
if (!stack) {
mps_root_destroy(root);
}
}
static Scheme_Object *sfs_let_void(Scheme_Object *o, SFS_Info *info)
{
Scheme_Let_Void *lv = (Scheme_Let_Void *)o;
Scheme_Object *body;
int i, pos, save_mnt;
Scheme_Object *vec;
scheme_sfs_push(info, lv->count, 1);
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(lv->count + 1, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (!SCHEME_VECTORP(vec))
scheme_signal_error("internal error: not a vector");
for (i = 0; i < lv->count; i++) {
info->max_used[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[i]);
info->max_calls[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
}
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
}
body = scheme_sfs_expr(lv->body, info, -1);
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
SCHEME_VEC_ELS(vec)[lv->count] = scheme_make_integer(info->max_nontail);
for (i = 0; i < lv->count; i++) {
n = info->max_used[pos + i];
SCHEME_VEC_ELS(vec)[i] = scheme_make_integer(n);
}
} else {
info->max_nontail = save_mnt;
}
lv->body = body;
return o;
}
Scheme_Object *
scheme_list_to_vector (Scheme_Object *list)
{
intptr_t len, i;
Scheme_Object *vec, *orig = list;
len = scheme_proper_list_length(list);
if (len < 0)
scheme_wrong_contract("list->vector", "list?", -1, 0, &orig);
vec = scheme_make_vector(len, NULL);
for (i = 0; i < len; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_CAR(list);
list = SCHEME_CDR(list);
}
return vec;
}
Scheme_Linklet *scheme_jit_linklet(Scheme_Linklet *linklet, int step)
/* step 1: clone the immediate record, to be mutated for actual prepataion
step 2: actual preparation */
{
Scheme_Linklet *new_linklet;
Scheme_Object *bodies, *v;
int i;
if (force_jit)
step = 2;
if (!linklet->jit_ready) {
new_linklet = MALLOC_ONE_TAGGED(Scheme_Linklet);
memcpy(new_linklet, linklet, sizeof(Scheme_Linklet));
} else
new_linklet = linklet;
if (new_linklet->jit_ready >= step)
return new_linklet;
if (step == 1) {
new_linklet->jit_ready = 1;
return new_linklet;
}
if (force_jit)
current_linklet_native_lambdas = scheme_null;
i = SCHEME_VEC_SIZE(linklet->bodies);
bodies = scheme_make_vector(i, NULL);
while (i--) {
v = jit_expr(SCHEME_VEC_ELS(linklet->bodies)[i]);
SCHEME_VEC_ELS(bodies)[i] = v;
}
new_linklet->bodies = bodies;
new_linklet->jit_ready = 2;
new_linklet->native_lambdas = current_linklet_native_lambdas;
current_linklet_native_lambdas = NULL;
return new_linklet;
}
Scheme_Object *scheme_chaperone_vector_copy(Scheme_Object *vec)
{
int len;
Scheme_Object *a[3], *vec2;
if (SCHEME_NP_CHAPERONEP(vec))
len = SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(vec));
else
len = SCHEME_VEC_SIZE(vec);
vec2 = scheme_make_vector(len, NULL);
a[0] = vec2;
a[1] = scheme_make_integer(0);
a[2] = vec;
(void)vector_copy_bang(3, a);
return vec2;
}
static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec, *ovec;
long len, i;
if (!SCHEME_VECTORP(argv[0]))
scheme_wrong_type("vector->immutable-vector", "vector", 0, argc, argv);
if (SCHEME_IMMUTABLEP(argv[0]))
return argv[0];
ovec = argv[0];
len = SCHEME_VEC_SIZE(ovec);
vec = scheme_make_vector(len, NULL);
for (i = 0; i < len; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(ovec)[i];
}
SCHEME_SET_IMMUTABLE(vec);
return vec;
}
static Scheme_Object *
make_vector (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec, *fill;
long len;
len = scheme_extract_index("make-vector", 0, argc, argv, -1, 0);
if (len == -1) {
scheme_raise_out_of_memory("make-vector", "making vector of length %s",
scheme_make_provided_string(argv[0], 1, NULL));
}
if (argc == 2)
fill = argv[1];
else
fill = scheme_make_integer(0);
vec = scheme_make_vector(len, fill);
return vec;
}
Scheme_Object *
scheme_checked_make_vector (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec, *fill;
intptr_t len;
len = scheme_extract_index("make-vector", 0, argc, argv, -1, 0);
if ((len == -1)
/* also watch for overflow: */
|| (REV_VECTOR_BYTES(VECTOR_BYTES(len)) != len)) {
scheme_raise_out_of_memory("make-vector", "making vector of length %s",
scheme_make_provided_string(argv[0], 1, NULL));
}
if (argc == 2)
fill = argv[1];
else
fill = scheme_make_integer(0);
vec = scheme_make_vector(len, fill);
return vec;
}
static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[])
{
Scheme_Thread *p;
Scheme_Object *vec, **a, *plain_vec;
intptr_t len, start, finish, i;
vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_contract("vector->values", "vector?", 0, argc, argv);
len = SCHEME_VEC_SIZE(vec);
if (argc > 1)
start = scheme_extract_index("vector->values", 1, argc, argv, len + 1, 0);
else
start = 0;
if (argc > 2)
finish = scheme_extract_index("vector->values", 2, argc, argv, len + 1, 0);
else
finish = len;
if (!(start <= len)) {
bad_index("vector->values", "starting ", argv[1], argv[0], 0);
}
if (!(finish >= start && finish <= len)) {
bad_index("vector->values", "ending ", argv[2], argv[0], start);
}
len = finish - start;
if (len == 1) {
if (!SAME_OBJ(vec, argv[0]))
return scheme_chaperone_vector_ref(argv[0], start);
else
return SCHEME_VEC_ELS(vec)[start];
}
if (!SAME_OBJ(vec, argv[0])) {
plain_vec = scheme_make_vector(len, NULL);
for (i = 0; i < len; i++) {
vec = scheme_chaperone_vector_ref(argv[0], start + i);
SCHEME_VEC_ELS(plain_vec)[i] = vec;
}
vec = plain_vec;
start = 0;
}
p = scheme_current_thread;
if (p->values_buffer && (p->values_buffer_size >= len))
a = p->values_buffer;
else {
a = MALLOC_N(Scheme_Object *, len);
p->values_buffer = a;
p->values_buffer_size = len;
}
p->ku.multiple.array = a;
p->ku.multiple.count = len;
for (i = 0; i < len; i++) {
a[i] = SCHEME_VEC_ELS(vec)[start + i];
}
return SCHEME_MULTIPLE_VALUES;
}
static Scheme_Object *do_chaperone_vector(const char *name, int is_impersonator, int pass_self, int unsafe, int argc, Scheme_Object **argv)
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0];
Scheme_Object *redirects;
Scheme_Object *props;
if (SCHEME_CHAPERONEP(val)) {
val = SCHEME_CHAPERONE_VAL(val);
}
if (!SCHEME_VECTORP(val)
|| (is_impersonator && !SCHEME_MUTABLEP(val)))
scheme_wrong_contract(name, is_impersonator ? "(and/c vector? (not/c immutable?))" : "vector?", 0, argc, argv);
if (unsafe) {
/* We cannot dispatch the operations on an unsafe vector chaperone to a chaperoned vector because of the invariant
that the val field of a vector chaperone must point to a non-chaperoned vector.
To ensure this we error if the second argument passed to `unsafe-chaperone-vector` is not a unchaperoned vector */
if (!SCHEME_VECTORP(argv[1])) {
scheme_wrong_contract(name, "(and/c vector? (not/c impersonator?))", 1, argc, argv);
}
val = argv[1];
}
else {
/* allow false for interposition procedures */
scheme_check_proc_arity2(name, 3 + (pass_self ? 1 : 0), 1, argc, argv, 1);
scheme_check_proc_arity2(name, 3 + (pass_self ? 1 : 0), 2, argc, argv, 1);
/* but only allow `#f` if both are `#f` */
if (SCHEME_FALSEP(argv[1]) != SCHEME_FALSEP(argv[2])) {
scheme_contract_error(name,
"accessor and mutator wrapper must be both `#f` or neither `#f`",
"accessor wrapper", 1, argv[1],
"mutator wrapper", 1, argv[2],
NULL);
}
}
props = scheme_parse_chaperone_props(name, unsafe ? 2 : 3, argc, argv);
/*
Regular vector chaperones store redirect procedures in a pair, (cons getter setter).
Property only vector chaperones have no redirection procedures, and redirects is assigned an empty vector.
Unsafe vector chaperones dispatch operations to another vector stored in a box in redirects.
*/
if (SCHEME_FALSEP(argv[1])) {
redirects = scheme_make_vector(0, NULL);
}
else if (unsafe) {
redirects = scheme_false;
}
else {
redirects = scheme_make_pair(argv[1], argv[2]);
}
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->iso.so.type = scheme_chaperone_type;
px->props = props;
px->val = val;
px->prev = argv[0];
px->redirects = redirects;
if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
/* Use flag to tell if the chaperone is a chaperone* */
if (pass_self) {
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_VEC_CHAPERONE_STAR;
}
return (Scheme_Object *)px;
}
Scheme_Object *scheme_jit_make_vector(intptr_t n)
{
Scheme_Object *vec;
vec = scheme_make_vector(n, NULL);
return vec;
}
Scheme_Object *scheme_jit_make_one_element_vector(Scheme_Object *a)
{
Scheme_Object *vec;
vec = scheme_make_vector(1, a);
return vec;
}
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;
}
static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip,
Scheme_Object *vec, int delta,
Scheme_Object *tbranch)
{
int t_min_t, t_max_t, t_cnt, n, stackpos, i, save_nt, b_end, nt;
Scheme_Object *t_vec, *o;
Scheme_Object *clears = scheme_null;
info->min_touch = -1;
info->max_touch = -1;
save_nt = info->max_nontail;
SFS_LOG(printf("%d %d %s %d\n", info->pass, ip, (delta ? "else" : "then"), ip));
if (info->pass) {
/* Re-install max_used entries that refer to the branch */
o = SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W];
t_min_t = SCHEME_INT_VAL(o);
o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2];
nt = SCHEME_INT_VAL(o);
if (nt > info->max_nontail)
info->max_nontail = nt;
if (t_min_t > -1) {
t_vec = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1];
t_cnt = SCHEME_VEC_SIZE(t_vec);
for (i = 0; i < t_cnt; i++) {
o = SCHEME_VEC_ELS(t_vec)[i];
if (SCHEME_INTP(o)) {
n = SCHEME_INT_VAL(o);
SFS_LOG(printf(" @%d %d\n", i + t_min_t, n));
if (info->max_used[i + t_min_t] < n) {
SFS_LOG(printf(" |%d %d %d\n", i + t_min_t, n, info->max_nontail));
info->max_used[i + t_min_t] = n;
info->max_calls[i + t_min_t] = info->max_nontail;
}
}
}
}
/* If the other branch has last use for something not used in this
branch, and if there's a non-tail call in this branch
of later, then we'll have to start with explicit clears.
Note that it doesn't matter whether the other branch actually
clears them (i.e., the relevant non-tail call might be only
in this branch). */
o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3];
b_end = SCHEME_INT_VAL(o);
SFS_LOG(printf(" %d %d %d %d\n", nt, ip, b_end, save_nt));
if (((nt > (ip + 1)) && (nt < b_end)) /* => non-tail call in branch */
|| ((ip + 1) < save_nt)) { /* => non-tail call after branches */
SFS_LOG(printf(" other\n"));
o = SCHEME_VEC_ELS(vec)[(1 - delta) * SFS_BRANCH_W];
t_min_t = SCHEME_INT_VAL(o);
if (t_min_t > -1) {
int at_ip, pos;
t_vec = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 1];
t_cnt = SCHEME_VEC_SIZE(t_vec);
o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 2];
nt = SCHEME_INT_VAL(o);
o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 3];
b_end = SCHEME_INT_VAL(o);
for (i = 0; i < t_cnt; i++) {
o = SCHEME_VEC_ELS(t_vec)[i];
if (SCHEME_INTP(o)) {
n = SCHEME_INT_VAL(o);
pos = i + t_min_t;
at_ip = info->max_used[pos];
SFS_LOG(printf(" ?%d %d %d\n", pos, n, at_ip));
/* is last use in other branch? */
if (((!delta && (at_ip == ip))
|| (delta && (at_ip == n)))) {
/* Yes, so add clear */
SFS_LOG(printf(" !%d %d %d\n", pos, n, at_ip));
pos -= info->stackpos;
clears = scheme_make_pair(scheme_make_integer(pos),
clears);
}
}
}
}
}
}
stackpos = info->stackpos;
tbranch = scheme_sfs_expr(tbranch, info, -1);
if (info->pass)
info->max_nontail = save_nt;
# if MAX_SFS_CLEARING
else
info->max_nontail = info->ip;
# endif
tbranch = scheme_sfs_add_clears(tbranch, clears, 1);
if (!info->pass) {
t_min_t = info->min_touch;
t_max_t = info->max_touch;
if (t_min_t < stackpos)
t_min_t = stackpos;
if (t_max_t < stackpos)
t_max_t = -1;
SFS_LOG(printf("%d %s %d [%d,%d] /%d\n", info->pass, (delta ? "else" : "then"), ip,
t_min_t, t_max_t, stackpos));
if (t_max_t < 0) {
t_min_t = -1;
t_vec = scheme_false;
} else {
t_cnt = t_max_t - t_min_t + 1;
t_vec = scheme_make_vector(t_cnt, NULL);
for (i = 0; i < t_cnt; i++) {
n = info->max_used[i + t_min_t];
SFS_LOG(printf("%d %s %d %d -> %d/%d\n", info->pass, (delta ? "else" : "then"), ip,
i + t_min_t, n, info->max_calls[i+ t_min_t]));
if (n > ip) {
SCHEME_VEC_ELS(t_vec)[i] = scheme_make_integer(n);
info->max_used[i + t_min_t] = ip;
} else {
SCHEME_VEC_ELS(t_vec)[i] = scheme_false;
}
}
}
SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W] = scheme_make_integer(t_min_t);
SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1] = t_vec;
SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2] = scheme_make_integer(info->max_nontail);
SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3] = scheme_make_integer(info->ip);
}
memset(info->max_used + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int));
memset(info->max_calls + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int));
info->stackpos = stackpos;
return tbranch;
}
static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
{
Scheme_Let_One *lo = (Scheme_Let_One *)o;
Scheme_Object *body, *rhs, *vec;
int pos, save_mnt, ip, et;
int unused = 0;
scheme_sfs_start_sequence(info, 2, 1);
scheme_sfs_push(info, 1, 1);
ip = info->ip;
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(3, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (SCHEME_VEC_SIZE(vec) != 3)
scheme_signal_error("internal error: bad vector length");
info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
}
rhs = scheme_sfs_expr(lo->value, info, -1);
body = scheme_sfs_expr(lo->body, info, -1);
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
info->max_calls[pos] = info->max_nontail;
n = info->max_used[pos];
SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
n = info->max_calls[pos];
SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
} else {
info->max_nontail = save_mnt;
if (info->max_used[pos] <= ip) {
/* No one is using it, so don't actually push the value at run time
(but keep the check that the result is single-valued).
The optimizer normally would have converted away the binding, but
it might not because (1) it was introduced late by inlining,
or (2) the rhs expression doesn't always produce a single
value. */
if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, -1)) {
rhs = scheme_false;
} else if ((ip < info->max_calls[pos])
&& SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) {
/* Unusual case: we can't just drop the global-variable access,
because it might be undefined, but we don't need the value,
and we want to avoid an SFS clear in the interpreter loop.
So, bind #f and then access in the global in a `begin'. */
Scheme_Sequence *s;
s = scheme_malloc_sequence(2);
s->so.type = scheme_sequence_type;
s->count = 2;
s->array[0] = rhs;
s->array[1] = body;
body = (Scheme_Object *)s;
rhs = scheme_false;
}
unused = 1;
}
}
lo->value = rhs;
lo->body = body;
et = scheme_get_eval_type(lo->value);
SCHEME_LET_EVAL_TYPE(lo) = (et
| (unused ? 0 : (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM))
| (unused ? LET_ONE_UNUSED : 0));
return o;
}
static Scheme_Object *sfs_branch(Scheme_Object *o, SFS_Info *info)
{
Scheme_Branch_Rec *b;
Scheme_Object *t, *tb, *fb, *vec;
int ip, min_t, max_t;
b = (Scheme_Branch_Rec *)o;
scheme_sfs_start_sequence(info, 1, 0);
t = scheme_sfs_expr(b->test, info, -1);
ip = info->ip;
info->ip++;
/* Use ip to represent all uses in the two branches.
Use ip+1 to represent all non-tail calls in the two branches. */
min_t = info->min_touch;
max_t = info->max_touch;
SFS_LOG(printf(" after test: %d %d\n", min_t, max_t));
if (!info->pass) {
vec = scheme_make_vector(SFS_BRANCH_W * 2, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
}
tb = sfs_one_branch(info, ip, vec, 0, b->tbranch);
if (!info->pass) {
if ((min_t == -1)
|| ((info->min_touch > -1) && (info->min_touch < min_t)))
min_t = info->min_touch;
if (info->max_touch > max_t)
max_t = info->max_touch;
if (info->max_nontail > ip + 1)
info->max_nontail = ip + 1;
}
fb = sfs_one_branch(info, ip, vec, 1, b->fbranch);
if (!info->pass) {
if ((min_t == -1)
|| ((info->min_touch > -1) && (info->min_touch < min_t)))
min_t = info->min_touch;
if (info->max_touch > max_t)
max_t = info->max_touch;
if (info->max_nontail > ip + 1)
info->max_nontail = ip + 1;
}
SFS_LOG(printf(" done if: %d %d\n", min_t, max_t));
info->min_touch = min_t;
info->max_touch = max_t;
b->test = t;
b->tbranch = tb;
b->fbranch = fb;
return o;
}