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; }