mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

peval uses effort counters, propagates lambdas more effectively

Browse source 
* module/language/tree-il/optimize.scm (code-contains-calls?): Remove
  this helper, we will deal with recursion when it happens, not after
  the fact.
  (peval): Add keyword args for various size and effort limits.  Instead
  of keeping a call stack, keep a chain of <counter> records, each with
  an abort continuation.  If ever an inlining attempt is taking too
  long, measured in terms of number of trips through the main loop, the
  counter will abort.  Add new contexts, `operator' and `operand'.  They
  have different default size limits.  In the future we should actually
  use the size counter, instead of these heuristics.

  The <lexical-ref> case is smarter now, and tries to avoid propagating
  too much data.  Perhaps it should be dumber though, and use a
  counter.  That would require changes to the environment structure.

  Inline <lambda> applications to <let>, so that we allow residual
  lexical references to have bindings.  Add a `for-operand' helper, and
  use it for the RHS of `let' expressions.  A `let' is an inlined
  `lambda'.

  `Let' and company no longer elide bindings if the result is a
  constant, as the arguments could have effects.  Peval will still do as
  much as it can, though.

* test-suite/tests/tree-il.test ("partial evaluation"): Update the tests
  for the new expectations.  They are uniformly awesomer, with the
  exception of two cases in which pure but not constant data is not
  propagated.
This commit is contained in:
Andy Wingo 2011-09-23 00:29:14 +02:00
parent fab137869e
commit b839233282
2 changed files with 370 additions and 291 deletions
Download patch file Download diff file Expand all files Collapse all files

365
module/language/tree-il/optimize.scm
View file

