suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

enable inlining of calls to `case-lambda' procedures

Browse Source 
which includes calls to procedures with optional (but no keyword)
 arguments
This commit is contained in:
Matthew Flatt 2011-04-19 21:21:46 -06:00
parent 25017ef3c1
commit 1932a453a8
9 changed files with 997 additions and 841 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/tests/racket/optimize.rktl
View File

@ -1063,6 +1063,12 @@
'(let ([f (lambda (x) x)]) '(let ([f (lambda (x) x)])
(list f))) (list f)))
(test-comp '(letrec ([f (case-lambda
[(x) x]
[(x y) (f (+ x y))])])
(f 10))
'10)
(test-comp '(procedure-arity-includes? integer? 1) (test-comp '(procedure-arity-includes? integer? 1)
#t) #t)

1559
src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

8
src/racket/src/env.c
View File

@ -3346,7 +3346,7 @@ static void register_stat_dist(Optimize_Info *info, int i, int j)
/* We're using a procedure that we weren't sure would be used. /* We're using a procedure that we weren't sure would be used.
Transitively mark everything that the procedure uses --- unless Transitively mark everything that the procedure uses --- unless
a transitive accumulation is in effect, in which case we a transitive accumulation is in effect, in which case we
don't for this one now, leaving it to be triggered when don't follow this one now, leaving it to be triggered when
the one we're accumulating is triggered. */ the one we're accumulating is triggered. */
if (!info->transitive_use_pos) { if (!info->transitive_use_pos) {
mzshort *map = info->transitive_use[i]; mzshort *map = info->transitive_use[i];
@ -3704,6 +3704,12 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
break; break;
else else
*closure_offset = delta; *closure_offset = delta;
} else if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_syntax_type)
&& (SCHEME_PINT_VAL(n) == CASE_LAMBDA_EXPD)) {
if (!closure_offset)
break;
else
*closure_offset = delta;
} else if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_toplevel_type)) { } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_toplevel_type)) {
/* Ok */ /* Ok */
} else if (closure_offset) { } else if (closure_offset) {

43
src/racket/src/eval.c
View File

@ -777,6 +777,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
&& (SCHEME_LOCAL_POS(o) > deeper_than)) && (SCHEME_LOCAL_POS(o) > deeper_than))
|| (vtype == scheme_unclosed_procedure_type) || (vtype == scheme_unclosed_procedure_type)
|| (vtype == scheme_compiled_unclosed_procedure_type) || (vtype == scheme_compiled_unclosed_procedure_type)
|| ((vtype == scheme_compiled_syntax_type) && (SCHEME_PINT_VAL(o) == CASE_LAMBDA_EXPD))
|| (vtype == scheme_case_lambda_sequence_type) || (vtype == scheme_case_lambda_sequence_type)
|| (vtype == scheme_quote_syntax_type) || (vtype == scheme_quote_syntax_type)
|| (vtype == scheme_compiled_quote_syntax_type)) { || (vtype == scheme_compiled_quote_syntax_type)) {
@ -2374,7 +2375,18 @@ static int estimate_expr_size(Scheme_Object *expr, int sz, int fuel)
} }
case scheme_compiled_syntax_type: case scheme_compiled_syntax_type:
{ {
sz += 1; /* FIXME */ if (SCHEME_PINT_VAL(expr) == CASE_LAMBDA_EXPD) {
int max_sz = sz + 1, a_sz;
Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)SCHEME_IPTR_VAL(expr);
int i;
for (i = cl->count; i--; ) {
a_sz = estimate_expr_size(cl->array[i], sz, fuel);
if (a_sz > max_sz) max_sz = a_sz;
}
sz = max_sz;
} else {
sz += 1; /* FIXME */
}
break; break;
} }
case scheme_application2_type: case scheme_application2_type:
@ -2652,6 +2664,35 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
} }
} }
if (le
&& SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_syntax_type)
&& (SCHEME_PINT_VAL(le) == CASE_LAMBDA_EXPD)) {
Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)SCHEME_IPTR_VAL(le);
Scheme_Object *cp;
int i, count;
if (!app && !app2 && !app3)
return le;
count = cl->count;
for (i = 0; i < count; i++) {
cp = cl->array[i];
if (SAME_TYPE(SCHEME_TYPE(cp), scheme_compiled_unclosed_procedure_type)) {
Scheme_Closure_Data *data = (Scheme_Closure_Data *)cp;
if ((data->num_params == argc)
|| ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
&& (argc + 1 >= data->num_params))) {
le = cp;
break;
}
} else {
scheme_signal_error("internal error: strange case-lambda");
}
}
if (i >= count)
bad_app = le;
}
if (le && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) { if (le && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) {
Scheme_Closure_Data *data = (Scheme_Closure_Data *)le; Scheme_Closure_Data *data = (Scheme_Closure_Data *)le;
int sz; int sz;

6
src/racket/src/fun.c
View File

@ -3576,6 +3576,12 @@ const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error)
name = ((Scheme_Closure_Data *)p)->name; name = ((Scheme_Closure_Data *)p)->name;
} else if (type == scheme_closure_type) { } else if (type == scheme_closure_type) {
name = SCHEME_COMPILED_CLOS_CODE(p)->name; name = SCHEME_COMPILED_CLOS_CODE(p)->name;
} else if (type == scheme_compiled_syntax_type) {
Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)SCHEME_IPTR_VAL(p);
if (!cl->count)
name = NULL;
else
name = ((Scheme_Closure_Data *)cl->array[0])->name;
} else { } else {
/* Native closure: */ /* Native closure: */
name = ((Scheme_Native_Closure *)p)->code->u2.name; name = ((Scheme_Native_Closure *)p)->code->u2.name;

16
src/racket/src/module.c
View File

@ -5619,7 +5619,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
n = scheme_list_length(vars); n = scheme_list_length(vars);
if (n == 1) { if (n == 1) {
if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_unclosed_procedure_type)) { if (IS_COMPILED_PROC(e)) {
Scheme_Toplevel *tl; Scheme_Toplevel *tl;
tl = (Scheme_Toplevel *)SCHEME_CAR(vars); tl = (Scheme_Toplevel *)SCHEME_CAR(vars);
@ -5656,7 +5656,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
Scheme_Object *e2; Scheme_Object *e2;
e2 = (Scheme_Object *)SCHEME_IPTR_VAL(e); e2 = (Scheme_Object *)SCHEME_IPTR_VAL(e);
e2 = SCHEME_CDR(e2); e2 = SCHEME_CDR(e2);
if (SAME_TYPE(SCHEME_TYPE(e2), scheme_compiled_unclosed_procedure_type)) if (IS_COMPILED_PROC(e2))
is_proc_def = 1; is_proc_def = 1;
} }
} }
@ -5710,7 +5710,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
if (sproc) { if (sproc) {
e2 = scheme_make_noninline_proc(e); e2 = scheme_make_noninline_proc(e);
} else if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_unclosed_procedure_type)) { } else if (IS_COMPILED_PROC(e)) {
e2 = scheme_optimize_clone(1, e, info, 0, 0); e2 = scheme_optimize_clone(1, e, info, 0, 0);
if (e2) { if (e2) {
Scheme_Object *pr; Scheme_Object *pr;
@ -5812,8 +5812,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
Scheme_Object *sub_e; Scheme_Object *sub_e;
sub_e = (Scheme_Object *)SCHEME_IPTR_VAL(e); sub_e = (Scheme_Object *)SCHEME_IPTR_VAL(e);
sub_e = SCHEME_CDR(sub_e); sub_e = SCHEME_CDR(sub_e);
if (SAME_TYPE(SCHEME_TYPE(sub_e), scheme_compiled_unclosed_procedure_type)) if (IS_COMPILED_PROC(sub_e))
old_sz = scheme_closure_body_size((Scheme_Closure_Data *)sub_e, 0, NULL, NULL); old_sz = scheme_compiled_proc_body_size(sub_e);
else else
old_sz = 0; old_sz = 0;
} else } else
@ -5838,7 +5838,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
don't replace that with a worse approximation. */ don't replace that with a worse approximation. */
Scheme_Object *old_e; Scheme_Object *old_e;
old_e = scheme_hash_get(info->top_level_consts, rpos); old_e = scheme_hash_get(info->top_level_consts, rpos);
if (SAME_TYPE(SCHEME_TYPE(old_e), scheme_compiled_unclosed_procedure_type)) if (IS_COMPILED_PROC(old_e))
e = NULL; e = NULL;
else else
e = scheme_make_noninline_proc(e); e = scheme_make_noninline_proc(e);
@ -5846,8 +5846,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
if (e) { if (e) {
if (OPT_LIMIT_FUNCTION_RESIZE) { if (OPT_LIMIT_FUNCTION_RESIZE) {
if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_unclosed_procedure_type)) if (IS_COMPILED_PROC(e))
new_sz = scheme_closure_body_size((Scheme_Closure_Data *)e, 0, NULL, NULL); new_sz = scheme_compiled_proc_body_size(e);
else else
new_sz = 0; new_sz = 0;
} else } else

5
src/racket/src/schpriv.h
View File

@ -2499,6 +2499,11 @@ Scheme_Object *scheme_protect_quote(Scheme_Object *expr);
Scheme_Object *scheme_make_syntax_resolved(int idx, Scheme_Object *data); Scheme_Object *scheme_make_syntax_resolved(int idx, Scheme_Object *data);
Scheme_Object *scheme_make_syntax_compiled(int idx, Scheme_Object *data); Scheme_Object *scheme_make_syntax_compiled(int idx, Scheme_Object *data);
#define IS_COMPILED_PROC(vals_expr) (SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_compiled_unclosed_procedure_type) \
|| (SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_compiled_syntax_type) \
&& (SCHEME_PINT_VAL(vals_expr) == CASE_LAMBDA_EXPD)))
int scheme_compiled_proc_body_size(Scheme_Object *o);
Scheme_Object *scheme_optimize_expr(Scheme_Object *, Optimize_Info *, int context); Scheme_Object *scheme_optimize_expr(Scheme_Object *, Optimize_Info *, int context);
Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context); Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context);

4
src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "5.1.1.2" #define MZSCHEME_VERSION "5.1.1.3"
#define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 1 #define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 2 #define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

191
src/racket/src/syntax.c
View File

@ -132,6 +132,7 @@ static Scheme_Object *begin0_clone(int dup_ok, Scheme_Object *data, Optimize_Inf
static Scheme_Object *set_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth); static Scheme_Object *set_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *apply_values_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth); static Scheme_Object *apply_values_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *splice_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth); static Scheme_Object *splice_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *case_lambda_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *begin0_shift(Scheme_Object *data, int delta, int after_depth); static Scheme_Object *begin0_shift(Scheme_Object *data, int delta, int after_depth);
static Scheme_Object *set_shift(Scheme_Object *data, int delta, int after_depth); static Scheme_Object *set_shift(Scheme_Object *data, int delta, int after_depth);
@ -323,7 +324,7 @@ scheme_init_syntax (Scheme_Env *env)
case_lambda_optimize, case_lambda_optimize,
case_lambda_resolve, case_lambda_sfs, case_lambda_validate, case_lambda_resolve, case_lambda_sfs, case_lambda_validate,
case_lambda_execute, case_lambda_jit, case_lambda_execute, case_lambda_jit,
NULL, case_lambda_shift, -1); case_lambda_clone, case_lambda_shift, -1);
scheme_register_syntax(BEGIN0_EXPD, scheme_register_syntax(BEGIN0_EXPD,
begin0_optimize, begin0_optimize,
begin0_resolve, begin0_sfs, begin0_validate, begin0_resolve, begin0_sfs, begin0_validate,
@ -797,7 +798,9 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) { if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) {
int flags = GLOB_IS_IMMUTATED; int flags = GLOB_IS_IMMUTATED;
if (SCHEME_PROCP(vals_expr) if (SCHEME_PROCP(vals_expr)
|| SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_unclosed_procedure_type)) || SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_unclosed_procedure_type)
|| (SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_syntax_type)
&& (SCHEME_PINT_VAL(vals_expr) == CASE_LAMBDA_EXPD)))
flags |= GLOB_IS_CONSISTENT; flags |= GLOB_IS_CONSISTENT;
((Scheme_Bucket_With_Flags *)b)->flags |= flags; ((Scheme_Bucket_With_Flags *)b)->flags |= flags;
} }
@ -2436,20 +2439,78 @@ case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info, int context)
Scheme_Object *le; Scheme_Object *le;
int i; int i;
Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr; Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;
mzshort **tus, *tu;
int *tu_lens, tup, tu_count = 0;
if (info->transitive_use_pos) {
/* We'll need to merge transitive_use arrays */
tup = info->transitive_use_pos - 1;
tus = (mzshort **)MALLOC_N(mzshort*, seq->count);
tu_lens = (int*)MALLOC_N_ATOMIC(int, seq->count);
} else {
tup = 0;
tus = NULL;
tu_lens = NULL;
}
for (i = 0; i < seq->count; i++) { for (i = 0; i < seq->count; i++) {
le = seq->array[i]; le = seq->array[i];
le = scheme_optimize_expr(le, info, 0); le = scheme_optimize_expr(le, info, 0);
seq->array[i] = le; seq->array[i] = le;
if (tus) {
tus[i] = info->transitive_use[tup];
tu_lens[i] = info->transitive_use_len[tup];
if (tus[i]) {
tu_count += tu_lens[i];
}
info->transitive_use[tup] = NULL;
info->transitive_use_len[tup] = 0;
}
} }
info->preserves_marks = 1; info->preserves_marks = 1;
info->single_result = 1; info->single_result = 1;
info->size += 1; info->size += 1;
if (tu_count) {
tu = MALLOC_N_ATOMIC(mzshort, tu_count);
tu_count = 0;
for (i = 0; i < seq->count; i++) {
if (tus[i]) {
memcpy(tu + tu_count, tus[i], tu_lens[i] * sizeof(mzshort));
tu_count += tu_lens[i];
}
}
info->transitive_use[tup] = tu;
info->transitive_use_len[tup] = tu_count;
}
return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, expr); return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, expr);
} }
static Scheme_Object *
case_lambda_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
{
Scheme_Object *le;
int i, sz;
Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data;
Scheme_Case_Lambda *seq2;
sz = sizeof(Scheme_Case_Lambda) + ((seq->count - 1) * sizeof(Scheme_Object*));
seq2 = (Scheme_Case_Lambda *)scheme_malloc_tagged(sz);
memcpy(seq2, seq, sz);
for (i = 0; i < seq->count; i++) {
le = seq->array[i];
le = scheme_optimize_clone(dup_ok, le, info, delta, closure_depth);
if (!le) return NULL;
seq2->array[i] = le;
}
return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, (Scheme_Object *)seq2);
}
static Scheme_Object * static Scheme_Object *
case_lambda_shift(Scheme_Object *data, int delta, int after_depth) case_lambda_shift(Scheme_Object *data, int delta, int after_depth)
{ {
@ -2795,6 +2856,8 @@ static int is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator)
switch (t) { switch (t) {
case scheme_compiled_unclosed_procedure_type: case scheme_compiled_unclosed_procedure_type:
return !as_rator; return !as_rator;
case scheme_compiled_syntax_type:
return (!as_rator && (SCHEME_PINT_VAL(o) == CASE_LAMBDA_EXPD));
case scheme_compiled_toplevel_type: case scheme_compiled_toplevel_type:
return 1; return 1;
case scheme_local_type: case scheme_local_type:
@ -2891,6 +2954,18 @@ int scheme_compiled_propagate_ok(Scheme_Object *value, Optimize_Info *info)
return 1; return 1;
} }
if (SAME_TYPE(scheme_compiled_syntax_type, SCHEME_TYPE(value))
&& (SCHEME_PINT_VAL(value) == CASE_LAMBDA_EXPD)) {
Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)SCHEME_IPTR_VAL(value);
int i;
for (i = cl->count; i--; ) {
if (!scheme_compiled_propagate_ok(cl->array[i], info))
return 0;
}
return 1;
}
if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_toplevel_type)) { if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_toplevel_type)) {
if (info->top_level_consts) { if (info->top_level_consts) {
int pos; int pos;
@ -2996,16 +3071,17 @@ static Scheme_Object *make_clones(Scheme_Compiled_Let_Value *retry_start,
clv = retry_start; clv = retry_start;
while (1) { while (1) {
value = clv->value; value = clv->value;
if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)) { if (IS_COMPILED_PROC(value)) {
clone = scheme_optimize_clone(1, value, body_info, 0, 0); clone = scheme_optimize_clone(1, value, body_info, 0, 0);
if (clone) { if (clone) {
pr = scheme_make_raw_pair(scheme_make_raw_pair(value, clone), NULL); pr = scheme_make_raw_pair(scheme_make_raw_pair(value, clone), NULL);
if (last) } else
SCHEME_CDR(last) = pr; pr = scheme_make_raw_pair(NULL, NULL);
else if (last)
first = pr; SCHEME_CDR(last) = pr;
last = pr; else
} first = pr;
last = pr;
} }
if (clv == pre_body) if (clv == pre_body)
break; break;
@ -3021,10 +3097,12 @@ static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
int set_flags, int mask_flags, int just_tentative, int set_flags, int mask_flags, int just_tentative,
int merge_flonum) int merge_flonum)
{ {
Scheme_Case_Lambda *cl, *cl2, *cl3;
Scheme_Compiled_Let_Value *clv; Scheme_Compiled_Let_Value *clv;
Scheme_Object *value, *first; Scheme_Object *value, *first;
int flags = CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS; int flags = CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS;
Scheme_Closure_Data *data; Scheme_Closure_Data *data, *data2, *data3;
int i, count;
/* The first in a clone pair is the one that is consulted for /* The first in a clone pair is the one that is consulted for
references. The second one is the clone, and it's the one whose references. The second one is the clone, and it's the one whose
@ -3034,24 +3112,45 @@ static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
clv = retry_start; clv = retry_start;
while (clones) { while (clones) {
value = clv->value; value = clv->value;
if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) { if (IS_COMPILED_PROC(value)) {
data = (Scheme_Closure_Data *)value;
first = SCHEME_CAR(clones); first = SCHEME_CAR(clones);
if (merge_flonum) { if (first) {
scheme_merge_closure_flonum_map(data, (Scheme_Closure_Data *)SCHEME_CAR(first)); if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) {
scheme_merge_closure_flonum_map(data, (Scheme_Closure_Data *)SCHEME_CDR(first)); count = 1;
scheme_merge_closure_flonum_map(data, (Scheme_Closure_Data *)SCHEME_CAR(first)); cl = NULL;
} cl2 = NULL;
cl3 = NULL;
} else {
cl = (Scheme_Case_Lambda *)SCHEME_IPTR_VAL(value);
cl2 = (Scheme_Case_Lambda *)SCHEME_IPTR_VAL(SCHEME_CAR(first));
cl3 = (Scheme_Case_Lambda *)SCHEME_IPTR_VAL(SCHEME_CDR(first));
count = cl->count;
}
for (i = 0; i < count; i++) {
if (cl) {
data = (Scheme_Closure_Data *)cl->array[i];
data2 = (Scheme_Closure_Data *)cl2->array[i];
data3 = (Scheme_Closure_Data *)cl3->array[i];
} else {
data = (Scheme_Closure_Data *)value;
data2 = (Scheme_Closure_Data *)SCHEME_CAR(first);
data3 = (Scheme_Closure_Data *)SCHEME_CDR(first);
}
if (merge_flonum) {
scheme_merge_closure_flonum_map(data, data2);
scheme_merge_closure_flonum_map(data, data3);
scheme_merge_closure_flonum_map(data, data2);
}
if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) { if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) {
flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data)); flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data));
SCHEME_CLOSURE_DATA_FLAGS(data2) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data2) & mask_flags);
data = (Scheme_Closure_Data *)SCHEME_CDR(first); SCHEME_CLOSURE_DATA_FLAGS(data3) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data3) & mask_flags);
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags); }
data = (Scheme_Closure_Data *)SCHEME_CAR(first); }
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
} }
clones = SCHEME_CDR(clones); clones = SCHEME_CDR(clones);
@ -3065,12 +3164,25 @@ static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
return flags; return flags;
} }
static int expr_size(Scheme_Object *o, Optimize_Info *info) int scheme_compiled_proc_body_size(Scheme_Object *o)
{ {
if (SAME_TYPE(SCHEME_TYPE(o), scheme_compiled_unclosed_procedure_type)) if (SAME_TYPE(SCHEME_TYPE(o), scheme_compiled_unclosed_procedure_type))
return scheme_closure_body_size((Scheme_Closure_Data *)o, 0, NULL, NULL) + 1; return scheme_closure_body_size((Scheme_Closure_Data *)o, 0, NULL, NULL);
else else if (SAME_TYPE(SCHEME_TYPE(o), scheme_compiled_syntax_type)
return 1; && (SCHEME_PINT_VAL(o) == CASE_LAMBDA_EXPD)) {
Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)SCHEME_IPTR_VAL(o);
int i, sz = 0;
for (i = cl->count; i--; ) {
sz += scheme_closure_body_size((Scheme_Closure_Data *)cl->array[i], 0, NULL, NULL);
}
return sz;
} else
return 0;
}
static int expr_size(Scheme_Object *o, Optimize_Info *info)
{
return scheme_compiled_proc_body_size(o) + 1;
} }
static int might_invoke_call_cc(Scheme_Object *value) static int might_invoke_call_cc(Scheme_Object *value)
@ -3083,6 +3195,7 @@ static int worth_lifting(Scheme_Object *v)
Scheme_Type lhs; Scheme_Type lhs;
lhs = SCHEME_TYPE(v); lhs = SCHEME_TYPE(v);
if ((lhs == scheme_compiled_unclosed_procedure_type) if ((lhs == scheme_compiled_unclosed_procedure_type)
|| ((lhs == scheme_compiled_syntax_type) && (SCHEME_PINT_VAL(v) == CASE_LAMBDA_EXPD))
|| (lhs == scheme_local_type) || (lhs == scheme_local_type)
|| (lhs == scheme_compiled_toplevel_type) || (lhs == scheme_compiled_toplevel_type)
|| (lhs == scheme_compiled_quote_syntax_type) || (lhs == scheme_compiled_quote_syntax_type)
@ -3315,7 +3428,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
pos = pre_body->position; pos = pre_body->position;
if ((pre_body->count == 1) if ((pre_body->count == 1)
&& SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(pre_body->value)) && IS_COMPILED_PROC(pre_body->value)
&& !(pre_body->flags[0] & SCHEME_WAS_SET_BANGED)) { && !(pre_body->flags[0] & SCHEME_WAS_SET_BANGED)) {
scheme_optimize_propagate(body_info, pos, scheme_estimate_closure_size(pre_body->value), 0); scheme_optimize_propagate(body_info, pos, scheme_estimate_closure_size(pre_body->value), 0);
} }
@ -3360,7 +3473,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
size_before_opt = body_info->size; size_before_opt = body_info->size;
if ((pre_body->count == 1) if ((pre_body->count == 1)
&& SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(pre_body->value)) && IS_COMPILED_PROC(pre_body->value)
&& !scheme_optimize_is_used(body_info, pos)) { && !scheme_optimize_is_used(body_info, pos)) {
if (!body_info->transitive_use) { if (!body_info->transitive_use) {
mzshort **tu; mzshort **tu;
@ -3375,7 +3488,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
} }
if (is_rec && OPT_DISCOURAGE_EARLY_INLINE && !rhs_info->letrec_not_twice if (is_rec && OPT_DISCOURAGE_EARLY_INLINE && !rhs_info->letrec_not_twice
&& SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(pre_body->value))) { && IS_COMPILED_PROC(pre_body->value)) {
inline_fuel = rhs_info->inline_fuel; inline_fuel = rhs_info->inline_fuel;
if (inline_fuel > 2) if (inline_fuel > 2)
rhs_info->inline_fuel = 2; rhs_info->inline_fuel = 2;
@ -3630,9 +3743,11 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
cl = clones; cl = clones;
while (1) { while (1) {
value = clv->value; value = clv->value;
if (cl) if (cl) {
cl_first = SCHEME_CAR(cl); cl_first = SCHEME_CAR(cl);
else if (!cl_first)
cl = SCHEME_CDR(cl);
} else
cl_first = NULL; cl_first = NULL;
if (cl_first && SAME_OBJ(value, SCHEME_CAR(cl_first))) { if (cl_first && SAME_OBJ(value, SCHEME_CAR(cl_first))) {
/* Try optimization. */ /* Try optimization. */
@ -3651,7 +3766,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
self_value = SCHEME_CDR(cl_first); self_value = SCHEME_CDR(cl_first);
/* Drop old size, and remove old inline fuel: */ /* Drop old size, and remove old inline fuel: */
sz = scheme_closure_body_size((Scheme_Closure_Data *)value, 0, NULL, NULL); sz = scheme_compiled_proc_body_size(value);
rhs_info->size -= (sz + 1); rhs_info->size -= (sz + 1);
/* Setting letrec_not_twice prevents inlinining /* Setting letrec_not_twice prevents inlinining
@ -3676,9 +3791,9 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
/* Register re-optimized as the value for the binding, but /* Register re-optimized as the value for the binding, but
maybe only if it didn't grow too much: */ maybe only if it didn't grow too much: */
int new_sz; int new_sz;
if (OPT_LIMIT_FUNCTION_RESIZE) { if (OPT_LIMIT_FUNCTION_RESIZE)
new_sz = scheme_closure_body_size((Scheme_Closure_Data *)value, 0, NULL, NULL); new_sz = scheme_compiled_proc_body_size(value);
} else else
new_sz = 0; new_sz = 0;
if (new_sz < 4 * sz) if (new_sz < 4 * sz)
scheme_optimize_propagate(body_info, clv->position, value, 0); scheme_optimize_propagate(body_info, clv->position, value, 0);