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

improve inling to support ((let (....) (lambda ....)) arg ...) patterns; allow nested 'let's for local flonum binding (which fixes a problem where unsafe flonum operations could end up much slower than safe ones)

Browse Source 
svn: r17972
This commit is contained in:
Matthew Flatt 2010-02-05 00:16:06 +00:00
parent 318833f422
commit 3812f8ca72
7 changed files with 348 additions and 165 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/compiler/decompile.ss
View File

@ -307,7 +307,12 @@
null) null)
,@(if (null? captures) ,@(if (null? captures)
null null
`('(captures: ,@captures))) `('(captures: ,@(map (lambda (c t)
(if (eq? t 'flonum)
`(flonum ,c)
c))
captures
closure-types))))
,(decompile-expr body globs ,(decompile-expr body globs
(append captures (append captures
(append vars rest-vars)) (append vars rest-vars))

47
collects/tests/mzscheme/benchmarks/shootout/spectralnorm-unsafe.ss
View File

@ -6,8 +6,14 @@
#lang scheme/base #lang scheme/base
(require scheme/cmdline (require scheme/cmdline
scheme/flonum scheme/require (for-syntax scheme/base)
scheme/unsafe/ops) (rename-in
(filtered-in
(lambda (name) (regexp-replace #rx"unsafe-" name ""))
scheme/unsafe/ops)
[fx->fl ->fl])
(only-in scheme/flonum make-flvector))
(define (Approximate n) (define (Approximate n)
(let ([u (make-flvector n 1.0)] (let ([u (make-flvector n 1.0)]
@ -21,37 +27,33 @@
;; v.Bv /(v.v) eigenvalue of v ;; v.Bv /(v.v) eigenvalue of v
(let loop ([i 0][vBv 0.0][vv 0.0]) (let loop ([i 0][vBv 0.0][vv 0.0])
(if (= i n) (if (= i n)
(unsafe-flsqrt (unsafe-fl/ vBv vv)) (flsqrt (fl/ vBv vv))
(let ([vi (unsafe-flvector-ref v i)]) (let ([vi (flvector-ref v i)])
(loop (unsafe-fx+ 1 i) (loop (add1 i)
(unsafe-fl+ vBv (unsafe-fl* (unsafe-flvector-ref u i) vi)) (fl+ vBv (fl* (flvector-ref u i) vi))
(unsafe-fl+ vv (unsafe-fl* vi vi)))))))) (fl+ vv (fl* vi vi))))))))
;; return element i,j of infinite matrix A ;; return element i,j of infinite matrix A
(define (A i j) (define (A i j)
(unsafe-fl/ 1.0 (fl/ 1.0 (fl+ (fl* (->fl (+ i j))
(unsafe-fl+ (fl/ (->fl (+ i (+ j 1))) 2.0))
(unsafe-fl* (unsafe-fx->fl (unsafe-fx+ i j)) (->fl (+ i 1)))))
(unsafe-fl/ (unsafe-fx->fl
(unsafe-fx+ i (unsafe-fx+ j 1)))
2.0))
(unsafe-fx->fl (unsafe-fx+ i 1)))))
;; multiply vector v by matrix A ;; multiply vector v by matrix A
(define (MultiplyAv n v Av) (define (MultiplyAv n v Av)
(for ([i (in-range n)]) (for ([i (in-range n)])
(unsafe-flvector-set! Av i (flvector-set! Av i
(for/fold ([r 0.0]) (for/fold ([r 0.0])
([j (in-range n)]) ([j (in-range n)])
(unsafe-fl+ r (unsafe-fl* (A i j) (unsafe-flvector-ref v j))))))) (fl+ r (fl* (A i j) (flvector-ref v j)))))))
;; multiply vector v by matrix A transposed ;; multiply vector v by matrix A transposed
(define (MultiplyAtv n v Atv) (define (MultiplyAtv n v Atv)
(for ([i (in-range n)]) (for ([i (in-range n)])
(unsafe-flvector-set! Atv i (flvector-set! Atv i
(for/fold ([r 0.0]) (for/fold ([r 0.0])
([j (in-range n)]) ([j (in-range n)])
(unsafe-fl+ r (unsafe-fl* (A j i) (unsafe-flvector-ref v j))))))) (fl+ r (fl* (A j i) (flvector-ref v j)))))))
;; multiply vector v by matrix A and then by matrix A transposed ;; multiply vector v by matrix A and then by matrix A transposed
(define (MultiplyAtAv n v AtAv) (define (MultiplyAtAv n v AtAv)
@ -63,4 +65,3 @@
(real->decimal-string (real->decimal-string
(Approximate (command-line #:args (n) (string->number n))) (Approximate (command-line #:args (n) (string->number n)))
9)) 9))

13
collects/tests/mzscheme/optimize.ss
View File

@ -670,6 +670,19 @@
(test-comp '(let ([x (list 3 4)]) x) (test-comp '(let ([x (list 3 4)]) x)
'(let ([f (lambda (a . b) b)]) '(let ([f (lambda (a . b) b)])
(f 5 3 4))) (f 5 3 4)))
(test-comp '(lambda (g)
((let ([r (read)])
(lambda () (+ r r)))))
'(lambda (g)
(let ([r (read)])
(+ r r))))
(test-comp '(lambda (g)
((let ([r (read)])
(lambda (x) (+ r r)))
g))
'(lambda (g)
(let ([r (read)])
(+ r r))))
(test-comp '(let ([x 1][y 2]) x) (test-comp '(let ([x 1][y 2]) x)
'1) '1)

253
src/mzscheme/src/eval.c
View File

@ -2431,7 +2431,8 @@ Scheme_Object *scheme_no_potential_size(Scheme_Object *v)
static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data, Optimize_Info *info, static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data, Optimize_Info *info,
int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3,
int context) int context,
int nested_count, Scheme_Object *orig, Scheme_Object *le_prev, long prev_offset)
{ {
Scheme_Let_Header *lh; Scheme_Let_Header *lh;
Scheme_Compiled_Let_Value *lv, *prev = NULL; Scheme_Compiled_Let_Value *lv, *prev = NULL;
@ -2441,13 +2442,20 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
expected = data->num_params; expected = data->num_params;
if (!expected) { if (!expected) {
info = scheme_optimize_info_add_frame(info, 0, 0, 0); info = scheme_optimize_info_add_frame(info, nested_count, nested_count, 0);
info->inline_fuel >>= 1; info->inline_fuel >>= 1;
if (nested_count) info->vclock++;
p = scheme_optimize_expr(p, info, context); p = scheme_optimize_expr(p, info, context);
info->next->single_result = info->single_result; info->next->single_result = info->single_result;
info->next->preserves_marks = info->preserves_marks; if (!nested_count)
info->next->preserves_marks = info->preserves_marks;
scheme_optimize_info_done(info); scheme_optimize_info_done(info);
return p;
if (le_prev) {
*((Scheme_Object **)(((char *)le_prev) + prev_offset)) = p;
return orig;
} else
return p;
} }
lh = MALLOC_ONE_TAGGED(Scheme_Let_Header); lh = MALLOC_ONE_TAGGED(Scheme_Let_Header);
@ -2506,7 +2514,13 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
else else
lh->body = p; lh->body = p;
return scheme_optimize_lets((Scheme_Object *)lh, info, 1, context); p = scheme_optimize_lets((Scheme_Object *)lh, info, 1 + nested_count, context);
if (le_prev) {
*((Scheme_Object **)(((char *)le_prev) + prev_offset)) = p;
return orig;
} else
return p;
} }
#if 0 #if 0
@ -2517,24 +2531,45 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int argc, Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int argc,
Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3,
int *_flags, int context) int *_flags, int context, int optimized_rator)
/* If not app, app2, or app3, just return a known procedure, if any, /* If not app, app2, or app3, just return a known procedure, if any,
and do not check arity. */ and do not check arity. */
{ {
int offset = 0, single_use = 0, psize = 0; int offset = 0, single_use = 0, psize = 0;
Scheme_Object *bad_app = NULL; Scheme_Object *bad_app = NULL, *prev = NULL, *orig_le = le;
long prev_offset = 0;
int nested_count = 0;
if (info->inline_fuel < 0) if (info->inline_fuel < 0)
return NULL; return NULL;
/* Move inside `let' bindings, so we can convert ((let (....) proc) arg ...)
to (let (....) (proc arg ...)) */
while (optimized_rator && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_let_void_type)) {
Scheme_Let_Header *lh;
int i;
lh = (Scheme_Let_Header *)le;
prev = le;
prev_offset = (long)&(((Scheme_Let_Header *)0x0)->body);
le = lh->body;
for (i = 0; i < lh->num_clauses; i++) {
prev = le;
prev_offset = (long)&(((Scheme_Compiled_Let_Value *)0x0)->body);
le = ((Scheme_Compiled_Let_Value *)le)->body;
}
nested_count += lh->count;
}
if (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) { if (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) {
/* Found a `((lambda' */ /* Found a `((lambda' */
single_use = 1; single_use = 1;
} }
if (SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) { if (!optimized_rator && SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) {
/* Check for inlining: */ /* Check for inlining: */
le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le), &offset, &single_use, 0, 0, &psize); if (SCHEME_LOCAL_POS(le) >= nested_count)
le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le) - nested_count, &offset, &single_use, 0, 0, &psize);
} }
if (le) { if (le) {
@ -2574,10 +2609,16 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
threshold = info->inline_fuel * (2 + argc); threshold = info->inline_fuel * (2 + argc);
if ((sz >= 0) && (single_use || (sz <= threshold))) { if ((sz >= 0) && (single_use || (sz <= threshold))) {
le = scheme_optimize_clone(0, data->code, info, offset, data->num_params); Optimize_Info *sub_info;
if (nested_count)
sub_info = scheme_optimize_info_add_frame(info, nested_count, nested_count, 0);
else
sub_info = info;
le = scheme_optimize_clone(0, data->code, sub_info, offset, data->num_params);
if (le) { if (le) {
LOG_INLINE(fprintf(stderr, "Inline %d %d %s\n", sz, single_use, data->name ? scheme_write_to_string(data->name, NULL) : "???")); LOG_INLINE(fprintf(stderr, "Inline %d %d %s\n", sz, single_use, data->name ? scheme_write_to_string(data->name, NULL) : "???"));
return apply_inlined(le, data, info, argc, app, app2, app3, context); return apply_inlined(le, data, info, argc, app, app2, app3, context,
nested_count, orig_le, prev, prev_offset);
} else { } else {
LOG_INLINE(fprintf(stderr, "No inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???")); LOG_INLINE(fprintf(stderr, "No inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???"));
} }
@ -3058,31 +3099,43 @@ static int is_unboxed_argument(Scheme_Object *rand, int fuel, Optimize_Info *inf
int scheme_expr_produces_flonum(Scheme_Object *expr) int scheme_expr_produces_flonum(Scheme_Object *expr)
{ {
switch (SCHEME_TYPE(expr)) { while (1) {
case scheme_application_type: switch (SCHEME_TYPE(expr)) {
{ case scheme_application_type:
Scheme_App_Rec *app = (Scheme_App_Rec *)expr; {
return produces_unboxed(app->args[0], NULL, app->num_args, 0); Scheme_App_Rec *app = (Scheme_App_Rec *)expr;
return produces_unboxed(app->args[0], NULL, app->num_args, 0);
}
break;
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr;
return produces_unboxed(app->rator, NULL, 1, 0);
}
break;
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr;
return produces_unboxed(app->rator, NULL, 2, 0);
}
break;
case scheme_compiled_let_void_type:
{
Scheme_Let_Header *lh = (Scheme_Let_Header *)expr;
int i;
expr = lh->body;
for (i = 0; i < lh->num_clauses; i++) {
expr = ((Scheme_Compiled_Let_Value *)expr)->body;
}
/* check expr again */
}
break;
default:
if (SCHEME_FLOATP(expr))
return 1;
return 0;
} }
break;
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr;
return produces_unboxed(app->rator, NULL, 1, 0);
}
break;
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr;
return produces_unboxed(app->rator, NULL, 2, 0);
}
break;
default:
if (SCHEME_FLOATP(expr))
return 1;
break;
} }
return 0;
} }
static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *rator, int count, Optimize_Info *info) static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *rator, int count, Optimize_Info *info)
@ -3239,12 +3292,11 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
for (i = 0; i < n; i++) { for (i = 0; i < n; i++) {
if (!i) { if (!i) {
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context); le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context, 0);
if (le) if (le)
return le; return le;
} }
sub_context = 0; sub_context = 0;
if ((i > 0) && scheme_wants_flonum_arguments(app->args[0], i - 1, 0)) if ((i > 0) && scheme_wants_flonum_arguments(app->args[0], i - 1, 0))
sub_context = OPT_CONTEXT_FLONUM_ARG; sub_context = OPT_CONTEXT_FLONUM_ARG;
@ -3253,12 +3305,10 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
app->args[i] = le; app->args[i] = le;
if (!i) { if (!i) {
if (SAME_TYPE(SCHEME_TYPE(app->args[0]),scheme_compiled_unclosed_procedure_type)) { /* Maybe found "((lambda" after optimizing; try again */
/* Found "((lambda" after optimizing; try again */ le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context, 1);
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context); if (le)
if (le) return le;
return le;
}
} }
if (i && (SCHEME_TYPE(le) < _scheme_compiled_values_types_)) if (i && (SCHEME_TYPE(le) < _scheme_compiled_values_types_))
@ -3349,16 +3399,16 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
le = check_app_let_rator(o, app->rator, info, 1, context); le = check_app_let_rator(o, app->rator, info, 1, context);
if (le) return le; if (le) return le;
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context); le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context, 0);
if (le) if (le)
return le; return le;
le = scheme_optimize_expr(app->rator, info, sub_context); le = scheme_optimize_expr(app->rator, info, sub_context);
app->rator = le; app->rator = le;
if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) { {
/* Found "((lambda" after optimizing; try again */ /* Maybe found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context); le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context, 1);
if (le) if (le)
return le; return le;
} }
@ -3421,20 +3471,20 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
le = check_app_let_rator(o, app->rator, info, 2, context); le = check_app_let_rator(o, app->rator, info, 2, context);
if (le) return le; if (le) return le;
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context); le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context, 0);
if (le) if (le)
return le; return le;
le = scheme_optimize_expr(app->rator, info, sub_context); le = scheme_optimize_expr(app->rator, info, sub_context);
app->rator = le; app->rator = le;
if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) { {
/* Found "((lambda" after optimizing; try again */ /* Maybe found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context); le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context, 1);
if (le) if (le)
return le; return le;
} }
/* 1st arg */ /* 1st arg */
if (scheme_wants_flonum_arguments(app->rator, 0, 0)) if (scheme_wants_flonum_arguments(app->rator, 0, 0))
@ -3570,7 +3620,7 @@ Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
if (rev) { if (rev) {
int rator2_flags; int rator2_flags;
Scheme_Object *o_f; Scheme_Object *o_f;
o_f = optimize_for_inline(info, rev, 1, NULL, NULL, NULL, &rator2_flags, context); o_f = optimize_for_inline(info, rev, 1, NULL, NULL, NULL, &rator2_flags, context, 0);
if (o_f) { if (o_f) {
f_is_proc = rev; f_is_proc = rev;
@ -3920,7 +3970,9 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
pos = SCHEME_LOCAL_POS(expr); pos = SCHEME_LOCAL_POS(expr);
val = scheme_optimize_info_lookup(info, pos, NULL, NULL, 1, context, NULL); val = scheme_optimize_info_lookup(info, pos, NULL, NULL,
(context & OPT_CONTEXT_NO_SINGLE) ? 0 : 1,
context, NULL);
if (val) { if (val) {
if (SAME_TYPE(SCHEME_TYPE(val), scheme_once_used_type)) { if (SAME_TYPE(SCHEME_TYPE(val), scheme_once_used_type)) {
Scheme_Once_Used *o = (Scheme_Once_Used *)val; Scheme_Once_Used *o = (Scheme_Once_Used *)val;
@ -4008,7 +4060,8 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_READY); expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_READY);
} }
} }
info->vclock += 1; if (!c)
info->vclock += 1;
} }
} else { } else {
info->vclock += 1; info->vclock += 1;
@ -11255,7 +11308,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code,
depth, delta, delta, depth, delta, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, NULL, 0, 0,
vc, 1); vc, 1, 0);
} }
} else { } else {
scheme_validate_expr(port, code, scheme_validate_expr(port, code,
@ -11263,7 +11316,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code,
depth, delta, delta, depth, delta, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, NULL, 0, 0,
vc, 1); vc, 1, 0);
} }
} }
@ -11287,7 +11340,8 @@ static Scheme_Object *validate_k(void)
scheme_validate_expr(port, expr, stack, tls, scheme_validate_expr(port, expr, stack, tls,
args[0], args[1], args[2], args[0], args[1], args[2],
args[3], args[4], args[5], args[3], args[4], args[5],
app_rator, args[6], args[7], vc, args[8]); app_rator, args[6], args[7], vc, args[8],
args[9]);
return scheme_true; return scheme_true;
} }
@ -11435,7 +11489,7 @@ void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr,
} }
scheme_validate_expr(port, data->code, new_stack, tls, sz, sz, base, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, data->code, new_stack, tls, sz, sz, base, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 1); NULL, 0, 0, vc, 1, 0);
} }
@ -11551,6 +11605,19 @@ static void check_self_call_valid(Scheme_Object *rator, Mz_CPort *port, struct V
} }
} }
static void no_flo(int need_flonum, Mz_CPort *port)
{
if (need_flonum) scheme_ill_formed_code(port);
}
static void check_flo(Scheme_Object *expr, int need_flonum, Mz_CPort *port)
{
if (need_flonum) {
if (!scheme_expr_produces_flonum(expr))
scheme_ill_formed_code(port);
}
}
#define CAN_RESET_STACK_SLOT 0 #define CAN_RESET_STACK_SLOT 0
#if !CAN_RESET_STACK_SLOT #if !CAN_RESET_STACK_SLOT
# define WHEN_CAN_RESET_STACK_SLOT(x) 0 # define WHEN_CAN_RESET_STACK_SLOT(x) 0
@ -11564,7 +11631,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
Scheme_Object *app_rator, int proc_with_refs_ok, Scheme_Object *app_rator, int proc_with_refs_ok,
int result_ignored, int result_ignored,
struct Validate_Clearing *vc, int tailpos) struct Validate_Clearing *vc, int tailpos,
int need_flonum)
{ {
Scheme_Type type; Scheme_Type type;
int did_one = 0, vc_merge = 0, vc_merge_start = 0; int did_one = 0, vc_merge = 0, vc_merge_start = 0;
@ -11576,7 +11644,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
void **pr; void **pr;
int *args; int *args;
args = MALLOC_N_ATOMIC(int, 8); args = MALLOC_N_ATOMIC(int, 10);
p->ku.k.p1 = (void *)port; p->ku.k.p1 = (void *)port;
p->ku.k.p2 = (void *)expr; p->ku.k.p2 = (void *)expr;
@ -11591,6 +11659,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
args[5] = num_lifts; args[5] = num_lifts;
args[6] = proc_with_refs_ok; args[6] = proc_with_refs_ok;
args[7] = result_ignored; args[7] = result_ignored;
args[8] = tailpos;
args[9] = need_flonum;
pr = MALLOC_N(void*, 3); pr = MALLOC_N(void*, 3);
pr[0] = (void *)args; pr[0] = (void *)args;
@ -11626,6 +11696,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
int d = c + delta; int d = c + delta;
int p = SCHEME_TOPLEVEL_POS(expr); int p = SCHEME_TOPLEVEL_POS(expr);
no_flo(need_flonum, port);
if ((c < 0) || (p < 0) || (d >= depth) if ((c < 0) || (p < 0) || (d >= depth)
|| (stack[d] != VALID_TOPLEVELS) || (stack[d] != VALID_TOPLEVELS)
|| (p >= (num_toplevels + num_lifts + num_stxes + (num_stxes ? 1 : 0))) || (p >= (num_toplevels + num_lifts + num_stxes + (num_stxes ? 1 : 0)))
@ -11670,6 +11742,9 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
if ((q < 0) || (p >= depth)) if ((q < 0) || (p >= depth))
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM)
no_flo(need_flonum, port);
if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_FLONUM) { if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_FLONUM) {
if (stack[p] != VALID_FLONUM) if (stack[p] != VALID_FLONUM)
@ -11712,6 +11787,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
int q = SCHEME_LOCAL_POS(expr); int q = SCHEME_LOCAL_POS(expr);
int p = q + delta; int p = q + delta;
no_flo(need_flonum, port);
if ((q < 0) || (p >= depth) || ((stack[p] != VALID_BOX) if ((q < 0) || (p >= depth) || ((stack[p] != VALID_BOX)
&& (stack[p] != VALID_BOX_NOCLEAR))) && (stack[p] != VALID_BOX_NOCLEAR)))
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
@ -11735,6 +11812,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
{ {
Scheme_Syntax_Validater f; Scheme_Syntax_Validater f;
int p = SCHEME_PINT_VAL(expr); int p = SCHEME_PINT_VAL(expr);
no_flo(need_flonum, port);
if ((p < 0) || (p >= _COUNT_EXPD_)) if ((p < 0) || (p >= _COUNT_EXPD_))
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
@ -11749,6 +11828,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_App_Rec *app = (Scheme_App_Rec *)expr; Scheme_App_Rec *app = (Scheme_App_Rec *)expr;
int i, n; int i, n;
check_flo(expr, need_flonum, port);
n = app->num_args + 1; n = app->num_args + 1;
delta -= (n - 1); delta -= (n - 1);
@ -11758,7 +11839,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
for (i = 0; i < n; i++) { for (i = 0; i < n; i++) {
scheme_validate_expr(port, app->args[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, app->args[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
i ? app->args[0] : NULL, i + 1, 0, vc, 0); i ? app->args[0] : NULL, i + 1, 0, vc, 0, 0);
} }
if (tailpos) if (tailpos)
@ -11768,6 +11849,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
case scheme_application2_type: case scheme_application2_type:
{ {
Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr;
check_flo(expr, need_flonum, port);
delta -= 1; delta -= 1;
if (delta < 0) if (delta < 0)
@ -11775,9 +11858,9 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
stack[delta] = VALID_NOT; stack[delta] = VALID_NOT;
scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 1, 0, vc, 0); NULL, 1, 0, vc, 0, 0);
scheme_validate_expr(port, app->rand, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, app->rand, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
app->rator, 2, 0, vc, 0); app->rator, 2, 0, vc, 0, 0);
if (tailpos) if (tailpos)
check_self_call_valid(app->rator, port, vc, delta, stack); check_self_call_valid(app->rator, port, vc, delta, stack);
@ -11786,6 +11869,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
case scheme_application3_type: case scheme_application3_type:
{ {
Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr;
check_flo(expr, need_flonum, port);
delta -= 2; delta -= 2;
if (delta < 0) if (delta < 0)
@ -11794,11 +11879,11 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
stack[delta+1] = VALID_NOT; stack[delta+1] = VALID_NOT;
scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 1, 0, vc, 0); NULL, 1, 0, vc, 0, 0);
scheme_validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
app->rator, 2, 0, vc, 0); app->rator, 2, 0, vc, 0, 0);
scheme_validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
app->rator, 3, 0, vc, 0); app->rator, 3, 0, vc, 0, 0);
if (tailpos) if (tailpos)
check_self_call_valid(app->rator, port, vc, delta, stack); check_self_call_valid(app->rator, port, vc, delta, stack);
@ -11809,12 +11894,14 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_Sequence *seq = (Scheme_Sequence *)expr; Scheme_Sequence *seq = (Scheme_Sequence *)expr;
int cnt; int cnt;
int i; int i;
no_flo(need_flonum, port);
cnt = seq->count; cnt = seq->count;
for (i = 0; i < cnt - 1; i++) { for (i = 0; i < cnt - 1; i++) {
scheme_validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 1, vc, 0); NULL, 0, 1, vc, 0, 0);
} }
expr = seq->array[cnt - 1]; expr = seq->array[cnt - 1];
@ -11826,9 +11913,11 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_Branch_Rec *b; Scheme_Branch_Rec *b;
int vc_pos, vc_ncpos; int vc_pos, vc_ncpos;
no_flo(need_flonum, port);
b = (Scheme_Branch_Rec *)expr; b = (Scheme_Branch_Rec *)expr;
scheme_validate_expr(port, b->test, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, b->test, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0); NULL, 0, 0, vc, 0, 0);
/* This is where letlimit is useful. It prevents let-assignment in the /* This is where letlimit is useful. It prevents let-assignment in the
"then" branch that could permit bad code in the "else" branch (or the "then" branch that could permit bad code in the "else" branch (or the
same thing with either branch affecting later code in a sequence). */ same thing with either branch affecting later code in a sequence). */
@ -11836,7 +11925,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
vc_pos = vc->stackpos; vc_pos = vc->stackpos;
vc_ncpos = vc->ncstackpos; vc_ncpos = vc->ncstackpos;
scheme_validate_expr(port, b->tbranch, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, b->tbranch, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, result_ignored, vc, tailpos); NULL, 0, result_ignored, vc, tailpos, 0);
/* Rewind clears and noclears, but also save the clears, /* Rewind clears and noclears, but also save the clears,
so that the branches' effects can be merged. */ so that the branches' effects can be merged. */
@ -11869,11 +11958,13 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
case scheme_with_cont_mark_type: case scheme_with_cont_mark_type:
{ {
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr; Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr;
no_flo(need_flonum, port);
scheme_validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0); NULL, 0, 0, vc, 0, 0);
scheme_validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0); NULL, 0, 0, vc, 0, 0);
expr = wcm->body; expr = wcm->body;
goto top; goto top;
} }
@ -11886,6 +11977,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
int p = qs->midpoint; int p = qs->midpoint;
int d = c + delta; int d = c + delta;
no_flo(need_flonum, port);
if ((c < 0) || (p < 0) || (d >= depth) if ((c < 0) || (p < 0) || (d >= depth)
|| (stack[d] != VALID_TOPLEVELS) || (stack[d] != VALID_TOPLEVELS)
|| (p != num_toplevels) || (p != num_toplevels)
@ -11895,6 +11988,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
break; break;
case scheme_unclosed_procedure_type: case scheme_unclosed_procedure_type:
{ {
no_flo(need_flonum, port);
validate_unclosed_procedure(port, expr, stack, tls, validate_unclosed_procedure(port, expr, stack, tls,
depth, delta, num_toplevels, num_stxes, num_lifts, depth, delta, num_toplevels, num_stxes, num_lifts,
app_rator, proc_with_refs_ok, -1); app_rator, proc_with_refs_ok, -1);
@ -11904,9 +11998,9 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
{ {
Scheme_Let_Value *lv = (Scheme_Let_Value *)expr; Scheme_Let_Value *lv = (Scheme_Let_Value *)expr;
int q, p, c, i; int q, p, c, i;
scheme_validate_expr(port, lv->value, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, lv->value, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0); NULL, 0, 0, vc, 0, 0);
/* memset(stack, VALID_NOT, delta); <-- seems unnecessary (and slow) */ /* memset(stack, VALID_NOT, delta); <-- seems unnecessary (and slow) */
c = lv->count; c = lv->count;
@ -11953,7 +12047,6 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
memset(stack + delta, VALID_UNINIT, c); memset(stack + delta, VALID_UNINIT, c);
} }
expr = lv->body; expr = lv->body;
goto top; goto top;
} }
@ -12001,7 +12094,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
stack[delta] = VALID_UNINIT; stack[delta] = VALID_UNINIT;
scheme_validate_expr(port, lo->value, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, scheme_validate_expr(port, lo->value, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0); NULL, 0, 0, vc, 0, SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM);
#if !CAN_RESET_STACK_SLOT #if !CAN_RESET_STACK_SLOT
if (stack[delta] != VALID_UNINIT) if (stack[delta] != VALID_UNINIT)
@ -12021,9 +12114,10 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
default: default:
/* All values are definitely ok, except pre-closed closures. /* All values are definitely ok, except pre-closed closures.
Such a closure can refer back to itself, so we use a flag Such a closure can refer back to itself, so we use a flag
to track cycles. */ to track cycles. Also check need_flonum. */
if (SAME_TYPE(type, scheme_closure_type)) { if (SAME_TYPE(type, scheme_closure_type)) {
Scheme_Closure_Data *data; Scheme_Closure_Data *data;
no_flo(need_flonum, port);
expr = (Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(expr); expr = (Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(expr);
data = (Scheme_Closure_Data *)expr; data = (Scheme_Closure_Data *)expr;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_VALIDATED) { if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_VALIDATED) {
@ -12033,6 +12127,9 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
did_one = 0; did_one = 0;
goto top; goto top;
} }
} else if (need_flonum) {
if (!SCHEME_FLOATP(expr))
no_flo(need_flonum, port);
} }
break; break;
} }
@ -12065,7 +12162,7 @@ void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
depth, delta, delta, depth, delta, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, skip_refs_check ? 1 : 0, 0, NULL, skip_refs_check ? 1 : 0, 0,
make_clearing_stack(), 0); make_clearing_stack(), 0, 0);
} }
void scheme_validate_boxenv(int p, Mz_CPort *port, char *stack, int depth, int delta) void scheme_validate_boxenv(int p, Mz_CPort *port, char *stack, int depth, int delta)