@ -176,22 +176,6 @@ references to the new symbols."
(lambda (exp res) #f) (lambda (exp res) #f)
#f exp))) #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
(($ <application> _
(and ref ($ <lexical-ref> _ _ gensym)) _)
(or (equal? ref proc)
(equal? (lookup gensym) proc)))
(($ <application>
(and proc* ($ <lambda>)))
(equal? proc* proc))
(_ #f)))
body))
(define (vlist-any proc vlist) (define (vlist-any proc vlist)
(let ((len (vlist-length vlist))) (let ((len (vlist-length vlist)))
(let lp ((i 0)) (let lp ((i 0))
@ -287,7 +271,13 @@ lexical references."
(counter-data orig) (counter-data orig)
current)) 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 "Partially evaluate EXP in compilation environment CENV, with
top-level bindings from ENV and return the resulting expression. Since top-level bindings from ENV and return the resulting expression. Since
it does not handle <fix> and <let-values>, it should be called before it does not handle <fix> and <let-values>, it should be called before
@ -470,6 +460,20 @@ it does not handle <fix> and <let-values>, it should be called before
(and (loop exp) (loop body))) (and (loop exp) (loop body)))
(_ #f)))) (_ #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) (define (mutable? exp)
;; Return #t if EXP is a mutable object. ;; Return #t if EXP is a mutable object.
;; todo: add an option to assume pairs are immutable ;; todo: add an option to assume pairs are immutable
@ -517,47 +521,28 @@ it does not handle <fix> and <let-values>, it should be called before
(or (make-value-construction src value) orig))) (or (make-value-construction src value) orig)))
(_ new))) (_ 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
(($ <lambda> src (= (cut assq-ref <> 'name) (? symbol? name))
($ <lambda-case> _ 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))
(($ <lambda> src ()
(and lc ($ <lambda-case>)))
;; 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 (catch 'match-error
(lambda () (lambda ()
(let loop ((exp exp) (let loop ((exp exp)
(env vlist-null) ; static environment (env vlist-null) ; static environment
(calls '()) ; inlined call stack (counter #f) ; inlined call stack
(ctx 'value)) ; effect, value, test, or call (ctx 'value)) ; effect, value, test, operator, or operand
(define (lookup var) (define (lookup var)
(and=> (vhash-assq var env) cdr)) (and=> (vhash-assq var env) cdr))
(define (for-value exp) (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) (define (for-test exp)
(loop exp env calls 'test)) (loop exp env counter 'test))
(define (for-effect exp) (define (for-effect exp)
(loop exp env calls 'effect)) (loop exp env counter 'effect))
(define (for-tail exp) (define (for-tail exp)
(loop exp env calls ctx)) (loop exp env counter ctx))
(if counter
(record-effort! counter))
(match exp (match exp
(($ <const>) (($ <const>)
@ -581,29 +566,55 @@ it does not handle <fix> and <let-values>, it should be called before
;; and don't reorder effects. ;; and don't reorder effects.
(record-residual-lexical-reference! gensym) (record-residual-lexical-reference! gensym)
exp) exp)
((lexical-ref? val)
(for-tail val))
((or (const? val) ((or (const? val)
(void? val) (void? val)
(lexical-ref? val)
(toplevel-ref? val)
(primitive-ref? val)) (primitive-ref? val))
;; Always propagate simple values that cannot lead to ;; Always propagate simple values that cannot lead to
;; code bloat. ;; code bloat.
(case ctx (for-tail val))
((test) (for-test val))
(else val)))
((= 1 (lexical-refcount gensym)) ((= 1 (lexical-refcount gensym))
;; Always propagate values referenced only once. ;; Always propagate values referenced only once.
;; There is no need to rename the bindings, as they ;; 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 (case ctx
((test) (for-test val)) ((test) (for-test val))
((operator) (record-source-expression! val (alpha-rename val)))
(else 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 (else
;; Always propagate constant expressions. FIXME: leads to ;; A pure expression, processed for value. Don't
;; divergence! ;; inline lambdas, because they will probably won't
(case ctx ;; fold because we don't know the operator.
((test) (for-test val)) (if (and (small-expression? val value-size-limit)
(else val)))))))) (not (tree-il-any lambda? val)))
(record-source-expression! val (alpha-rename val))
(begin
(record-residual-lexical-reference! gensym)
exp))))))))
(($ <lexical-set> src name gensym exp) (($ <lexical-set> src name gensym exp)
(if (zero? (lexical-refcount gensym)) (if (zero? (lexical-refcount gensym))
(let ((exp (for-effect exp))) (let ((exp (for-effect exp)))
@ -616,45 +627,58 @@ it does not handle <fix> and <let-values>, it should be called before
(maybe-unconst exp (maybe-unconst exp
(for-value exp)))))) (for-value exp))))))
(($ <let> src names gensyms vals body) (($ <let> src names gensyms vals body)
(let* ((vals* (map for-value vals)) (let* ((vals* (map for-operand vals))
(vals (map maybe-unconst vals vals*)) (vals (map maybe-unconst vals vals*))
(body* (loop body (body* (loop body
(fold vhash-consq env gensyms vals) (fold vhash-consq env gensyms vals)
calls counter
ctx)) ctx))
(body (maybe-unconst body body*))) (body (maybe-unconst body body*)))
(if (const? body*) (cond
body ((const? body*)
;; Only include bindings for which lexical references (for-tail (make-sequence src (append vals (list body)))))
;; have been residualized. ((and (lexical-ref? body)
(let*-values (memq (lexical-ref-gensym body) gensyms))
(((stripped) (remove (let ((sym (lexical-ref-gensym body))
(lambda (x) (pairs (map cons gensyms vals)))
(and (not (hashq-ref ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
residual-lexical-references (for-tail
(cadr x))) (make-sequence
;; FIXME: Here we can probably src
;; strip pure expressions in (append (map cdr (alist-delete sym pairs eq?))
;; addition to constant (list (assq-ref pairs sym)))))))
;; expressions. (else
(constant-expression? (car x)))) ;; Only include bindings for which lexical references
(zip vals gensyms names))) ;; have been residualized.
((vals gensyms names) (unzip3 stripped))) (let*-values
(if (null? stripped) (((stripped) (remove
body (lambda (x)
(make-let src names gensyms vals body)))))) (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)))))))
(($ <letrec> src in-order? names gensyms vals body) (($ <letrec> src in-order? names gensyms vals body)
;; Things could be done more precisely when IN-ORDER? but ;; Things could be done more precisely when IN-ORDER? but
;; it's OK not to do it---at worst we lost an optimization ;; it's OK not to do it---at worst we lost an optimization
;; opportunity. ;; opportunity.
(let* ((vals* (map for-value vals)) (let* ((vals* (map for-operand vals))
(vals (map maybe-unconst vals vals*)) (vals (map maybe-unconst vals vals*))
(body* (loop body (body* (loop body
(fold vhash-consq env gensyms vals) (fold vhash-consq env gensyms vals)
calls counter
ctx)) ctx))
(body (maybe-unconst body body*))) (body (maybe-unconst body body*)))
(if (const? body*) (if (and (const? body*)
(every constant-expression? vals*))
body body
(let*-values (let*-values
(((stripped) (remove (((stripped) (remove
@ -669,13 +693,14 @@ it does not handle <fix> and <let-values>, it should be called before
body body
(make-letrec src in-order? names gensyms vals body)))))) (make-letrec src in-order? names gensyms vals body))))))
(($ <fix> src names gensyms vals body) (($ <fix> src names gensyms vals body)
(let* ((vals (map for-value vals)) (let* ((vals (map for-operand vals))
(body* (loop body (body* (loop body
(fold vhash-consq env gensyms vals) (fold vhash-consq env gensyms vals)
calls counter
ctx)) ctx))
(body (maybe-unconst body body*))) (body (maybe-unconst body body*)))
(if (const? body*) (if (and (const? body*)
(every constant-expression? vals))
body body
(make-fix src names gensyms vals body)))) (make-fix src names gensyms vals body))))
(($ <let-values> lv-src producer consumer) (($ <let-values> lv-src producer consumer)
@ -747,84 +772,106 @@ it does not handle <fix> and <let-values>, it should be called before
(($ <application> src orig-proc orig-args) (($ <application> src orig-proc orig-args)
;; todo: augment the global env with specialized functions ;; todo: augment the global env with specialized functions
(let* ((proc (loop orig-proc env calls 'call)) (let ((proc (loop orig-proc env counter 'operator)))
(proc* (maybe-unlambda orig-proc proc env)) (match proc
(args (map for-value orig-args)) (($ <primitive-ref> _ (? effect-free-primitive? name))
(args* (map (cut maybe-unlambda <> <> env) (let ((args (map for-value orig-args)))
orig-args (if (every const? args) ; only simple constants
(map maybe-unconst orig-args args))) (let-values (((success? values)
(app (make-application src proc* args*))) (apply-primitive name
;; If at least one of ARGS is static (to avoid infinite (map const-exp args))))
;; inlining) and this call hasn't already been expanded (if success?
;; before (to avoid infinite recursion), then expand it (case ctx
;; (todo: emit an infinite recursion warning.) ((effect) (make-void #f))
(if (and (or (null? args) (any const*? args)) ((test)
(not (member (cons proc args) calls))) ;; Values truncation: only take the first
(match proc ;; value.
(($ <primitive-ref> _ (? effect-free-primitive? name)) (if (pair? values)
(if (every const? args) ; only simple constants (make-const #f (car values))
(let-values (((success? values) (make-values src '())))
(apply-primitive name (else
(map const-exp args)))) (make-values src (map (cut make-const src <>)
(if success? values))))
(case ctx (make-application src proc
((effect) (make-void #f)) (map maybe-unconst orig-args args))))
((test) (make-application src proc
;; Values truncation: only take the first (map maybe-unconst orig-args args)))))
;; value. (($ <lambda> _ _
(if (pair? values) ($ <lambda-case> _ req opt #f #f inits gensyms body #f))
(make-const #f (car values)) ;; Simple case: no rest, no keyword arguments.
(make-values src '()))) ;; todo: handle the more complex cases
(else (let* ((nargs (length orig-args))
(make-values src (map (cut make-const src <>) (nreq (length req))
values)))) (nopt (if opt (length opt) 0))
app)) (key (source-expression proc)))
app)) (cond
(($ <primitive-ref>) ((or (< nargs nreq) (> nargs (+ nreq nopt)))
;; An effectful primitive. ;; An error, or effecting arguments.
app) (make-application src (for-value orig-proc)
(($ <lambda> _ _ (map maybe-unconst orig-args
($ <lambda-case> _ req opt #f #f inits gensyms body)) (map for-value orig-args))))
;; Simple case: no rest, no keyword arguments. ((and=> (find-counter key counter) counter-recursive?)
;; todo: handle the more complex cases ;; A recursive call. Process again in tail context.
(let ((nargs (length args)) (loop (make-let src (append req (or opt '()))
(nreq (length req)) gensyms
(nopt (if opt (length opt) 0))) (append orig-args
(if (and (>= nargs nreq) (<= nargs (+ nreq nopt)) (drop inits
(every constant-expression? args)) (max 0
(let* ((params (- nargs
(append args (+ nreq nopt)))))
(drop inits body)
(max 0 env counter ctx))
(- nargs (else
(+ nreq nopt)))))) ;; An integration at the top-level, the first
(body ;; recursion of a recursive procedure, or a nested
(loop body ;; integration of a procedure that hasn't been seen
(fold vhash-consq env gensyms params) ;; yet.
(cons (cons proc args) calls) (let/ec k
ctx))) (let ((abort (lambda ()
;; If the residual code contains recursive (k (make-application
;; calls, give up inlining. src
(if (code-contains-calls? body proc lookup) (for-value orig-proc)
app (map maybe-unconst orig-args
body)) (map for-value orig-args)))))))
app))) (loop (make-let src (append req (or opt '()))
(($ <lambda>) gensyms
app) (append orig-args
(($ <toplevel-ref>) (drop inits
app) (max 0
(- nargs
;; In practice, this is the clause that stops peval: (+ nreq nopt)))))
;; module-ref applications (produced by macros, body)
;; typically) don't match, and so this throws, env
;; aborting peval for an entire expression. (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 ($ <primitive-ref>)
($ <lambda>)
($ <toplevel-ref>)
($ <lexical-ref>))
(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.
)))
(($ <lambda> src meta body) (($ <lambda> src meta body)
(case ctx (case ctx
((effect) (make-void #f)) ((effect) (make-void #f))
((test) (make-const #f #t)) ((test) (make-const #f #t))
((operator) exp)
(else (else
(make-lambda src meta (for-value body))))) (make-lambda src meta (for-value body)))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt) (($ <lambda-case> src req opt rest kw inits gensyms body alt)

296
test-suite/tests/tree-il.test
View file

@ -663,18 +663,88 @@
(apply (primitive list) (apply (primitive list)
(const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))) (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 (pass-if-peval
;; First order, mutability preserved. ;; First order, mutability preserved.
(define mutable (let loop ((i 3) (r '()))
(let loop ((i 3) (r '())) (if (zero? i)
(if (zero? i) r
r (loop (1- i) (cons (cons i i) r))))
(loop (1- i) (cons (cons i i) r))))) (apply (primitive list)
(define mutable (apply (primitive cons) (const 1) (const 1))
(apply (primitive list) (apply (primitive cons) (const 2) (const 2))
(apply (primitive cons) (const 1) (const 1)) (apply (primitive cons) (const 3) (const 3))))
(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 (pass-if-peval
;; Mutability preserved. ;; Mutability preserved.
@ -708,14 +778,14 @@
(lexical y _)))) (lexical y _))))
(pass-if-peval (pass-if-peval
;; First order, evaluated. ;; Infinite recursion
(define one ((lambda (x) (x x)) (lambda (x) (x x)))
(let loop ((i 7) (let (x) (_)
(r '())) ((lambda _
(if (<= i 0) (lambda-case
(car r) (((x) _ _ _ _ _)
(loop (1- i) (cons i r))))) (apply (lexical x _) (lexical x _))))))
(define one (const 1))) (apply (lexical x _) (lexical x _))))
(pass-if-peval (pass-if-peval
;; First order, aliased primitive. ;; First order, aliased primitive.
@ -759,8 +829,7 @@
(lambda (_) (lambda (_)
(lambda-case (lambda-case
(((x) #f #f #f () (_)) (((x) #f #f #f () (_))
(letrec* (bar) (_) ((lambda (_) . _)) (apply (primitive +) (lexical x _) (const 9)))))))
(apply (primitive +) (lexical x _) (const 9))))))))
(pass-if-peval (pass-if-peval
;; First order, with lambda inlined & specialized twice. ;; First order, with lambda inlined & specialized twice.
@ -770,55 +839,40 @@
(y 3)) (y 3))
(+ (* x (f x y)) (+ (* x (f x y))
(f something x))) (f something x)))
(let (f) (_) ((lambda (_) (apply (primitive +)
(lambda-case (apply (primitive *)
(((x y) #f #f #f () (_ _)) (const 2)
(apply (primitive +) (apply (primitive +) ; (f 2 3)
(apply (primitive *) (apply (primitive *)
(lexical x _) (const 2)
(toplevel top)) (toplevel top))
(lexical y _)))))) (const 3)))
(apply (primitive +) (let (x) (_) ((toplevel something)) ; (f something 2)
(apply (primitive *) ;; `something' is not const, so preserve order of
(const 2) ;; effects with a lexical binding.
(apply (primitive +) ; (f 2 3) (apply (primitive +)
(apply (primitive *) (apply (primitive *)
(const 2) (lexical x _)
(toplevel top)) (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)
(const 2))))) (const 2)))))
(pass-if-peval (pass-if-peval
;; First order, with lambda inlined & specialized 3 times. ;; First order, with lambda inlined & specialized 3 times.
(let ((f (lambda (x y) (if (> x 0) y x)))) (let ((f (lambda (x y) (if (> x 0) y x))))
(+ (f -1 0) (+ (f -1 0)
(f 1 0) (f 1 0)
(f -1 y) (f -1 y)
(f 2 y) (f 2 y)
(f z y))) (f z y)))
(let (f) (_) (apply (primitive +)
((lambda (_) (const -1) ; (f -1 0)
(lambda-case (const 0) ; (f 1 0)
(((x y) #f #f #f () (_ _)) (begin (toplevel y) (const -1)) ; (f -1 y)
(if (apply (primitive >) (lexical x _) (const 0)) (toplevel y) ; (f 2 y)
(lexical y _) (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
(lexical x _)))))) (if (apply (primitive >) (lexical x _) (const 0))
(apply (primitive +) (lexical y _)
(const -1) ; (f -1 0) (lexical x _)))))
(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)))))
(pass-if-peval (pass-if-peval
;; First order, conditional. ;; First order, conditional.
@ -839,8 +893,8 @@
n n
(+ (fibo (- n 1)) (+ (fibo (- n 1))
(fibo (- n 2))))))) (fibo (- n 2)))))))
(fibo 7)) (fibo 4))
(const 13)) (const 3))
(pass-if-peval (pass-if-peval
;; Don't propagate toplevel references, as intervening expressions ;; Don't propagate toplevel references, as intervening expressions
@ -884,25 +938,15 @@
(pass-if-peval (pass-if-peval
;; Higher order. ;; Higher order.
((lambda (f) (f x)) (lambda (x) x)) ((lambda (f) (f x)) (lambda (x) x))
(apply (lambda () (toplevel x))
(lambda-case
(((x) #f #f #f () (_))
(lexical x _))))
(toplevel x)))
(pass-if-peval (pass-if-peval
;; Bug reported at ;; Bug reported at
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>. ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
(let ((fold (lambda (f g) (f (g top))))) (let ((fold (lambda (f g) (f (g top)))))
(fold 1+ (lambda (x) x))) (fold 1+ (lambda (x) x)))
(let (fold) (_) (_) (apply (primitive 1+) (toplevel top)))
(apply (primitive 1+)
(apply (lambda ()
(lambda-case
(((x) #f #f #f () (_))
(lexical x _))))
(toplevel top)))))
(pass-if-peval (pass-if-peval
;; Procedure not inlined when residual code contains recursive calls. ;; Procedure not inlined when residual code contains recursive calls.
;; <http://debbugs.gnu.org/9542> ;; <http://debbugs.gnu.org/9542>
@ -940,20 +984,19 @@
(lambda (x) (lambda (y) (+ x y))))) (lambda (x) (lambda (y) (+ x y)))))
(cons (make-adder 1) (make-adder 2))) (cons (make-adder 1) (make-adder 2)))
#:to 'tree-il))) #:to 'tree-il)))
((let (make-adder) (_) (_) ((apply (primitive cons)
(apply (primitive cons) (lambda ()
(lambda () (lambda-case
(lambda-case (((y) #f #f #f () (,gensym1))
(((y) #f #f #f () (,gensym1)) (apply (primitive +)
(apply (primitive +) (const 1)
(const 1) (lexical y ,ref1)))))
(lexical y ,ref1))))) (lambda ()
(lambda () (lambda-case
(lambda-case (((y) #f #f #f () (,gensym2))
(((y) #f #f #f () (,gensym2)) (apply (primitive +)
(apply (primitive +) (const 2)
(const 2) (lexical y ,ref2))))))
(lexical y ,ref2)))))))
(and (eq? gensym1 ref1) (and (eq? gensym1 ref1)
(eq? gensym2 ref2) (eq? gensym2 ref2)
(not (eq? gensym1 gensym2)))) (not (eq? gensym1 gensym2))))
@ -1018,40 +1061,27 @@
(vector 1 2 3) (vector 1 2 3)
(make-list 10) (make-list 10)
(list 1 2 3)) (list 1 2 3))
(apply (lambda () (let (x y z) (_ _ _)
(lambda-case ((apply (primitive vector) (const 1) (const 2) (const 3))
(((x y z) #f #f #f () (_ _ _)) (apply (toplevel make-list) (const 10))
(begin (apply (primitive list) (const 1) (const 2) (const 3)))
(apply (toplevel vector-set!) (begin
(lexical x _) (const 0) (const 0)) (apply (toplevel vector-set!)
(apply (toplevel set-car!) (lexical x _) (const 0) (const 0))
(lexical y _) (const 0)) (apply (toplevel set-car!)
(apply (toplevel set-cdr!) (lexical y _) (const 0))
(lexical z _) (const ())))))) (apply (toplevel set-cdr!)
(apply (primitive vector) (const 1) (const 2) (const 3)) (lexical z _) (const ())))))
(apply (toplevel make-list) (const 10))
(apply (primitive list) (const 1) (const 2) (const 3))))
(pass-if-peval (pass-if-peval
;; Procedure only called with dynamic args is not inlined.
(let ((foo top-foo) (bar top-bar)) (let ((foo top-foo) (bar top-bar))
(let* ((g (lambda (x y) (+ x y))) (let* ((g (lambda (x y) (+ x y)))
(f (lambda (g x) (g x x)))) (f (lambda (g x) (g x x))))
(+ (f g foo) (f g bar)))) (+ (f g foo) (f g bar))))
(let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar)) (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
(let (g) (_) (apply (primitive +)
((lambda _ ; g (apply (primitive +) (lexical foo _) (lexical foo _))
(lambda-case (apply (primitive +) (lexical bar _) (lexical bar _)))))
(((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 _)))))))
(pass-if-peval (pass-if-peval
;; Fresh objects are not turned into constants. ;; Fresh objects are not turned into constants.
@ -1060,9 +1090,8 @@
(y (cons 0 x))) (y (cons 0 x)))
y) y)
(let (x) (_) ((apply (primitive list) (const 1) (const 2) (const 3))) (let (x) (_) ((apply (primitive list) (const 1) (const 2) (const 3)))
(let (y) (_) ((apply (primitive cons) (const 0) (lexical x _))) (apply (primitive cons) (const 0) (lexical x _))))
(lexical y _))))
(pass-if-peval (pass-if-peval
;; Bindings mutated. ;; Bindings mutated.
(let ((x 2)) (let ((x 2))
@ -1081,10 +1110,10 @@
x))) x)))
(frob f) ; may mutate `x' (frob f) ; may mutate `x'
x) x)
(letrec (x f) (_ _) ((const 0) _) (letrec (x) (_) ((const 0))
(begin (begin
(apply (toplevel frob) (lexical f _)) (apply (toplevel frob) (lambda _ _))
(lexical x _)))) (lexical x _))))
(pass-if-peval (pass-if-peval
;; Bindings mutated. ;; Bindings mutated.
@ -1130,11 +1159,14 @@
(pass-if-peval (pass-if-peval
;; Inlining aborted when residual code contains recursive calls. ;; Inlining aborted when residual code contains recursive calls.
;;
;; <http://debbugs.gnu.org/9542> ;; <http://debbugs.gnu.org/9542>
(let loop ((x x) (y 0)) (let loop ((x x) (y 0))
(if (> y 0) (if (> y 0)
(loop (1+ x) (1+ y)) (loop (1- x) (1- y))
(if (< x 0) x (loop (1- x))))) (if (< x 0)
x
(loop (1+ x) (1+ y)))))
(letrec (loop) (_) ((lambda (_) (letrec (loop) (_) ((lambda (_)
(lambda-case (lambda-case
(((x y) #f #f #f () (_ _)) (((x y) #f #f #f () (_ _))