static Scheme_Object *begin0_jit(Scheme_Object *data)
{
Scheme_Sequence *seq = (Scheme_Sequence *)data, *seq2;
Scheme_Object *old, *naya = NULL;
int i, j, count;
count = seq->count;
for (i = 0; i < count; i++) {
old = seq->array[i];
naya = jit_expr(old);
if (!SAME_OBJ(old, naya))
break;
}
if (i >= count)
return data;
seq2 = (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence)
+ (count - mzFLEX_DELTA)
* sizeof(Scheme_Object *));
seq2->so.type = scheme_begin0_sequence_type;
seq2->count = count;
for (j = 0; j < i; j++) {
seq2->array[j] = seq->array[j];
}
seq2->array[i] = naya;
for (i++; i < count; i++) {
old = seq->array[i];
naya = jit_expr(old);
seq2->array[i] = naya;
}
return (Scheme_Object *)seq2;
}
Scheme_Object *
scheme_make_vector (intptr_t size, Scheme_Object *fill)
{
Scheme_Object *vec;
intptr_t i;
if (size < 0) {
vec = scheme_make_integer(size);
scheme_wrong_contract("make-vector", "exact-nonnegative-integer?", -1, 0, &vec);
}
if (size < 1024) {
vec = (Scheme_Object *)scheme_malloc_tagged(VECTOR_BYTES(size));
} else {
size_t sz;
sz = VECTOR_BYTES(size);
if (REV_VECTOR_BYTES(sz) != size)
/* overflow */
scheme_raise_out_of_memory(NULL, NULL);
else
vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged, sz);
}
vec->type = scheme_vector_type;
SCHEME_VEC_SIZE(vec) = size;
if (fill) {
for (i = 0; i < size; i++) {
SCHEME_VEC_ELS(vec)[i] = fill;
}
}
return vec;
}
static Scheme_Object *jit_application(Scheme_Object *o)
{
Scheme_Object *orig, *naya = NULL;
Scheme_App_Rec *app, *app2;
int i, n, size;
app = (Scheme_App_Rec *)o;
n = app->num_args + 1;
for (i = 0; i < n; i++) {
orig = app->args[i];
naya = jit_expr(orig);
if (!SAME_OBJ(orig, naya))
break;
}
if (i >= n)
return o;
size = (sizeof(Scheme_App_Rec)
+ ((n - mzFLEX_DELTA) * sizeof(Scheme_Object *))
+ n * sizeof(char));
app2 = (Scheme_App_Rec *)scheme_malloc_tagged(size);
memcpy(app2, app, size);
app2->args[i] = naya;
for (i++; i < n; i++) {
orig = app2->args[i];
naya = jit_expr(orig);
app2->args[i] = naya;
}
return (Scheme_Object *)app2;
}
Scheme_Object *
scheme_make_vector (intptr_t size, Scheme_Object *fill)
{
Scheme_Object *vec;
intptr_t i;
if (size < 0) {
vec = scheme_make_integer(size);
scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
}
if (size < 1024) {
vec = (Scheme_Object *)scheme_malloc_tagged(VECTOR_BYTES(size));
} else {
vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged, VECTOR_BYTES(size));
}
vec->type = scheme_vector_type;
SCHEME_VEC_SIZE(vec) = size;
if (fill) {
for (i = 0; i < size; i++) {
SCHEME_VEC_ELS(vec)[i] = fill;
}
}
return vec;
}
static Scheme_Object *jit_sequence(Scheme_Object *o)
{
Scheme_Object *orig, *naya = NULL;
Scheme_Sequence *seq, *seq2;
int i, n, size;
seq = (Scheme_Sequence *)o;
n = seq->count;
for (i = 0; i < n; i++) {
orig = seq->array[i];
naya = jit_expr(orig);
if (!SAME_OBJ(orig, naya))
break;
}
if (i >= n)
return o;
size = (sizeof(Scheme_Sequence)
+ ((n - mzFLEX_DELTA) * sizeof(Scheme_Object *)));
seq2 = (Scheme_Sequence *)scheme_malloc_tagged(size);
memcpy(seq2, seq, size);
seq2->array[i] = naya;
for (i++; i < n; i++) {
orig = seq2->array[i];
naya = jit_expr(orig);
seq2->array[i] = naya;
}
return (Scheme_Object *)seq2;
}
Scheme_Object *
scheme_make_vector (int size, Scheme_Object *fill)
{
Scheme_Object *vec;
int i;
if (size <= 0) {
if (size) {
vec = scheme_make_integer(size);
scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
} else
return zero_length_vector;
}
if (size < 1024) {
vec = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Vector)
+ (size - 1) * sizeof(Scheme_Object *));
} else {
vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged,
sizeof(Scheme_Vector)
+ (size - 1) * sizeof(Scheme_Object *));
}
vec->type = scheme_vector_type;
SCHEME_VEC_SIZE(vec) = size;
if (fill) {
for (i = 0; i < size; i++) {
SCHEME_VEC_ELS(vec)[i] = fill;
}
}
return vec;
}
static Scheme_Object *read_let_void(Scheme_Object *obj)
{
Scheme_Let_Void *lv;
lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void));
lv->iso.so.type = scheme_let_void_type;
if (!SCHEME_PAIRP(obj)) return NULL;
lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj));
lv->body = SCHEME_CDR(obj);
return (Scheme_Object *)lv;
}
static Scheme_Object *read_case_lambda(Scheme_Object *obj)
{
Scheme_Object *s, *a;
int count, i, all_closed = 1;
Scheme_Case_Lambda *cl;
if (!SCHEME_PAIRP(obj)) return NULL;
s = SCHEME_CDR(obj);
for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) {
count++;
}
cl = (Scheme_Case_Lambda *)
scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
+ (count - 1) * sizeof(Scheme_Object *));
cl->so.type = scheme_case_lambda_sequence_type;
cl->count = count;
cl->name = SCHEME_CAR(obj);
if (SCHEME_NULLP(cl->name))
cl->name = NULL;
s = SCHEME_CDR(obj);
for (i = 0; i < count; i++, s = SCHEME_CDR(s)) {
a = SCHEME_CAR(s);
cl->array[i] = a;
if (!SCHEME_PROCP(a)) {
if (!SAME_TYPE(SCHEME_TYPE(a), scheme_unclosed_procedure_type))
return NULL;
all_closed = 0;
}
}
if (all_closed) {
/* Empty closure: produce procedure value directly.
(We assume that this was generated by a direct write of
a case-lambda data record in print.c, and that it's not
in a CASE_LAMBDA_EXPD syntax record.) */
return scheme_case_lambda_execute((Scheme_Object *)cl);
}
return (Scheme_Object *)cl;
}
Scheme_Object *scheme_case_lambda_jit(Scheme_Object *expr)
{
#ifdef MZ_USE_JIT
Scheme_Case_Lambda *seqin = (Scheme_Case_Lambda *)expr;
if (!seqin->native_code) {
Scheme_Case_Lambda *seqout;
Scheme_Native_Lambda *ndata;
Scheme_Object *val, *name;
int i, cnt, size, all_closed = 1;
cnt = seqin->count;
size = sizeof(Scheme_Case_Lambda) + ((cnt - mzFLEX_DELTA) * sizeof(Scheme_Object *));
seqout = (Scheme_Case_Lambda *)scheme_malloc_tagged(size);
memcpy(seqout, seqin, size);
name = seqin->name;
if (name && SCHEME_BOXP(name))
name = SCHEME_BOX_VAL(name);
for (i = 0; i < cnt; i++) {
val = seqout->array[i];
if (SCHEME_PROCP(val)) {
/* Undo creation of empty closure */
val = (Scheme_Object *)((Scheme_Closure *)val)->code;
seqout->array[i] = val;
}
((Scheme_Lambda *)val)->name = name;
if (((Scheme_Lambda *)val)->closure_size)
all_closed = 0;
}
/* Generating the code may cause empty closures to be formed: */
ndata = scheme_generate_case_lambda(seqout);
seqout->native_code = ndata;
if (current_linklet_native_lambdas) {
for (i = 0; i < cnt; i++) {
val = seqout->array[i];
{
/* Force jitprep on body, too, to discover all lambdas */
Scheme_Object *body;
body = jit_expr(((Scheme_Lambda *)val)->body);
((Scheme_Lambda *)val)->body = body;
}
val = (Scheme_Object *)((Scheme_Lambda *)val)->u.native_code;
current_linklet_native_lambdas = scheme_make_pair(val, current_linklet_native_lambdas);
}
}
if (all_closed) {
/* Native closures do not refer back to the original bytecode,
so no need to worry about clearing the reference. */
Scheme_Native_Closure *nc;
nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata);
for (i = 0; i < cnt; i++) {
val = seqout->array[i];
if (!SCHEME_PROCP(val)) {
val = scheme_make_native_closure(((Scheme_Lambda *)val)->u.native_code);
}
nc->vals[i] = val;
}
return (Scheme_Object *)nc;
} else {
/* The case-lambda data must point to the original closure-data
record, because that's where the closure maps are kept. But
we don't need the bytecode, anymore. So clone the
closure-data record and drop the bytecode in thte clone. */
for (i = 0; i < cnt; i++) {
val = seqout->array[i];
if (!SCHEME_PROCP(val)) {
Scheme_Lambda *data;
data = MALLOC_ONE_TAGGED(Scheme_Lambda);
memcpy(data, val, sizeof(Scheme_Lambda));
data->body = NULL;
seqout->array[i] = (Scheme_Object *)data;
}
}
}
return (Scheme_Object *)seqout;
}
#endif
return expr;
}
void *scheme_malloc_stubborn_tagged(size_t s)
{
return scheme_malloc_tagged(s);
}
void
scheme_init_vector (Scheme_Env *env)
{
Scheme_Object *p;
REGISTER_SO(zero_length_vector);
zero_length_vector = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Vector)
- sizeof(Scheme_Object *));
zero_length_vector->type = scheme_vector_type;
SCHEME_VEC_SIZE(zero_length_vector) = 0;
p = scheme_make_folding_prim(vector_p, "vector?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("vector?", p, env);
scheme_add_global_constant("make-vector",
scheme_make_noncm_prim(make_vector,
"make-vector",
1, 2),
env);
scheme_add_global_constant("vector",
scheme_make_noncm_prim(vector,
"vector",
0, -1),
env);
scheme_add_global_constant("vector-immutable",
scheme_make_noncm_prim(vector_immutable,
"vector-immutable",
0, -1),
env);
scheme_add_global_constant("vector-length",
scheme_make_folding_prim(vector_length,
"vector-length",
1, 1, 1),
env);
p = scheme_make_noncm_prim(scheme_checked_vector_ref,
"vector-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("vector-ref", p, env);
p = scheme_make_noncm_prim(scheme_checked_vector_set,
"vector-set!",
3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_MIN_NARY_INLINED;
scheme_add_global_constant("vector-set!", p, env);
scheme_add_global_constant("vector->list",
scheme_make_noncm_prim(vector_to_list,
"vector->list",
1, 1),
env);
scheme_add_global_constant("list->vector",
scheme_make_noncm_prim(list_to_vector,
"list->vector",
1, 1),
env);
scheme_add_global_constant("vector-fill!",
scheme_make_noncm_prim(vector_fill,
"vector-fill!",
2, 2),
env);
scheme_add_global_constant("vector->immutable-vector",
scheme_make_noncm_prim(vector_to_immutable,
"vector->immutable-vector",
1, 1),
env);
scheme_add_global_constant("vector->values",
scheme_make_prim_w_arity2(vector_to_values,
"vector->values",
1, 3,
0, -1),
env);
}
