static Scheme_Object *jit_letrec(Scheme_Object *o)
{
Scheme_Letrec *lr = (Scheme_Letrec *)o, *lr2;
Scheme_Object **procs, **procs2, *v;
int i, count;
count = lr->count;
lr2 = MALLOC_ONE_TAGGED(Scheme_Letrec);
memcpy(lr2, lr, sizeof(Scheme_Letrec));
procs = lr->procs;
procs2 = MALLOC_N(Scheme_Object *, count);
lr2->procs = procs2;
for (i = 0; i < count; i++) {
v = scheme_jit_closure(procs[i], (Scheme_Object *)lr2);
procs2[i] = v;
}
v = jit_expr(lr->body);
lr2->body = v;
return (Scheme_Object *)lr2;
}
static Scheme_Object *read_quote_syntax(Scheme_Object *obj)
{
Scheme_Quote_Syntax *qs;
Scheme_Object *a;
int c, i, p;
if (!SCHEME_PAIRP(obj)) return NULL;
a = SCHEME_CAR(obj);
c = SCHEME_INT_VAL(a);
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
a = SCHEME_CAR(obj);
i = SCHEME_INT_VAL(a);
a = SCHEME_CDR(obj);
p = SCHEME_INT_VAL(a);
qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax);
qs->so.type = scheme_quote_syntax_type;
qs->depth = c;
qs->position = i;
qs->midpoint = p;
return (Scheme_Object *)qs;
}
static Scheme_Object *do_chaperone_vector(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0];
Scheme_Object *redirects;
Scheme_Hash_Tree *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);
scheme_check_proc_arity(name, 3, 1, argc, argv);
scheme_check_proc_arity(name, 3, 2, argc, argv);
props = scheme_parse_chaperone_props(name, 3, argc, argv);
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;
return (Scheme_Object *)px;
}
static Scheme_Object *read_letrec(Scheme_Object *obj)
{
Scheme_Letrec *lr;
int i, c;
Scheme_Object **sa;
lr = MALLOC_ONE_TAGGED(Scheme_Letrec);
lr->so.type = scheme_letrec_type;
if (!SCHEME_PAIRP(obj)) return NULL;
c = lr->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
lr->body = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
sa = MALLOC_N(Scheme_Object*, c);
lr->procs = sa;
for (i = 0; i < c; i++) {
if (!SCHEME_PAIRP(obj)) return NULL;
lr->procs[i] = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
}
return (Scheme_Object *)lr;
}
Scheme_Object *scheme_make_sema(intptr_t v)
{
Scheme_Sema *sema;
sema = MALLOC_ONE_TAGGED(Scheme_Sema);
sema->value = v;
sema->so.type = scheme_sema_type;
return (Scheme_Object *)sema;
}
Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Object *context)
/* If lr is supplied as a letrec binding this closure, it may be used
for JIT compilation. */
{
#ifdef MZ_USE_JIT
Scheme_Lambda *data = (Scheme_Lambda *)code, *data2;
/* We need to cache clones to support multiple references
to a zero-sized closure in bytecode. We need either a clone
or native code, and context determines which field is relevant,
so we put the two possibilities in a union `u'. */
if (!context)
data2 = data->u.jit_clone;
else
data2 = NULL;
if (!data2) {
Scheme_Native_Lambda *ndata;
data2 = MALLOC_ONE_TAGGED(Scheme_Lambda);
memcpy(data2, code, sizeof(Scheme_Lambda));
data2->context = context;
ndata = scheme_generate_lambda(data2, 1, NULL);
data2->u.native_code = ndata;
if (current_linklet_native_lambdas)
current_linklet_native_lambdas = scheme_make_pair((Scheme_Object *)ndata,
current_linklet_native_lambdas);
if (!context)
data->u.jit_clone = data2;
if (current_linklet_native_lambdas) {
/* Force jitprep on body, too, to discover all lambdas */
Scheme_Object *body;
body = jit_expr(data2->body);
data2->body = body;
}
}
/* If it's zero-sized, then create closure now */
if (!data2->closure_size)
return scheme_make_native_closure(data2->u.native_code);
return (Scheme_Object *)data2;
#endif
return code;
}
static Scheme_Object *read_with_cont_mark(Scheme_Object *obj)
{
Scheme_With_Continuation_Mark *wcm;
if (!SCHEME_PAIRP(obj) || !SCHEME_PAIRP(SCHEME_CDR(obj)))
return NULL; /* bad .zo */
wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
wcm->so.type = scheme_with_cont_mark_type;
wcm->key = SCHEME_CAR(obj);
wcm->val = SCHEME_CADR(obj);
wcm->body = SCHEME_CDR(SCHEME_CDR(obj));
return (Scheme_Object *)wcm;
}
static Scheme_Object *read_top(Scheme_Object *obj)
{
Scheme_Compilation_Top *top;
top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top);
top->so.type = scheme_compilation_top_type;
if (!SCHEME_PAIRP(obj)) return NULL;
top->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
top->prefix = (Resolve_Prefix *)SCHEME_CAR(obj);
top->code = SCHEME_CDR(obj);
return (Scheme_Object *)top;
}
static Scheme_Object *jit_let_void(Scheme_Object *o)
{
Scheme_Let_Void *lv = (Scheme_Let_Void *)o;
Scheme_Object *body;
body = jit_expr(lv->body);
if (SAME_OBJ(body, lv->body))
return o;
lv = MALLOC_ONE_TAGGED(Scheme_Let_Void);
memcpy(lv, o, sizeof(Scheme_Let_Void));
lv->body = body;
return (Scheme_Object *)lv;
}
static Scheme_Object *set_jit(Scheme_Object *data)
{
Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data, *naya;
Scheme_Object *orig_val, *naya_val;
orig_val = sb->val;
naya_val = jit_expr(orig_val);
if (SAME_OBJ(naya_val, orig_val))
return data;
else {
naya = MALLOC_ONE_TAGGED(Scheme_Set_Bang);
memcpy(naya, sb, sizeof(Scheme_Set_Bang));
naya->val = naya_val;
return (Scheme_Object *)naya;
}
}
static Scheme_Object *read_set_bang(Scheme_Object *obj)
{
Scheme_Set_Bang *sb;
sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang);
sb->so.type = scheme_set_bang_type;
if (!SCHEME_PAIRP(obj)) return NULL;
sb->set_undef = SCHEME_TRUEP(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
sb->var = SCHEME_CAR(obj);
sb->val = SCHEME_CDR(obj);
return (Scheme_Object *)sb;
}
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;
}
static Scheme_Object *jit_let_value(Scheme_Object *o)
{
Scheme_Let_Value *lv = (Scheme_Let_Value *)o;
Scheme_Object *body, *rhs;
rhs = jit_expr(lv->value);
body = jit_expr(lv->body);
if (SAME_OBJ(rhs, lv->value)
&& SAME_OBJ(body, lv->body))
return o;
lv = MALLOC_ONE_TAGGED(Scheme_Let_Value);
memcpy(lv, o, sizeof(Scheme_Let_Value));
lv->value = rhs;
lv->body = body;
return (Scheme_Object *)lv;
}
static Scheme_Object *jit_let_one(Scheme_Object *o)
{
Scheme_Let_One *lo = (Scheme_Let_One *)o;
Scheme_Object *body, *rhs;
rhs = jit_expr(lo->value);
body = jit_expr(lo->body);
if (SAME_OBJ(rhs, lo->value)
&& SAME_OBJ(body, lo->body))
return o;
lo = MALLOC_ONE_TAGGED(Scheme_Let_One);
memcpy(lo, o, sizeof(Scheme_Let_One));
lo->value = rhs;
lo->body = body;
return (Scheme_Object *)lo;
}
static Scheme_Object *jit_application2(Scheme_Object *o)
{
Scheme_App2_Rec *app;
Scheme_Object *nrator, *nrand;
app = (Scheme_App2_Rec *)o;
nrator = jit_expr(app->rator);
nrand = jit_expr(app->rand);
if (SAME_OBJ(nrator, app->rator)
&& SAME_OBJ(nrand, app->rand))
return o;
app = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
memcpy(app, o, sizeof(Scheme_App2_Rec));
app->rator = nrator;
app->rand = nrand;
return (Scheme_Object *)app;
}
static Scheme_Object *with_immed_mark_jit(Scheme_Object *o)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *k, *v, *b;
k = jit_expr(wcm->key);
v = jit_expr(wcm->val);
b = jit_expr(wcm->body);
if (SAME_OBJ(wcm->key, k)
&& SAME_OBJ(wcm->val, v)
&& SAME_OBJ(wcm->body, b))
return o;
wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
memcpy(wcm, o, sizeof(Scheme_With_Continuation_Mark));
wcm->key = k;
wcm->val = v;
wcm->body = b;
return (Scheme_Object *)wcm;
}
static Scheme_Object *jit_application3(Scheme_Object *o)
{
Scheme_App3_Rec *app;
Scheme_Object *nrator, *nrand1, *nrand2;
app = (Scheme_App3_Rec *)o;
nrator = jit_expr(app->rator);
nrand1 = jit_expr(app->rand1);
nrand2 = jit_expr(app->rand2);
if (SAME_OBJ(nrator, app->rator)
&& SAME_OBJ(nrand1, app->rand1)
&& SAME_OBJ(nrand2, app->rand2))
return o;
app = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
memcpy(app, o, sizeof(Scheme_App3_Rec));
app->rator = nrator;
app->rand1 = nrand1;
app->rand2 = nrand2;
return (Scheme_Object *)app;
}
static Scheme_Object *jit_branch(Scheme_Object *o)
{
Scheme_Branch_Rec *b;
Scheme_Object *t, *tb, *fb;
b = (Scheme_Branch_Rec *)o;
t = jit_expr(b->test);
tb = jit_expr(b->tbranch);
fb = jit_expr(b->fbranch);
if (SAME_OBJ(t, b->test)
&& SAME_OBJ(tb, b->tbranch)
&& SAME_OBJ(fb, b->fbranch))
return o;
b = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
memcpy(b, o, sizeof(Scheme_Branch_Rec));
b->test = t;
b->tbranch = tb;
b->fbranch = fb;
return (Scheme_Object *)b;
}
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_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_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;
}