156
src/mzscheme/src/jit.c
View File

@ -3958,7 +3958,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
int directly; int directly;
jitter->unbox++; jitter->unbox++;
if (can_unbox_inline(arg, 5, JIT_FPR_NUM-1, 0)) if (can_unbox_inline(arg, 5, JIT_FPR_NUM-1, 0))
directly = 1; directly = 2;
else if (can_unbox_directly(arg)) else if (can_unbox_directly(arg))
directly = 1; directly = 1;
else else
@ -4255,35 +4255,51 @@ static int can_unbox_directly(Scheme_Object *obj)
{ {
Scheme_Type t; Scheme_Type t;
t = SCHEME_TYPE(obj); while (1) {
switch (t) { t = SCHEME_TYPE(obj);
case scheme_application2_type: switch (t) {
{ case scheme_application2_type:
Scheme_App2_Rec *app = (Scheme_App2_Rec *)obj; {
if (is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_UNARY_INLINED, 1, 1)) Scheme_App2_Rec *app = (Scheme_App2_Rec *)obj;
return 1; if (is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_UNARY_INLINED, 1, 1))
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)) {
if (IS_NAMED_PRIM(app->rator, "->fl")
|| IS_NAMED_PRIM(app->rator, "fx->fl"))
return 1; return 1;
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)) {
if (IS_NAMED_PRIM(app->rator, "->fl")
|| IS_NAMED_PRIM(app->rator, "fx->fl"))
return 1;
}
return 0;
} }
break;
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)obj;
if (is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_BINARY_INLINED, 1, 1))
return 1;
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_BINARY_INLINED)) {
if (IS_NAMED_PRIM(app->rator, "flvector-ref")) return 1;
}
return 0;
}
break;
case scheme_let_value_type:
obj = ((Scheme_Let_Value *)obj)->body;
break;
case scheme_let_one_type:
obj = ((Scheme_Let_One *)obj)->body;
break;
case scheme_let_void_type:
obj = ((Scheme_Let_Void *)obj)->body;
break;
case scheme_letrec_type:
obj = ((Scheme_Letrec *)obj)->body;
break;
default:
return 0;
} }
break;
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)obj;
if (is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_BINARY_INLINED, 1, 1))
return 1;
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_BINARY_INLINED)) {
if (IS_NAMED_PRIM(app->rator, "flvector-ref")) return 1;
}
}
break;
} }
return 0;
} }
static jit_insn *generate_arith_slow_path(mz_jit_state *jitter, Scheme_Object *rator, static jit_insn *generate_arith_slow_path(mz_jit_state *jitter, Scheme_Object *rator,
@ -4901,11 +4917,11 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
} }
if (inlined_flonum1) if (inlined_flonum1)
can_direct1 = 1; can_direct1 = 2;
else else
can_direct1 = can_unbox_directly(rand); can_direct1 = can_unbox_directly(rand);
if (inlined_flonum2) if (inlined_flonum2)
can_direct2 = 1; can_direct2 = 2;
else else
can_direct2 = can_unbox_directly(rand2); can_direct2 = can_unbox_directly(rand2);
@ -7855,23 +7871,26 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
} }
} }
if ((which == 3) if (which == 3) {
&& (can_unbox_inline(app->args[3], 5, JIT_FPR_NUM-3, 0) if (can_unbox_inline(app->args[3], 5, JIT_FPR_NUM-3, 0))
|| can_unbox_directly(app->args[3]))) { flonum_arg = 2;
# if !defined(INLINE_FP_OPS) || !defined(CAN_INLINE_ALLOC) else if (can_unbox_directly(app->args[3]))
/* Error handling will have to box flonum, so don't unbox if
that cannot be done inline: */
if (!unsafe)
flonum_arg = 0;
else
# endif
flonum_arg = 1; flonum_arg = 1;
else
flonum_arg = 0;
} else } else
flonum_arg = 0; flonum_arg = 0;
# if !defined(INLINE_FP_OPS) || !defined(CAN_INLINE_ALLOC)
/* Error handling will have to box flonum, so don't unbox if
that cannot be done inline: */
if (flonum_arg && !unsafe)
flonum_arg = 0;
# endif
if (flonum_arg) { if (flonum_arg) {
jitter->unbox++; jitter->unbox++;
generate_unboxed(app->args[3], jitter, 1, 0); generate_unboxed(app->args[3], jitter, flonum_arg, 0);
--jitter->unbox; --jitter->unbox;
} else { } else {
generate_non_tail(app->args[3], jitter, 0, 1, 0); /* sync'd below */ generate_non_tail(app->args[3], jitter, 0, 1, 0); /* sync'd below */
@ -8697,12 +8716,16 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter,
} }
static int generate_unboxed(Scheme_Object *obj, mz_jit_state *jitter, int inlined_ok, int unbox_anyway) static int generate_unboxed(Scheme_Object *obj, mz_jit_state *jitter, int inlined_ok, int unbox_anyway)
/* de-sync's; if refslow, failure jumps conditionally with non-flonum in R0 */ /* de-sync's; if refslow, failure jumps conditionally with non-flonum in R0;
inlined_ok == 2 => can generate directly; inlined_ok == 1 => non-tail unbox */
{ {
int saved; int saved;
if (inlined_ok) { if (inlined_ok) {
return generate(obj, jitter, 0, 1, JIT_R0, NULL); if (inlined_ok == 2)
return generate(obj, jitter, 0, 1, JIT_R0, NULL);
else
return generate_non_tail(obj, jitter, 0, 1, 0);
} }
if (!jitter->unbox || jitter->unbox_depth) if (!jitter->unbox || jitter->unbox_depth)
@ -9625,11 +9648,16 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
case scheme_let_value_type: case scheme_let_value_type:
{ {
Scheme_Let_Value *lv = (Scheme_Let_Value *)obj; Scheme_Let_Value *lv = (Scheme_Let_Value *)obj;
int ab = SCHEME_LET_AUTOBOX(lv), i, pos; int ab = SCHEME_LET_AUTOBOX(lv), i, pos, to_unbox = 0;
START_JIT_DATA(); START_JIT_DATA();
LOG_IT(("let...\n")); LOG_IT(("let...\n"));
if (jitter->unbox) {
to_unbox = jitter->unbox;
jitter->unbox = 0;
}
if (lv->count == 1) { if (lv->count == 1) {
/* Expect one result: */ /* Expect one result: */
generate_non_tail(lv->value, jitter, 0, 1, 0); /* no sync */ generate_non_tail(lv->value, jitter, 0, 1, 0); /* no sync */
@ -9707,16 +9735,24 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
LOG_IT(("...in\n")); LOG_IT(("...in\n"));
if (to_unbox)
jitter->unbox = to_unbox;
return generate(lv->body, jitter, is_tail, multi_ok, orig_target, for_branch); return generate(lv->body, jitter, is_tail, multi_ok, orig_target, for_branch);
} }
case scheme_let_void_type: case scheme_let_void_type:
{ {
Scheme_Let_Void *lv = (Scheme_Let_Void *)obj; Scheme_Let_Void *lv = (Scheme_Let_Void *)obj;
int c = lv->count; int c = lv->count, to_unbox = 0;
START_JIT_DATA(); START_JIT_DATA();
LOG_IT(("letv...\n")); LOG_IT(("letv...\n"));
if (jitter->unbox) {
to_unbox = jitter->unbox;
jitter->unbox = 0;
}
mz_rs_dec(c); mz_rs_dec(c);
CHECK_RUNSTACK_OVERFLOW(); CHECK_RUNSTACK_OVERFLOW();
stack_safety(jitter, c, 0); stack_safety(jitter, c, 0);
@ -9742,16 +9778,24 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
LOG_IT(("...in\n")); LOG_IT(("...in\n"));
if (to_unbox)
jitter->unbox = to_unbox;
return generate(lv->body, jitter, is_tail, multi_ok, orig_target, for_branch); return generate(lv->body, jitter, is_tail, multi_ok, orig_target, for_branch);
} }
case scheme_letrec_type: case scheme_letrec_type:
{ {
Scheme_Letrec *l = (Scheme_Letrec *)obj; Scheme_Letrec *l = (Scheme_Letrec *)obj;
int i, nsrs, prepped = 0; int i, nsrs, prepped = 0, to_unbox = 0;
START_JIT_DATA(); START_JIT_DATA();
LOG_IT(("letrec...\n")); LOG_IT(("letrec...\n"));
if (jitter->unbox) {
to_unbox = jitter->unbox;
jitter->unbox = 0;
}
mz_rs_sync(); mz_rs_sync();
/* Create unfinished closures */ /* Create unfinished closures */
@ -9803,16 +9847,24 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
jitter->need_set_rs = nsrs; jitter->need_set_rs = nsrs;
} }
if (to_unbox)
jitter->unbox = to_unbox;
return generate(l->body, jitter, is_tail, multi_ok, orig_target, for_branch); return generate(l->body, jitter, is_tail, multi_ok, orig_target, for_branch);
} }
case scheme_let_one_type: case scheme_let_one_type:
{ {
Scheme_Let_One *lv = (Scheme_Let_One *)obj; Scheme_Let_One *lv = (Scheme_Let_One *)obj;
int flonum; int flonum, to_unbox = 0;
START_JIT_DATA(); START_JIT_DATA();
LOG_IT(("leto...\n")); LOG_IT(("leto...\n"));
if (jitter->unbox) {
to_unbox = jitter->unbox;
jitter->unbox = 0;
}
mz_runstack_skipped(jitter, 1); mz_runstack_skipped(jitter, 1);
#ifdef USE_FLONUM_UNBOXING #ifdef USE_FLONUM_UNBOXING
@ -9824,12 +9876,15 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
PAUSE_JIT_DATA(); PAUSE_JIT_DATA();
if (flonum) { if (flonum) {
#ifdef USE_FLONUM_UNBOXING #ifdef USE_FLONUM_UNBOXING
if (can_unbox_inline(lv->value, 5, JIT_FPR_NUM-1, 0) if (can_unbox_inline(lv->value, 5, JIT_FPR_NUM-1, 0)) {
|| can_unbox_directly(lv->value)) { jitter->unbox++;
generate_unboxed(lv->value, jitter, 2, 0);
} else {
if (0) /* validator should ensure that this is ok */
if (!can_unbox_directly(lv->value))
scheme_signal_error("internal error: bad FLONUM annotation on let");
jitter->unbox++; jitter->unbox++;
generate_unboxed(lv->value, jitter, 1, 0); generate_unboxed(lv->value, jitter, 1, 0);
} else {
scheme_signal_error("internal error: bad FLONUM annotation on let");
} }
#endif #endif
} else } else
@ -9864,6 +9919,9 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
mz_RECORD_STATUS(mz_RS_R0_HAS_RUNSTACK0); mz_RECORD_STATUS(mz_RS_R0_HAS_RUNSTACK0);
if (to_unbox)
jitter->unbox = to_unbox;
return generate(lv->body, jitter, is_tail, multi_ok, orig_target, for_branch); return generate(lv->body, jitter, is_tail, multi_ok, orig_target, for_branch);
} }
case scheme_with_cont_mark_type: case scheme_with_cont_mark_type:

6
src/mzscheme/src/schpriv.h
View File

@ -2308,8 +2308,9 @@ Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, in
#define OPT_CONTEXT_FLONUM_ARG 0x1 #define OPT_CONTEXT_FLONUM_ARG 0x1
#define OPT_CONTEXT_BOOLEAN 0x2 #define OPT_CONTEXT_BOOLEAN 0x2
#define OPT_CONTEXT_NO_SINGLE 0x4
#define scheme_optimize_result_context(c) (c & (~OPT_CONTEXT_FLONUM_ARG)) #define scheme_optimize_result_context(c) (c & (~(OPT_CONTEXT_FLONUM_ARG | OPT_CONTEXT_NO_SINGLE)))
#define scheme_optimize_tail_context(c) scheme_optimize_result_context(c) #define scheme_optimize_tail_context(c) scheme_optimize_result_context(c)
Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e, Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
@ -2613,7 +2614,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts, int num_toplevels, int num_stxes, int num_lifts,
Scheme_Object *app_rator, int proc_with_refs_ok, Scheme_Object *app_rator, int proc_with_refs_ok,
int result_ignored, struct Validate_Clearing *vc, int tailpos); int result_ignored, struct Validate_Clearing *vc,
int tailpos, int need_flonum);
void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port, void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
char *stack, Validate_TLS tls, char *stack, Validate_TLS tls,
int depth, int delta, int depth, int delta,

