From 3812f8ca72c8845b4758f01a353ab81a60297d0a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 5 Feb 2010 00:16:06 +0000 Subject: [PATCH] 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) svn: r17972 --- collects/compiler/decompile.ss | 7 +- .../shootout/spectralnorm-unsafe.ss | 47 ++-- collects/tests/mzscheme/optimize.ss | 13 + src/mzscheme/src/eval.c | 253 ++++++++++++------ src/mzscheme/src/jit.c | 156 +++++++---- src/mzscheme/src/schpriv.h | 6 +- src/mzscheme/src/syntax.c | 31 ++- 7 files changed, 348 insertions(+), 165 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 5a2ef58b79..cff92eccd5 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -307,7 +307,12 @@ null) ,@(if (null? captures) null - `('(captures: ,@captures))) + `('(captures: ,@(map (lambda (c t) + (if (eq? t 'flonum) + `(flonum ,c) + c)) + captures + closure-types)))) ,(decompile-expr body globs (append captures (append vars rest-vars)) diff --git a/collects/tests/mzscheme/benchmarks/shootout/spectralnorm-unsafe.ss b/collects/tests/mzscheme/benchmarks/shootout/spectralnorm-unsafe.ss index ac7325e151..5b35f32ca5 100644 --- a/collects/tests/mzscheme/benchmarks/shootout/spectralnorm-unsafe.ss +++ b/collects/tests/mzscheme/benchmarks/shootout/spectralnorm-unsafe.ss @@ -6,8 +6,14 @@ #lang scheme/base (require scheme/cmdline - scheme/flonum - scheme/unsafe/ops) + scheme/require (for-syntax scheme/base) + (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) (let ([u (make-flvector n 1.0)] @@ -21,37 +27,33 @@ ;; v.Bv /(v.v) eigenvalue of v (let loop ([i 0][vBv 0.0][vv 0.0]) (if (= i n) - (unsafe-flsqrt (unsafe-fl/ vBv vv)) - (let ([vi (unsafe-flvector-ref v i)]) - (loop (unsafe-fx+ 1 i) - (unsafe-fl+ vBv (unsafe-fl* (unsafe-flvector-ref u i) vi)) - (unsafe-fl+ vv (unsafe-fl* vi vi)))))))) + (flsqrt (fl/ vBv vv)) + (let ([vi (flvector-ref v i)]) + (loop (add1 i) + (fl+ vBv (fl* (flvector-ref u i) vi)) + (fl+ vv (fl* vi vi)))))))) ;; return element i,j of infinite matrix A (define (A i j) - (unsafe-fl/ 1.0 - (unsafe-fl+ - (unsafe-fl* (unsafe-fx->fl (unsafe-fx+ i j)) - (unsafe-fl/ (unsafe-fx->fl - (unsafe-fx+ i (unsafe-fx+ j 1))) - 2.0)) - (unsafe-fx->fl (unsafe-fx+ i 1))))) + (fl/ 1.0 (fl+ (fl* (->fl (+ i j)) + (fl/ (->fl (+ i (+ j 1))) 2.0)) + (->fl (+ i 1))))) ;; multiply vector v by matrix A (define (MultiplyAv n v Av) (for ([i (in-range n)]) - (unsafe-flvector-set! Av i - (for/fold ([r 0.0]) - ([j (in-range n)]) - (unsafe-fl+ r (unsafe-fl* (A i j) (unsafe-flvector-ref v j))))))) + (flvector-set! Av i + (for/fold ([r 0.0]) + ([j (in-range n)]) + (fl+ r (fl* (A i j) (flvector-ref v j))))))) ;; multiply vector v by matrix A transposed (define (MultiplyAtv n v Atv) (for ([i (in-range n)]) - (unsafe-flvector-set! Atv i - (for/fold ([r 0.0]) - ([j (in-range n)]) - (unsafe-fl+ r (unsafe-fl* (A j i) (unsafe-flvector-ref v j))))))) + (flvector-set! Atv i + (for/fold ([r 0.0]) + ([j (in-range n)]) + (fl+ r (fl* (A j i) (flvector-ref v j))))))) ;; multiply vector v by matrix A and then by matrix A transposed (define (MultiplyAtAv n v AtAv) @@ -63,4 +65,3 @@ (real->decimal-string (Approximate (command-line #:args (n) (string->number n))) 9)) - diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index 66b681acea..aceb92d3ba 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -670,6 +670,19 @@ (test-comp '(let ([x (list 3 4)]) x) '(let ([f (lambda (a . b) b)]) (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) '1) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 798c101ede..b563b3b40b 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -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, 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_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; 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; + if (nested_count) info->vclock++; p = scheme_optimize_expr(p, info, context); 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); - 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); @@ -2506,7 +2514,13 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data, else 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 @@ -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_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, and do not check arity. */ { 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) 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)) { /* Found a `((lambda' */ 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: */ - 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) { @@ -2574,10 +2609,16 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a threshold = info->inline_fuel * (2 + argc); 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) { 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 { 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) { - 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); + while (1) { + 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); + } + 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) @@ -3239,12 +3292,11 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info for (i = 0; i < n; 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) return le; } - sub_context = 0; if ((i > 0) && scheme_wants_flonum_arguments(app->args[0], i - 1, 0)) 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; if (!i) { - if (SAME_TYPE(SCHEME_TYPE(app->args[0]),scheme_compiled_unclosed_procedure_type)) { - /* Found "((lambda" after optimizing; try again */ - le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context); - if (le) - return le; - } + /* Maybe found "((lambda" after optimizing; try again */ + le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context, 1); + if (le) + return le; } 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); 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) return le; le = scheme_optimize_expr(app->rator, info, sub_context); app->rator = le; - if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) { - /* Found "((lambda" after optimizing; try again */ - le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context); + { + /* Maybe found "((lambda" after optimizing; try again */ + le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context, 1); if (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); 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) return le; le = scheme_optimize_expr(app->rator, info, sub_context); app->rator = le; - if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) { - /* Found "((lambda" after optimizing; try again */ - le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context); + { + /* Maybe found "((lambda" after optimizing; try again */ + le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context, 1); if (le) return le; } - + /* 1st arg */ 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) { int rator2_flags; 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) { 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); - 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 (SAME_TYPE(SCHEME_TYPE(val), scheme_once_used_type)) { 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); } } - info->vclock += 1; + if (!c) + info->vclock += 1; } } else { info->vclock += 1; @@ -11255,7 +11308,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, depth, delta, delta, num_toplevels, num_stxes, num_lifts, NULL, 0, 0, - vc, 1); + vc, 1, 0); } } else { scheme_validate_expr(port, code, @@ -11263,7 +11316,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, depth, delta, delta, num_toplevels, num_stxes, num_lifts, 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, args[0], args[1], args[2], 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; } @@ -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, - 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 #if !CAN_RESET_STACK_SLOT # 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, Scheme_Object *app_rator, int proc_with_refs_ok, int result_ignored, - struct Validate_Clearing *vc, int tailpos) + struct Validate_Clearing *vc, int tailpos, + int need_flonum) { Scheme_Type type; 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; int *args; - args = MALLOC_N_ATOMIC(int, 8); + args = MALLOC_N_ATOMIC(int, 10); p->ku.k.p1 = (void *)port; 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[6] = proc_with_refs_ok; args[7] = result_ignored; + args[8] = tailpos; + args[9] = need_flonum; pr = MALLOC_N(void*, 3); pr[0] = (void *)args; @@ -11626,6 +11696,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, int d = c + delta; int p = SCHEME_TOPLEVEL_POS(expr); + no_flo(need_flonum, port); + if ((c < 0) || (p < 0) || (d >= depth) || (stack[d] != VALID_TOPLEVELS) || (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)) 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 (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 p = q + delta; + no_flo(need_flonum, port); + if ((q < 0) || (p >= depth) || ((stack[p] != VALID_BOX) && (stack[p] != VALID_BOX_NOCLEAR))) scheme_ill_formed_code(port); @@ -11735,6 +11812,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, { Scheme_Syntax_Validater f; int p = SCHEME_PINT_VAL(expr); + + no_flo(need_flonum, port); if ((p < 0) || (p >= _COUNT_EXPD_)) 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; int i, n; + check_flo(expr, need_flonum, port); + n = app->num_args + 1; delta -= (n - 1); @@ -11758,7 +11839,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, for (i = 0; i < n; i++) { 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) @@ -11768,6 +11849,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, case scheme_application2_type: { Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; + + check_flo(expr, need_flonum, port); delta -= 1; if (delta < 0) @@ -11775,9 +11858,9 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, stack[delta] = VALID_NOT; 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, - app->rator, 2, 0, vc, 0); + app->rator, 2, 0, vc, 0, 0); if (tailpos) 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: { Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; + + check_flo(expr, need_flonum, port); delta -= 2; if (delta < 0) @@ -11794,11 +11879,11 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, stack[delta+1] = VALID_NOT; 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, - 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, - app->rator, 3, 0, vc, 0); + app->rator, 3, 0, vc, 0, 0); if (tailpos) 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; int cnt; int i; + + no_flo(need_flonum, port); cnt = seq->count; 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, - NULL, 0, 1, vc, 0); + NULL, 0, 1, vc, 0, 0); } expr = seq->array[cnt - 1]; @@ -11826,9 +11913,11 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, Scheme_Branch_Rec *b; int vc_pos, vc_ncpos; + no_flo(need_flonum, port); + b = (Scheme_Branch_Rec *)expr; 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 "then" branch that could permit bad code in the "else" branch (or the 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_ncpos = vc->ncstackpos; 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, 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: { 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, - 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, - NULL, 0, 0, vc, 0); + NULL, 0, 0, vc, 0, 0); expr = wcm->body; goto top; } @@ -11886,6 +11977,8 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, int p = qs->midpoint; int d = c + delta; + no_flo(need_flonum, port); + if ((c < 0) || (p < 0) || (d >= depth) || (stack[d] != VALID_TOPLEVELS) || (p != num_toplevels) @@ -11895,6 +11988,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, break; case scheme_unclosed_procedure_type: { + no_flo(need_flonum, port); validate_unclosed_procedure(port, expr, stack, tls, depth, delta, num_toplevels, num_stxes, num_lifts, 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; int q, p, c, i; - + 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) */ c = lv->count; @@ -11953,7 +12047,6 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, memset(stack + delta, VALID_UNINIT, c); } - expr = lv->body; goto top; } @@ -12001,7 +12094,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, stack[delta] = VALID_UNINIT; 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 (stack[delta] != VALID_UNINIT) @@ -12021,9 +12114,10 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, default: /* All values are definitely ok, except pre-closed closures. 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)) { Scheme_Closure_Data *data; + no_flo(need_flonum, port); expr = (Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(expr); data = (Scheme_Closure_Data *)expr; 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; goto top; } + } else if (need_flonum) { + if (!SCHEME_FLOATP(expr)) + no_flo(need_flonum, port); } break; } @@ -12065,7 +12162,7 @@ void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port, depth, delta, delta, num_toplevels, num_stxes, num_lifts, 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) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 09b8646b4a..7964bd339a 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -3958,7 +3958,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ int directly; jitter->unbox++; if (can_unbox_inline(arg, 5, JIT_FPR_NUM-1, 0)) - directly = 1; + directly = 2; else if (can_unbox_directly(arg)) directly = 1; else @@ -4255,35 +4255,51 @@ static int can_unbox_directly(Scheme_Object *obj) { Scheme_Type t; - t = SCHEME_TYPE(obj); - 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)) - 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")) + while (1) { + t = SCHEME_TYPE(obj); + 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)) 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, @@ -4901,11 +4917,11 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } if (inlined_flonum1) - can_direct1 = 1; + can_direct1 = 2; else can_direct1 = can_unbox_directly(rand); if (inlined_flonum2) - can_direct2 = 1; + can_direct2 = 2; else 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) - && (can_unbox_inline(app->args[3], 5, JIT_FPR_NUM-3, 0) - || can_unbox_directly(app->args[3]))) { -# 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 (!unsafe) - flonum_arg = 0; - else -# endif + if (which == 3) { + if (can_unbox_inline(app->args[3], 5, JIT_FPR_NUM-3, 0)) + flonum_arg = 2; + else if (can_unbox_directly(app->args[3])) flonum_arg = 1; + else + flonum_arg = 0; } else 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) { jitter->unbox++; - generate_unboxed(app->args[3], jitter, 1, 0); + generate_unboxed(app->args[3], jitter, flonum_arg, 0); --jitter->unbox; } else { 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) -/* 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; 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) @@ -9625,11 +9648,16 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m case scheme_let_value_type: { 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(); LOG_IT(("let...\n")); + if (jitter->unbox) { + to_unbox = jitter->unbox; + jitter->unbox = 0; + } + if (lv->count == 1) { /* Expect one result: */ 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")); + if (to_unbox) + jitter->unbox = to_unbox; + return generate(lv->body, jitter, is_tail, multi_ok, orig_target, for_branch); } case scheme_let_void_type: { Scheme_Let_Void *lv = (Scheme_Let_Void *)obj; - int c = lv->count; + int c = lv->count, to_unbox = 0; START_JIT_DATA(); LOG_IT(("letv...\n")); + if (jitter->unbox) { + to_unbox = jitter->unbox; + jitter->unbox = 0; + } + mz_rs_dec(c); CHECK_RUNSTACK_OVERFLOW(); 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")); + if (to_unbox) + jitter->unbox = to_unbox; + return generate(lv->body, jitter, is_tail, multi_ok, orig_target, for_branch); } case scheme_letrec_type: { Scheme_Letrec *l = (Scheme_Letrec *)obj; - int i, nsrs, prepped = 0; + int i, nsrs, prepped = 0, to_unbox = 0; START_JIT_DATA(); LOG_IT(("letrec...\n")); + if (jitter->unbox) { + to_unbox = jitter->unbox; + jitter->unbox = 0; + } + mz_rs_sync(); /* 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; } + if (to_unbox) + jitter->unbox = to_unbox; + return generate(l->body, jitter, is_tail, multi_ok, orig_target, for_branch); } case scheme_let_one_type: { Scheme_Let_One *lv = (Scheme_Let_One *)obj; - int flonum; + int flonum, to_unbox = 0; START_JIT_DATA(); LOG_IT(("leto...\n")); + if (jitter->unbox) { + to_unbox = jitter->unbox; + jitter->unbox = 0; + } + mz_runstack_skipped(jitter, 1); #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(); if (flonum) { #ifdef USE_FLONUM_UNBOXING - if (can_unbox_inline(lv->value, 5, JIT_FPR_NUM-1, 0) - || can_unbox_directly(lv->value)) { + if (can_unbox_inline(lv->value, 5, JIT_FPR_NUM-1, 0)) { + 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++; generate_unboxed(lv->value, jitter, 1, 0); - } else { - scheme_signal_error("internal error: bad FLONUM annotation on let"); } #endif } 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); + if (to_unbox) + jitter->unbox = to_unbox; + return generate(lv->body, jitter, is_tail, multi_ok, orig_target, for_branch); } case scheme_with_cont_mark_type: diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 3bfa135d30..0e67fe98cf 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -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_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) 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 num_toplevels, int num_stxes, int num_lifts, 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, char *stack, Validate_TLS tls, int depth, int delta, diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 53f4c9f491..f57336157b 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -988,7 +988,7 @@ static void define_values_validate(Scheme_Object *data, Mz_CPort *port, scheme_validate_expr(port, val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, - NULL, !!only_var, 0, vc, 0); + NULL, !!only_var, 0, vc, 0, 0); } 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, 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, num_toplevels, num_stxes, num_lifts, 0); @@ -2178,11 +2178,11 @@ static void apply_values_validate(Scheme_Object *data, Mz_CPort *port, scheme_validate_expr(port, f, 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, e, stack, tls, depth, letlimit, delta, 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_validate_expr(port, e, stack, tls, depth, letlimit, delta, 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, 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_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_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body; 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->tbranch)) { Scheme_Branch_Rec *b3; - Optimize_Info *sub_info; b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); 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) { - 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; } else 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? */ if (!head->num_clauses) { scheme_optimize_info_done(body_info); + if (for_inline > 1) scheme_optimize_info_done(sub_info); 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); + if (for_inline > 1) scheme_optimize_info_done(sub_info); 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, depth, letlimit, delta, 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, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, - NULL, 0, 0, vc, 0); + NULL, 0, 0, vc, 0, 0); } /**********************************************************************/