(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
- (($ <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)
(let ((len (vlist-length vlist)))
(let lp ((i 0))
(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 <fix> and <let-values>, 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
(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
- (($ <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
(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
(($ <const>)
;; 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))))))))
(($ <lexical-set> src name gensym exp)
(if (zero? (lexical-refcount gensym))
(let ((exp (for-effect exp)))
(maybe-unconst exp
(for-value exp))))))
(($ <let> 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)))))))
(($ <letrec> 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
body
(make-letrec src in-order? 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
(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))))
(($ <let-values> lv-src producer consumer)
(($ <application> 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
- (($ <primitive-ref> _ (? 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))
- (($ <primitive-ref>)
- ;; An effectful primitive.
- app)
- (($ <lambda> _ _
- ($ <lambda-case> _ 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)))
- (($ <lambda>)
- app)
- (($ <toplevel-ref>)
- 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.
- )
-
- app)))
+ (let ((proc (loop orig-proc env counter 'operator)))
+ (match proc
+ (($ <primitive-ref> _ (? 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)))))
+ (($ <lambda> _ _
+ ($ <lambda-case> _ 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 ($ <primitive-ref>)
+ ($ <lambda>)
+ ($ <toplevel-ref>)
+ ($ <lexical-ref>))
+ (make-application src proc
+ (map maybe-unconst orig-args
+ (map for-value orig-args))))
+
+ ;; 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)
(case ctx
((effect) (make-void #f))
((test) (make-const #f #t))
+ ((operator) exp)
(else
(make-lambda src meta (for-value body)))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
(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.
(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.
(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.
(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.
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
(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
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
(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.
;; <http://debbugs.gnu.org/9542>
(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))))
(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.
(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))
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.
(pass-if-peval
;; Inlining aborted when residual code contains recursive calls.
+ ;;
;; <http://debbugs.gnu.org/9542>
(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 () (_ _))
HCoop / bpt / guile.git / commitdiff