31
src/mzscheme/src/syntax.c
View File

@ -988,7 +988,7 @@ static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, val, stack, tls, scheme_validate_expr(port, val, stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, !!only_var, 0, vc, 0); NULL, !!only_var, 0, vc, 0, 0);
} }
static Scheme_Object * static Scheme_Object *
@ -1533,7 +1533,7 @@ static void set_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, val, stack, tls, depth, letlimit, delta, scheme_validate_expr(port, val, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0); NULL, 0, 0, vc, 0, 0);
scheme_validate_toplevel(tl, port, stack, tls, depth, delta, scheme_validate_toplevel(tl, port, stack, tls, depth, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
0); 0);
@ -2178,11 +2178,11 @@ static void apply_values_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, f, stack, tls, scheme_validate_expr(port, f, stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0); NULL, 0, 0, vc, 0, 0);
scheme_validate_expr(port, e, stack, tls, scheme_validate_expr(port, e, stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0); NULL, 0, 0, vc, 0, 0);
} }
/**********************************************************************/ /**********************************************************************/
@ -2348,7 +2348,7 @@ static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stac
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
scheme_validate_expr(port, e, stack, tls, depth, letlimit, delta, scheme_validate_expr(port, e, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0); NULL, 0, 0, vc, 0, 0);
} }
} }
@ -2740,7 +2740,7 @@ static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, SCHEME_CDR(data), stack, tls, depth, letlimit, delta, scheme_validate_expr(port, SCHEME_CDR(data), stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, tailpos); NULL, 0, 0, vc, tailpos, 0);
} }
/**********************************************************************/ /**********************************************************************/
@ -3030,7 +3030,7 @@ static int worth_lifting(Scheme_Object *v)
Scheme_Object * Scheme_Object *
scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context) scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context)
{ {
Optimize_Info *body_info, *rhs_info; Optimize_Info *sub_info, *body_info, *rhs_info;
Scheme_Let_Header *head = (Scheme_Let_Header *)form; Scheme_Let_Header *head = (Scheme_Let_Header *)form;
Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body; Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body;
Scheme_Object *body, *value, *ready_pairs = NULL, *rp_last = NULL, *ready_pairs_start; Scheme_Object *body, *value, *ready_pairs = NULL, *rp_last = NULL, *ready_pairs_start;
@ -3053,7 +3053,6 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
&& !SCHEME_LOCAL_POS(b->test) && !SCHEME_LOCAL_POS(b->test)
&& !SCHEME_LOCAL_POS(b->tbranch)) { && !SCHEME_LOCAL_POS(b->tbranch)) {
Scheme_Branch_Rec *b3; Scheme_Branch_Rec *b3;
Optimize_Info *sub_info;
b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
b3->so.type = scheme_branch_type; b3->so.type = scheme_branch_type;
@ -3099,9 +3098,15 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
} }
} }
body_info = scheme_optimize_info_add_frame(info, head->count, head->count, 0); if (for_inline > 1) {
info->vclock++;
sub_info = scheme_optimize_info_add_frame(info, for_inline - 1, for_inline - 1, 0);
} else
sub_info = info;
body_info = scheme_optimize_info_add_frame(sub_info, head->count, head->count, 0);
if (for_inline) { if (for_inline) {
rhs_info = scheme_optimize_info_add_frame(info, 0, head->count, 0); rhs_info = scheme_optimize_info_add_frame(info, 0, head->count + (for_inline - 1), 0);
body_info->inline_fuel >>= 1; body_info->inline_fuel >>= 1;
} else } else
rhs_info = body_info; rhs_info = body_info;
@ -3514,6 +3519,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
/* Optimized away all clauses? */ /* Optimized away all clauses? */
if (!head->num_clauses) { if (!head->num_clauses) {
scheme_optimize_info_done(body_info); scheme_optimize_info_done(body_info);
if (for_inline > 1) scheme_optimize_info_done(sub_info);
return head->body; return head->body;
} }
@ -3579,6 +3585,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
} }
scheme_optimize_info_done(body_info); scheme_optimize_info_done(body_info);
if (for_inline > 1) scheme_optimize_info_done(sub_info);
return form; return form;
} }
@ -4898,7 +4905,7 @@ static void begin0_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, seq->array[i], stack, tls, scheme_validate_expr(port, seq->array[i], stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, i > 0, vc, 0); NULL, 0, i > 0, vc, 0, 0);
} }
} }
@ -5246,7 +5253,7 @@ static void splice_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, data, stack, tls, scheme_validate_expr(port, data, stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, num_toplevels, num_stxes, num_lifts,
NULL, 0, 0, vc, 0); NULL, 0, 0, vc, 0, 0);
} }
/**********************************************************************/ /**********************************************************************/