From ebab4270bf9e23abed341e4f2c37877f3cbb00c8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 Aug 2008 15:18:09 +0000 Subject: [PATCH] fix letrec compilation when call/cc is used on the RHS of something that otherwise looks like it could be let*; add #%in annotations to decompiler output svn: r11329 --- collects/compiler/decompile.ss | 31 +++++++++++-- collects/scribblings/mzc/decompile.scrbl | 9 +++- collects/tests/mzscheme/basic.ss | 7 +++ src/mzscheme/src/syntax.c | 57 ++++++++++++++++++------ 4 files changed, 85 insertions(+), 19 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 3beb726fbd..4c009cdcd1 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -237,10 +237,11 @@ [(struct application (rator rands)) (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand)) stack)]) - `(,(decompile-expr rator globs stack) - ,@(map (lambda (rand) - (decompile-expr rand globs stack)) - rands)))] + (annotate-inline + `(,(decompile-expr rator globs stack) + ,@(map (lambda (rand) + (decompile-expr rand globs stack)) + rands))))] [(struct apply-values (proc args-expr)) `(#%apply-values ,(decompile-expr proc globs stack) ,(decompile-expr args-expr globs stack))] @@ -284,6 +285,28 @@ ,(decompile-expr body globs (append captures (append vars rest-vars)))))])) +(define (annotate-inline a) + (if (and (symbol? (car a)) + (case (length a) + [(2) (memq (car a) '(not null? pair? mpair? symbol? + syntax? char? boolean? + number? real? exact-integer? + fixnum? inexact-real? + procedure? vector? box? string? bytes? eof-object? + zero? negative? exact-nonnegative-integer? + exact-positive-integer? + car cdr caar cadr cdar cddr + mcar mcdr unbox syntax-e + add1 sub1 - abs bitwise-not))] + [(3) (memq (car a) '(eq? = <= < >= > + bitwise-bit-set? char=? + + - * / min max bitwise-and bitwise-ior + arithmetic-shift vector-ref string-ref bytes-ref + set-mcar! set-mcdr! cons mcons))] + [(4) (memq (car a) '(vector-set! string-set! bytes-set!))])) + (cons '#%in a) + a)) + ;; ---------------------------------------- #; diff --git a/collects/scribblings/mzc/decompile.scrbl b/collects/scribblings/mzc/decompile.scrbl index 4d177abdcb..31d3803295 100644 --- a/collects/scribblings/mzc/decompile.scrbl +++ b/collects/scribblings/mzc/decompile.scrbl @@ -32,8 +32,7 @@ Many forms in the decompiled code, such as @scheme[module], variable will be defined before the access. Uses of core primitives are shown without a leading @litchar{_}, and - they are never wrapped with @schemeidfont{#%checked}. Applications of - some primitives are inlined by the JIT compiler.} + they are never wrapped with @schemeidfont{#%checked}.} @item{Local-variable access may be wrapped with @schemeidfont{#%sfs-clear}, which indicates that the variable-stack @@ -70,6 +69,12 @@ Many forms in the decompiled code, such as @scheme[module], it may even contain cyclic references to itself or other constant closures.} + @item{Some applications of core primitives are annotated with + @schemeidfont{#%in}, which indicates that the JIT compiler will + inline the operation. (Inlining information is not part of the + bytecode, but is instead based on an enumeration of primitives that + the JIT is known to handle specially.)} + @item{A form @scheme[(#%apply-values _proc _expr)] is equivalent to @scheme[(call-with-values (lambda () _expr) _proc)], but the run-time system avoids allocating a closure for @scheme[_expr].} diff --git a/collects/tests/mzscheme/basic.ss b/collects/tests/mzscheme/basic.ss index 5bd54f2ed0..fdcfa46793 100644 --- a/collects/tests/mzscheme/basic.ss +++ b/collects/tests/mzscheme/basic.ss @@ -1827,6 +1827,13 @@ (void))) count)) +;; Letrec must allocate early, though: +(test #f 'letrec+call/cc + (letrec ((x (call-with-current-continuation list))) + (if (pair? x) + ((car x) (lambda () x)) + (pair? (x))))) + (arity-test call/cc 1 2) (arity-test call/ec 1 1) (err/rt-test (call/cc 4)) diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 5c0a6a094c..4cd2a3bbbd 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -2719,11 +2719,24 @@ static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, /* let, let-values, letrec, etc. */ /**********************************************************************/ -static int is_liftable(Scheme_Object *o, int bind_count, int fuel) +static int is_liftable_prim(Scheme_Object *v) +{ + if (SCHEME_PRIMP(v)) { + if ((((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OPT_MASK) + >= SCHEME_PRIM_OPT_IMMEDIATE) + return 1; + } + + return 0; +} + +static int is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator) { Scheme_Type t = SCHEME_TYPE(o); switch (t) { + case scheme_compiled_unclosed_procedure_type: + return !as_rator; case scheme_compiled_toplevel_type: return 1; case scheme_local_type: @@ -2733,9 +2746,9 @@ static int is_liftable(Scheme_Object *o, int bind_count, int fuel) case scheme_branch_type: if (fuel) { Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)o; - if (is_liftable(b->test, bind_count, fuel - 1) - && is_liftable(b->tbranch, bind_count, fuel - 1) - && is_liftable(b->fbranch, bind_count, fuel - 1)) + if (is_liftable(b->test, bind_count, fuel - 1, 0) + && is_liftable(b->tbranch, bind_count, fuel - 1, as_rator) + && is_liftable(b->fbranch, bind_count, fuel - 1, as_rator)) return 1; } break; @@ -2743,8 +2756,12 @@ static int is_liftable(Scheme_Object *o, int bind_count, int fuel) { Scheme_App_Rec *app = (Scheme_App_Rec *)o; int i; + if (!is_liftable_prim(app->args[0])) + return 0; + if (bind_count >= 0) + bind_count += app->num_args; for (i = app->num_args + 1; i--; ) { - if (!is_liftable(app->args[i], bind_count + app->num_args, fuel - 1)) + if (!is_liftable(app->args[i], bind_count, fuel - 1, 1)) return 0; } return 1; @@ -2752,16 +2769,24 @@ static int is_liftable(Scheme_Object *o, int bind_count, int fuel) case scheme_application2_type: { Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; - if (is_liftable(app->rator, bind_count + 1, fuel - 1) - && is_liftable(app->rand, bind_count + 1, fuel - 1)) + if (!is_liftable_prim(app->rator)) + return 0; + if (bind_count >= 0) + bind_count += 1; + if (is_liftable(app->rator, bind_count, fuel - 1, 1) + && is_liftable(app->rand, bind_count, fuel - 1, 1)) return 1; } case scheme_application3_type: { Scheme_App3_Rec *app = (Scheme_App3_Rec *)o; - if (is_liftable(app->rator, bind_count + 2, fuel - 1) - && is_liftable(app->rand1, bind_count + 2, fuel - 1) - && is_liftable(app->rand2, bind_count + 2, fuel - 1)) + if (!is_liftable_prim(app->rator)) + return 0; + if (bind_count >= 0) + bind_count += 2; + if (is_liftable(app->rator, bind_count, fuel - 1, 1) + && is_liftable(app->rand1, bind_count, fuel - 1, 1) + && is_liftable(app->rand2, bind_count, fuel - 1, 1)) return 1; } default: @@ -2915,6 +2940,11 @@ static int expr_size(Scheme_Object *o) return 1; } +static int might_invoke_call_cc(Scheme_Object *value) +{ + return !is_liftable(value, -1, 10, 0); +} + Scheme_Object * scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline) { @@ -3010,7 +3040,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline) if (is_rec && !not_simply_let_star) { /* Keep track of whether we can simplify to let*: */ - if (scheme_optimize_any_uses(rhs_info, pos, head->count)) + if (might_invoke_call_cc(value) + || scheme_optimize_any_uses(rhs_info, pos, head->count)) not_simply_let_star = 1; } @@ -3103,7 +3134,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline) && !body_info->letrec_not_twice && ((i < 1) || (!scheme_is_compiled_procedure(((Scheme_Compiled_Let_Value *)pre_body->body)->value, 1, 1) - && !is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5)))) { + && !is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5, 1)))) { if (did_set_value) { /* Next RHS ends a reorderable sequence. Re-optimize from retry_start to pre_body, inclusive. @@ -3420,7 +3451,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) if (is_proc) is_lift = 0; else - is_lift = is_liftable(clv->value, head->count, 5); + is_lift = is_liftable(clv->value, head->count, 5, 1); if (!is_proc && !is_lift) { recbox = 1;