static Scheme_Object * define_values_sfs(Scheme_Object *data, SFS_Info *info) { Scheme_Object *e; scheme_sfs_start_sequence(info, 1, 0); e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1); SCHEME_VEC_ELS(data)[0] = e; return data; }
static Scheme_Object * inline_variant_sfs(Scheme_Object *data, SFS_Info *info) { Scheme_Object *e; scheme_sfs_start_sequence(info, 1, 0); e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1); SCHEME_VEC_ELS(data)[0] = e; /* we don't bother with inlinable variant, since it isn't called directly */ return data; }
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 * ref_sfs(Scheme_Object *data, SFS_Info *info) { Scheme_Object *a_naya; Scheme_Object *b_naya; scheme_sfs_start_sequence(info, 1, 0); a_naya = scheme_sfs_expr(SCHEME_PTR1_VAL(data), info, -1); b_naya = scheme_sfs_expr(SCHEME_PTR2_VAL(data), info, -1); SCHEME_PTR1_VAL(data) = a_naya; SCHEME_PTR2_VAL(data) = b_naya; return data; }
static Scheme_Object * begin0_sfs(Scheme_Object *obj, SFS_Info *info) { int i, cnt; cnt = ((Scheme_Sequence *)obj)->count; scheme_sfs_start_sequence(info, cnt, 0); for (i = 0; i < cnt; i++) { Scheme_Object *le; le = scheme_sfs_expr(((Scheme_Sequence *)obj)->array[i], info, -1); ((Scheme_Sequence *)obj)->array[i] = le; } return obj; }
static Scheme_Object *sfs_wcm(Scheme_Object *o, SFS_Info *info) { Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; Scheme_Object *k, *v, *b; scheme_sfs_start_sequence(info, 3, 1); k = scheme_sfs_expr(wcm->key, info, -1); v = scheme_sfs_expr(wcm->val, info, -1); b = scheme_sfs_expr(wcm->body, info, -1); wcm->key = k; wcm->val = v; wcm->body = b; return o; }
static Scheme_Object * module_sfs(Scheme_Object *data, SFS_Info *old_info) { Scheme_Module *m = (Scheme_Module *)data; Scheme_Object *e, *ex; SFS_Info *info; int i, j, cnt, let_depth; if (!old_info->for_mod) { if (old_info->pass) return data; info = scheme_new_sfs_info(m->max_let_depth); info->for_mod = 1; scheme_sfs(data, info, m->max_let_depth); return data; } info = old_info; cnt = SCHEME_VEC_SIZE(m->bodies[0]); scheme_sfs_start_sequence(info, cnt, 0); for (i = 0; i < cnt; i++) { e = scheme_sfs_expr(SCHEME_VEC_ELS(m->bodies[0])[i], info, -1); SCHEME_VEC_ELS(m->bodies[0])[i] = e; } if (!info->pass) { for (j = m->num_phases; j-- > 1; ) { cnt = SCHEME_VEC_SIZE(m->bodies[j]); for (i = 0; i < cnt; i++) { e = SCHEME_VEC_ELS(m->bodies[j])[i]; let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); ex = SCHEME_VEC_ELS(e)[1]; info = scheme_new_sfs_info(let_depth); ex = scheme_sfs(ex, info, let_depth); SCHEME_VEC_ELS(e)[1] = ex; } } } return data; }
static Scheme_Object * apply_values_sfs(Scheme_Object *data, SFS_Info *info) { Scheme_Object *f, *e; f = SCHEME_PTR1_VAL(data); e = SCHEME_PTR2_VAL(data); scheme_sfs_start_sequence(info, 2, 0); f = scheme_sfs_expr(f, info, -1); e = scheme_sfs_expr(e, info, -1); SCHEME_PTR1_VAL(data) = f; SCHEME_PTR2_VAL(data) = e; return data; }
static Scheme_Object * set_sfs(Scheme_Object *data, SFS_Info *info) { Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; Scheme_Object *var, *val; var = sb->var; val = sb->val; scheme_sfs_start_sequence(info, 2, 0); val = scheme_sfs_expr(val, info, -1); var = scheme_sfs_expr(var, info, -1); sb->var = var; sb->val = val; return (Scheme_Object *)sb; }
static Scheme_Object *sfs_application2(Scheme_Object *o, SFS_Info *info) { Scheme_App2_Rec *app; Scheme_Object *nrator, *nrand; app = (Scheme_App2_Rec *)o; scheme_sfs_start_sequence(info, 2, 0); scheme_sfs_push(info, 1, 0); nrator = scheme_sfs_expr(app->rator, info, -1); nrand = scheme_sfs_expr(app->rand, info, -1); app->rator = nrator; app->rand = nrand; sfs_note_app(info, app->rator); scheme_reset_app2_eval_type(app); return o; }
static Scheme_Object *sfs_let_value(Scheme_Object *o, SFS_Info *info) { Scheme_Let_Value *lv = (Scheme_Let_Value *)o; Scheme_Object *body, *rhs, *clears = scheme_null; int i, pos; scheme_sfs_start_sequence(info, 2, 1); rhs = scheme_sfs_expr(lv->value, info, -1); if (!info->pass || (info->ip < info->max_nontail)) { for (i = 0; i < lv->count; i++) { pos = lv->position + i; if (!info->pass) scheme_sfs_used(info, pos); else { int spos; spos = pos + info->stackpos; if ((info->max_used[spos] == info->ip) && (info->max_calls[spos] > info->ip)) { /* No one is using the id after we set it. We still need to set it, in case it's boxed and shared, but then remove the binding or box. */ clears = scheme_make_pair(scheme_make_integer(pos), clears); } } } } body = scheme_sfs_expr(lv->body, info, -1); body = scheme_sfs_add_clears(body, clears, 1); lv->value = rhs; lv->body = body; return o; }
static Scheme_Object * case_lambda_sfs(Scheme_Object *expr, SFS_Info *info) { Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr; Scheme_Object *le, *clears = scheme_null; int i; scheme_sfs_start_sequence(info, seq->count, 0); for (i = 0; i < seq->count; i++) { le = seq->array[i]; le = scheme_sfs_expr(le, info, -1); if (SAME_TYPE(SCHEME_TYPE(le), scheme_begin0_sequence_type)) { /* Some clearing actions were added to the closure. Lift them out. */ int j; Scheme_Sequence *cseq = (Scheme_Sequence *)le; if (!cseq->count) scheme_signal_error("internal error: empty sequence"); for (j = 1; j < cseq->count; j++) { int pos; pos = SCHEME_LOCAL_POS(cseq->array[j]); clears = scheme_make_pair(scheme_make_integer(pos), clears); } le = cseq->array[0]; } if (!SAME_TYPE(SCHEME_TYPE(le), scheme_unclosed_procedure_type) && !SAME_TYPE(SCHEME_TYPE(le), scheme_closure_type)) { scheme_signal_error("internal error: not a lambda for case-lambda: %d", SCHEME_TYPE(le)); } seq->array[i] = le; } if (!SCHEME_NULLP(clears)) { return scheme_sfs_add_clears(expr, clears, 0); } else return expr; }
static Scheme_Object *sfs_sequence(Scheme_Object *o, SFS_Info *info, int can_flatten) { Scheme_Object *orig, *naya; Scheme_Sequence *seq; int i, n; seq = (Scheme_Sequence *)o; n = seq->count; scheme_sfs_start_sequence(info, n, 1); for (i = 0; i < n; i++) { orig = seq->array[i]; naya = scheme_sfs_expr(orig, info, -2); seq->array[i] = naya; } if (can_flatten && info->pass) o = flatten_sequence(o); return o; }
static Scheme_Object *sfs_letrec(Scheme_Object *o, SFS_Info *info) { Scheme_Letrec *lr = (Scheme_Letrec *)o; Scheme_Object **procs, *v, *clears = scheme_null; int i, count; count = lr->count; scheme_sfs_start_sequence(info, count + 1, 1); procs = lr->procs; for (i = 0; i < count; i++) { v = scheme_sfs_expr(procs[i], info, i); if (SAME_TYPE(SCHEME_TYPE(v), scheme_begin0_sequence_type)) { /* Some clearing actions were added to the closure. Lift them out. */ int j; Scheme_Sequence *cseq = (Scheme_Sequence *)v; for (j = 1; j < cseq->count; j++) { int pos; pos = SCHEME_LOCAL_POS(cseq->array[j]); clears = scheme_make_pair(scheme_make_integer(pos), clears); } v = cseq->array[0]; } procs[i] = v; } v = scheme_sfs_expr(lr->body, info, -1); v = scheme_sfs_add_clears(v, clears, 1); lr->body = v; return o; }
static Scheme_Object *sfs_application(Scheme_Object *o, SFS_Info *info) { Scheme_Object *orig, *naya = NULL; Scheme_App_Rec *app; int i, n; app = (Scheme_App_Rec *)o; n = app->num_args + 1; scheme_sfs_start_sequence(info, n, 0); scheme_sfs_push(info, n-1, 0); for (i = 0; i < n; i++) { orig = app->args[i]; naya = scheme_sfs_expr(orig, info, -1); app->args[i] = naya; } sfs_note_app(info, app->args[0]); scheme_finish_application(app); return o; }
static Scheme_Object *sfs_application3(Scheme_Object *o, SFS_Info *info) { Scheme_App3_Rec *app; Scheme_Object *nrator, *nrand1, *nrand2; app = (Scheme_App3_Rec *)o; scheme_sfs_start_sequence(info, 3, 0); scheme_sfs_push(info, 2, 0); nrator = scheme_sfs_expr(app->rator, info, -1); nrand1 = scheme_sfs_expr(app->rand1, info, -1); nrand2 = scheme_sfs_expr(app->rand2, info, -1); app->rator = nrator; app->rand1 = nrand1; app->rand2 = nrand2; sfs_note_app(info, app->rator); scheme_reset_app3_eval_type(app); return o; }
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; }