diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 1f2e17aa0..a95b3ad90 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -176,22 +176,6 @@ references to the new symbols." (lambda (exp res) #f) #f exp))) -(define (code-contains-calls? body proc lookup) - "Return true if BODY contains calls to PROC. Use LOOKUP to look up -lexical references." - (tree-il-any - (lambda (exp) - (match exp - (($ _ - (and ref ($ _ _ gensym)) _) - (or (equal? ref proc) - (equal? (lookup gensym) proc))) - (($ - (and proc* ($ ))) - (equal? proc* proc)) - (_ #f))) - body)) - (define (vlist-any proc vlist) (let ((len (vlist-length vlist))) (let lp ((i 0)) @@ -287,7 +271,13 @@ lexical references." (counter-data orig) current)) -(define* (peval exp #:optional (cenv (current-module)) (env vlist-null)) +(define* (peval exp #:optional (cenv (current-module)) (env vlist-null) + #:key + (operator-size-limit 40) + (operand-size-limit 20) + (value-size-limit 10) + (effort-limit 500) + (recursive-effort-limit 100)) "Partially evaluate EXP in compilation environment CENV, with top-level bindings from ENV and return the resulting expression. Since it does not handle and , it should be called before @@ -470,6 +460,20 @@ it does not handle and , it should be called before (and (loop exp) (loop body))) (_ #f)))) + (define (small-expression? x limit) + (let/ec k + (tree-il-fold + (lambda (x res) ; leaf + (1+ res)) + (lambda (x res) ; down + (1+ res)) + (lambda (x res) ; up + (if (< res limit) + res + (k #f))) + 0 x) + #t)) + (define (mutable? exp) ;; Return #t if EXP is a mutable object. ;; todo: add an option to assume pairs are immutable @@ -517,47 +521,28 @@ it does not handle and , it should be called before (or (make-value-construction src value) orig))) (_ new))) - (define (maybe-unlambda orig new env) - ;; If NEW is a named lambda and ORIG is what it looked like before - ;; partial evaluation, then attempt to replace NEW with a lexical - ;; ref, to avoid code duplication. - (match new - (($ src (= (cut assq-ref <> 'name) (? symbol? name)) - ($ _ req opt rest kw inits gensyms body)) - ;; Look for NEW in the current environment, starting from the - ;; outermost frame. - (or (vlist-any (lambda (x) - (and (eq? (cdr x) new) - (begin - (record-residual-lexical-reference! (car x)) - (make-lexical-ref src name (car x))))) - env) - new)) - (($ src () - (and lc ($ ))) - ;; This is an anonymous lambda that we're going to inline. - ;; Inlining creates new variable bindings, so we need to provide - ;; the new code with fresh names. - (record-source-expression! new (alpha-rename new))) - (_ new))) - (catch 'match-error (lambda () (let loop ((exp exp) (env vlist-null) ; static environment - (calls '()) ; inlined call stack - (ctx 'value)) ; effect, value, test, or call + (counter #f) ; inlined call stack + (ctx 'value)) ; effect, value, test, operator, or operand (define (lookup var) (and=> (vhash-assq var env) cdr)) (define (for-value exp) - (loop exp env calls 'value)) + (loop exp env counter 'value)) + (define (for-operand exp) + (loop exp env counter 'operand)) (define (for-test exp) - (loop exp env calls 'test)) + (loop exp env counter 'test)) (define (for-effect exp) - (loop exp env calls 'effect)) + (loop exp env counter 'effect)) (define (for-tail exp) - (loop exp env calls ctx)) + (loop exp env counter ctx)) + + (if counter + (record-effort! counter)) (match exp (($ ) @@ -581,29 +566,55 @@ it does not handle and , it should be called before ;; and don't reorder effects. (record-residual-lexical-reference! gensym) exp) + ((lexical-ref? val) + (for-tail val)) ((or (const? val) (void? val) - (lexical-ref? val) - (toplevel-ref? val) (primitive-ref? val)) ;; Always propagate simple values that cannot lead to ;; code bloat. - (case ctx - ((test) (for-test val)) - (else val))) + (for-tail val)) ((= 1 (lexical-refcount gensym)) ;; Always propagate values referenced only once. ;; There is no need to rename the bindings, as they - ;; are only being moved, not copied. + ;; are only being moved, not copied. However in + ;; operator context we do rename it, as that + ;; effectively clears out the residualized-lexical + ;; flags that may have been set when this value was + ;; visited previously as an operand. (case ctx ((test) (for-test val)) + ((operator) (record-source-expression! val (alpha-rename val))) (else val))) + ;; FIXME: do demand-driven size accounting rather than + ;; these heuristics. + ((eq? ctx 'operator) + ;; A pure expression in the operator position. Inline + ;; if it's a lambda that's small enough. + (if (and (lambda? val) + (small-expression? val operator-size-limit)) + (record-source-expression! val (alpha-rename val)) + (begin + (record-residual-lexical-reference! gensym) + exp))) + ((eq? ctx 'operand) + ;; A pure expression in the operand position. Inline + ;; if it's small enough. + (if (small-expression? val operand-size-limit) + (record-source-expression! val (alpha-rename val)) + (begin + (record-residual-lexical-reference! gensym) + exp))) (else - ;; Always propagate constant expressions. FIXME: leads to - ;; divergence! - (case ctx - ((test) (for-test val)) - (else val)))))))) + ;; A pure expression, processed for value. Don't + ;; inline lambdas, because they will probably won't + ;; fold because we don't know the operator. + (if (and (small-expression? val value-size-limit) + (not (tree-il-any lambda? val))) + (record-source-expression! val (alpha-rename val)) + (begin + (record-residual-lexical-reference! gensym) + exp)))))))) (($ src name gensym exp) (if (zero? (lexical-refcount gensym)) (let ((exp (for-effect exp))) @@ -616,45 +627,58 @@ it does not handle and , it should be called before (maybe-unconst exp (for-value exp)))))) (($ src names gensyms vals body) - (let* ((vals* (map for-value vals)) + (let* ((vals* (map for-operand vals)) (vals (map maybe-unconst vals vals*)) (body* (loop body (fold vhash-consq env gensyms vals) - calls + counter ctx)) (body (maybe-unconst body body*))) - (if (const? body*) - body - ;; Only include bindings for which lexical references - ;; have been residualized. - (let*-values - (((stripped) (remove - (lambda (x) - (and (not (hashq-ref - residual-lexical-references - (cadr x))) - ;; FIXME: Here we can probably - ;; strip pure expressions in - ;; addition to constant - ;; expressions. - (constant-expression? (car x)))) - (zip vals gensyms names))) - ((vals gensyms names) (unzip3 stripped))) - (if (null? stripped) - body - (make-let src names gensyms vals body)))))) + (cond + ((const? body*) + (for-tail (make-sequence src (append vals (list body))))) + ((and (lexical-ref? body) + (memq (lexical-ref-gensym body) gensyms)) + (let ((sym (lexical-ref-gensym body)) + (pairs (map cons gensyms vals))) + ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo) + (for-tail + (make-sequence + src + (append (map cdr (alist-delete sym pairs eq?)) + (list (assq-ref pairs sym))))))) + (else + ;; Only include bindings for which lexical references + ;; have been residualized. + (let*-values + (((stripped) (remove + (lambda (x) + (and (not (hashq-ref + residual-lexical-references + (cadr x))) + ;; FIXME: Here we can probably + ;; strip pure expressions in + ;; addition to constant + ;; expressions. + (constant-expression? (car x)))) + (zip vals gensyms names))) + ((vals gensyms names) (unzip3 stripped))) + (if (null? stripped) + body + (make-let src names gensyms vals body))))))) (($ src in-order? names gensyms vals body) ;; Things could be done more precisely when IN-ORDER? but ;; it's OK not to do it---at worst we lost an optimization ;; opportunity. - (let* ((vals* (map for-value vals)) + (let* ((vals* (map for-operand vals)) (vals (map maybe-unconst vals vals*)) (body* (loop body (fold vhash-consq env gensyms vals) - calls + counter ctx)) (body (maybe-unconst body body*))) - (if (const? body*) + (if (and (const? body*) + (every constant-expression? vals*)) body (let*-values (((stripped) (remove @@ -669,13 +693,14 @@ it does not handle and , it should be called before body (make-letrec src in-order? names gensyms vals body)))))) (($ src names gensyms vals body) - (let* ((vals (map for-value vals)) + (let* ((vals (map for-operand vals)) (body* (loop body (fold vhash-consq env gensyms vals) - calls + counter ctx)) (body (maybe-unconst body body*))) - (if (const? body*) + (if (and (const? body*) + (every constant-expression? vals)) body (make-fix src names gensyms vals body)))) (($ lv-src producer consumer) @@ -747,84 +772,106 @@ it does not handle and , it should be called before (($ src orig-proc orig-args) ;; todo: augment the global env with specialized functions - (let* ((proc (loop orig-proc env calls 'call)) - (proc* (maybe-unlambda orig-proc proc env)) - (args (map for-value orig-args)) - (args* (map (cut maybe-unlambda <> <> env) - orig-args - (map maybe-unconst orig-args args))) - (app (make-application src proc* args*))) - ;; If at least one of ARGS is static (to avoid infinite - ;; inlining) and this call hasn't already been expanded - ;; before (to avoid infinite recursion), then expand it - ;; (todo: emit an infinite recursion warning.) - (if (and (or (null? args) (any const*? args)) - (not (member (cons proc args) calls))) - (match proc - (($ _ (? effect-free-primitive? name)) - (if (every const? args) ; only simple constants - (let-values (((success? values) - (apply-primitive name - (map const-exp args)))) - (if success? - (case ctx - ((effect) (make-void #f)) - ((test) - ;; Values truncation: only take the first - ;; value. - (if (pair? values) - (make-const #f (car values)) - (make-values src '()))) - (else - (make-values src (map (cut make-const src <>) - values)))) - app)) - app)) - (($ ) - ;; An effectful primitive. - app) - (($ _ _ - ($ _ req opt #f #f inits gensyms body)) - ;; Simple case: no rest, no keyword arguments. - ;; todo: handle the more complex cases - (let ((nargs (length args)) - (nreq (length req)) - (nopt (if opt (length opt) 0))) - (if (and (>= nargs nreq) (<= nargs (+ nreq nopt)) - (every constant-expression? args)) - (let* ((params - (append args - (drop inits - (max 0 - (- nargs - (+ nreq nopt)))))) - (body - (loop body - (fold vhash-consq env gensyms params) - (cons (cons proc args) calls) - ctx))) - ;; If the residual code contains recursive - ;; calls, give up inlining. - (if (code-contains-calls? body proc lookup) - app - body)) - app))) - (($ ) - app) - (($ ) - app) - - ;; In practice, this is the clause that stops peval: - ;; module-ref applications (produced by macros, - ;; typically) don't match, and so this throws, - ;; aborting peval for an entire expression. - ) + (let ((proc (loop orig-proc env counter 'operator))) + (match proc + (($ _ (? effect-free-primitive? name)) + (let ((args (map for-value orig-args))) + (if (every const? args) ; only simple constants + (let-values (((success? values) + (apply-primitive name + (map const-exp args)))) + (if success? + (case ctx + ((effect) (make-void #f)) + ((test) + ;; Values truncation: only take the first + ;; value. + (if (pair? values) + (make-const #f (car values)) + (make-values src '()))) + (else + (make-values src (map (cut make-const src <>) + values)))) + (make-application src proc + (map maybe-unconst orig-args args)))) + (make-application src proc + (map maybe-unconst orig-args args))))) + (($ _ _ + ($ _ req opt #f #f inits gensyms body #f)) + ;; Simple case: no rest, no keyword arguments. + ;; todo: handle the more complex cases + (let* ((nargs (length orig-args)) + (nreq (length req)) + (nopt (if opt (length opt) 0)) + (key (source-expression proc))) + (cond + ((or (< nargs nreq) (> nargs (+ nreq nopt))) + ;; An error, or effecting arguments. + (make-application src (for-value orig-proc) + (map maybe-unconst orig-args + (map for-value orig-args)))) + ((and=> (find-counter key counter) counter-recursive?) + ;; A recursive call. Process again in tail context. + (loop (make-let src (append req (or opt '())) + gensyms + (append orig-args + (drop inits + (max 0 + (- nargs + (+ nreq nopt))))) + body) + env counter ctx)) + (else + ;; An integration at the top-level, the first + ;; recursion of a recursive procedure, or a nested + ;; integration of a procedure that hasn't been seen + ;; yet. + (let/ec k + (let ((abort (lambda () + (k (make-application + src + (for-value orig-proc) + (map maybe-unconst orig-args + (map for-value orig-args))))))) + (loop (make-let src (append req (or opt '())) + gensyms + (append orig-args + (drop inits + (max 0 + (- nargs + (+ nreq nopt))))) + body) + env + (cond + ((find-counter key counter) + => (lambda (prev) + (make-recursive-counter recursive-effort-limit + operand-size-limit + prev counter))) + (counter + (make-nested-counter abort key counter)) + (else + (make-top-counter effort-limit operand-size-limit + abort key))) + ctx))))))) + ((or ($ ) + ($ ) + ($ ) + ($ )) + (make-application src proc + (map maybe-unconst orig-args + (map for-value orig-args)))) - app))) + ;; In practice, this is the clause that stops peval: + ;; module-ref applications (produced by macros, + ;; typically) don't match, and so this throws, + ;; aborting peval for an entire expression. + ))) (($ src meta body) (case ctx ((effect) (make-void #f)) ((test) (make-const #f #t)) + ((operator) exp) (else (make-lambda src meta (for-value body))))) (($ src req opt rest kw inits gensyms body alt) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 0fb5659ed..a913541ac 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -663,18 +663,88 @@ (apply (primitive list) (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))) + ;; These two tests doesn't work any more because we changed the way we + ;; deal with constants -- now the algorithm will see a construction as + ;; being bound to the lexical, so it won't propagate it. It can't + ;; even propagate it in the case that it is only referenced once, + ;; because: + ;; + ;; (let ((x (cons 1 2))) (lambda () x)) + ;; + ;; is not the same as + ;; + ;; (lambda () (cons 1 2)) + ;; + ;; Perhaps if we determined that not only was it only referenced once, + ;; it was not closed over by a lambda, then we could propagate it, and + ;; re-enable these two tests. + ;; + #; (pass-if-peval - ;; First order, mutability preserved. - (define mutable - (let loop ((i 3) (r '())) - (if (zero? i) - r - (loop (1- i) (cons (cons i i) r))))) - (define mutable - (apply (primitive list) - (apply (primitive cons) (const 1) (const 1)) - (apply (primitive cons) (const 2) (const 2)) - (apply (primitive cons) (const 3) (const 3))))) + ;; First order, mutability preserved. + (let loop ((i 3) (r '())) + (if (zero? i) + r + (loop (1- i) (cons (cons i i) r)))) + (apply (primitive list) + (apply (primitive cons) (const 1) (const 1)) + (apply (primitive cons) (const 2) (const 2)) + (apply (primitive cons) (const 3) (const 3)))) + ;; + ;; See above. + #; + (pass-if-peval + ;; First order, evaluated. + (let loop ((i 7) + (r '())) + (if (<= i 0) + (car r) + (loop (1- i) (cons i r)))) + (const 1)) + + ;; Instead here are tests for what happens for the above cases: they + ;; unroll but they don't fold. + (pass-if-peval + (let loop ((i 3) (r '())) + (if (zero? i) + r + (loop (1- i) (cons (cons i i) r)))) + (letrec (loop) (_) (_) + (let (r) (_) + ((apply (primitive list) + (apply (primitive cons) (const 3) (const 3)))) + (let (r) (_) + ((apply (primitive cons) + (apply (primitive cons) (const 2) (const 2)) + (lexical r _))) + (apply (primitive cons) + (apply (primitive cons) (const 1) (const 1)) + (lexical r _)))))) + + ;; See above. + (pass-if-peval + (let loop ((i 4) + (r '())) + (if (<= i 0) + (car r) + (loop (1- i) (cons i r)))) + (letrec (loop) (_) (_) + (let (r) (_) + ((apply (primitive list) (const 4))) + (let (r) (_) + ((apply (primitive cons) + (const 3) + (lexical r _))) + (let (r) (_) + ((apply (primitive cons) + (const 2) + (lexical r _))) + (let (r) (_) + ((apply (primitive cons) + (const 1) + (lexical r _))) + (apply (primitive car) + (lexical r _)))))))) (pass-if-peval ;; Mutability preserved. @@ -708,14 +778,14 @@ (lexical y _)))) (pass-if-peval - ;; First order, evaluated. - (define one - (let loop ((i 7) - (r '())) - (if (<= i 0) - (car r) - (loop (1- i) (cons i r))))) - (define one (const 1))) + ;; Infinite recursion + ((lambda (x) (x x)) (lambda (x) (x x))) + (let (x) (_) + ((lambda _ + (lambda-case + (((x) _ _ _ _ _) + (apply (lexical x _) (lexical x _)))))) + (apply (lexical x _) (lexical x _)))) (pass-if-peval ;; First order, aliased primitive. @@ -759,8 +829,7 @@ (lambda (_) (lambda-case (((x) #f #f #f () (_)) - (letrec* (bar) (_) ((lambda (_) . _)) - (apply (primitive +) (lexical x _) (const 9)))))))) + (apply (primitive +) (lexical x _) (const 9))))))) (pass-if-peval ;; First order, with lambda inlined & specialized twice. @@ -770,55 +839,40 @@ (y 3)) (+ (* x (f x y)) (f something x))) - (let (f) (_) ((lambda (_) - (lambda-case - (((x y) #f #f #f () (_ _)) - (apply (primitive +) - (apply (primitive *) - (lexical x _) - (toplevel top)) - (lexical y _)))))) - (apply (primitive +) - (apply (primitive *) - (const 2) - (apply (primitive +) ; (f 2 3) - (apply (primitive *) - (const 2) - (toplevel top)) - (const 3))) - (apply (lexical f _) ; (f something 2) - ;; This arg is not const, so the lambda does not - ;; fold. We will fix this in the future when we - ;; inline lambda to `let'. That will offer the - ;; possibility of creating a lexical binding for - ;; `something', to preserve the order of effects. - (toplevel something) + (apply (primitive +) + (apply (primitive *) + (const 2) + (apply (primitive +) ; (f 2 3) + (apply (primitive *) + (const 2) + (toplevel top)) + (const 3))) + (let (x) (_) ((toplevel something)) ; (f something 2) + ;; `something' is not const, so preserve order of + ;; effects with a lexical binding. + (apply (primitive +) + (apply (primitive *) + (lexical x _) + (toplevel top)) (const 2))))) - + (pass-if-peval - ;; First order, with lambda inlined & specialized 3 times. - (let ((f (lambda (x y) (if (> x 0) y x)))) - (+ (f -1 0) - (f 1 0) - (f -1 y) - (f 2 y) - (f z y))) - (let (f) (_) - ((lambda (_) - (lambda-case - (((x y) #f #f #f () (_ _)) - (if (apply (primitive >) (lexical x _) (const 0)) - (lexical y _) - (lexical x _)))))) - (apply (primitive +) - (const -1) ; (f -1 0) - (const 0) ; (f 1 0) - (apply (lexical f _) ; (f -1 y) - (const -1) (toplevel y)) - (apply (lexical f _) ; (f 2 y) - (const 2) (toplevel y)) - (apply (lexical f _) ; (f z y) - (toplevel z) (toplevel y))))) + ;; First order, with lambda inlined & specialized 3 times. + (let ((f (lambda (x y) (if (> x 0) y x)))) + (+ (f -1 0) + (f 1 0) + (f -1 y) + (f 2 y) + (f z y))) + (apply (primitive +) + (const -1) ; (f -1 0) + (const 0) ; (f 1 0) + (begin (toplevel y) (const -1)) ; (f -1 y) + (toplevel y) ; (f 2 y) + (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y) + (if (apply (primitive >) (lexical x _) (const 0)) + (lexical y _) + (lexical x _))))) (pass-if-peval ;; First order, conditional. @@ -839,8 +893,8 @@ n (+ (fibo (- n 1)) (fibo (- n 2))))))) - (fibo 7)) - (const 13)) + (fibo 4)) + (const 3)) (pass-if-peval ;; Don't propagate toplevel references, as intervening expressions @@ -884,25 +938,15 @@ (pass-if-peval ;; Higher order. ((lambda (f) (f x)) (lambda (x) x)) - (apply (lambda () - (lambda-case - (((x) #f #f #f () (_)) - (lexical x _)))) - (toplevel x))) + (toplevel x)) (pass-if-peval ;; Bug reported at ;; . (let ((fold (lambda (f g) (f (g top))))) (fold 1+ (lambda (x) x))) - (let (fold) (_) (_) - (apply (primitive 1+) - (apply (lambda () - (lambda-case - (((x) #f #f #f () (_)) - (lexical x _)))) - (toplevel top))))) - + (apply (primitive 1+) (toplevel top))) + (pass-if-peval ;; Procedure not inlined when residual code contains recursive calls. ;; @@ -940,20 +984,19 @@ (lambda (x) (lambda (y) (+ x y))))) (cons (make-adder 1) (make-adder 2))) #:to 'tree-il))) - ((let (make-adder) (_) (_) - (apply (primitive cons) - (lambda () - (lambda-case - (((y) #f #f #f () (,gensym1)) - (apply (primitive +) - (const 1) - (lexical y ,ref1))))) - (lambda () - (lambda-case - (((y) #f #f #f () (,gensym2)) - (apply (primitive +) - (const 2) - (lexical y ,ref2))))))) + ((apply (primitive cons) + (lambda () + (lambda-case + (((y) #f #f #f () (,gensym1)) + (apply (primitive +) + (const 1) + (lexical y ,ref1))))) + (lambda () + (lambda-case + (((y) #f #f #f () (,gensym2)) + (apply (primitive +) + (const 2) + (lexical y ,ref2)))))) (and (eq? gensym1 ref1) (eq? gensym2 ref2) (not (eq? gensym1 gensym2)))) @@ -1018,40 +1061,27 @@ (vector 1 2 3) (make-list 10) (list 1 2 3)) - (apply (lambda () - (lambda-case - (((x y z) #f #f #f () (_ _ _)) - (begin - (apply (toplevel vector-set!) - (lexical x _) (const 0) (const 0)) - (apply (toplevel set-car!) - (lexical y _) (const 0)) - (apply (toplevel set-cdr!) - (lexical z _) (const ())))))) - (apply (primitive vector) (const 1) (const 2) (const 3)) - (apply (toplevel make-list) (const 10)) - (apply (primitive list) (const 1) (const 2) (const 3)))) + (let (x y z) (_ _ _) + ((apply (primitive vector) (const 1) (const 2) (const 3)) + (apply (toplevel make-list) (const 10)) + (apply (primitive list) (const 1) (const 2) (const 3))) + (begin + (apply (toplevel vector-set!) + (lexical x _) (const 0) (const 0)) + (apply (toplevel set-car!) + (lexical y _) (const 0)) + (apply (toplevel set-cdr!) + (lexical z _) (const ()))))) (pass-if-peval - ;; Procedure only called with dynamic args is not inlined. (let ((foo top-foo) (bar top-bar)) (let* ((g (lambda (x y) (+ x y))) (f (lambda (g x) (g x x)))) (+ (f g foo) (f g bar)))) (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar)) - (let (g) (_) - ((lambda _ ; g - (lambda-case - (((x y) #f #f #f () (_ _)) - (apply (primitive +) (lexical x _) (lexical y _)))))) - (let (f) (_) - ((lambda _ ; f - (lambda-case - (((g x) #f #f #f () (_ _)) - (apply (lexical g _) (lexical x _) (lexical x _)))))) - (apply (primitive +) - (apply (lexical g _) (lexical foo _) (lexical foo _)) - (apply (lexical g _) (lexical bar _) (lexical bar _))))))) + (apply (primitive +) + (apply (primitive +) (lexical foo _) (lexical foo _)) + (apply (primitive +) (lexical bar _) (lexical bar _))))) (pass-if-peval ;; Fresh objects are not turned into constants. @@ -1060,9 +1090,8 @@ (y (cons 0 x))) y) (let (x) (_) ((apply (primitive list) (const 1) (const 2) (const 3))) - (let (y) (_) ((apply (primitive cons) (const 0) (lexical x _))) - (lexical y _)))) - + (apply (primitive cons) (const 0) (lexical x _)))) + (pass-if-peval ;; Bindings mutated. (let ((x 2)) @@ -1081,10 +1110,10 @@ x))) (frob f) ; may mutate `x' x) - (letrec (x f) (_ _) ((const 0) _) + (letrec (x) (_) ((const 0)) (begin - (apply (toplevel frob) (lexical f _)) - (lexical x _)))) + (apply (toplevel frob) (lambda _ _)) + (lexical x _)))) (pass-if-peval ;; Bindings mutated. @@ -1130,11 +1159,14 @@ (pass-if-peval ;; Inlining aborted when residual code contains recursive calls. + ;; ;; (let loop ((x x) (y 0)) (if (> y 0) - (loop (1+ x) (1+ y)) - (if (< x 0) x (loop (1- x))))) + (loop (1- x) (1- y)) + (if (< x 0) + x + (loop (1+ x) (1+ y))))) (letrec (loop) (_) ((lambda (_) (lambda-case (((x y) #f #f #f () (_ _))