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