mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +02:00
Code Activity

peval: Abort inlining when the residual code contains recursive calls.

Browse source 
* module/language/tree-il/optimize.scm (code-contains-calls?): New
  procedure.
  (peval): Use it and abort inlining if the residual code of a procedure
  application contains recursive calls.  Suggested by Wingo, Waddell,
  and Dybvig.  Fixes <http://debbugs.gnu.org/9542>.

* test-suite/tests/tree-il.test ("partial evaluation"): Update 2 tests
  that relied on the previous behavior.  Add 1 another test.
This commit is contained in:
Ludovic Courtès 2011-09-18 23:01:51 +02:00
parent 239b4b2ac6
commit 72b2ca55f6
2 changed files with 70 additions and 50 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -105,6 +105,34 @@ references to the new symbols."
(($ <sequence> src exps) (($ <sequence> src exps)
(make-sequence src (map (cut loop <> mapping) exps)))))) (make-sequence src (map (cut loop <> mapping) exps))))))
(define (code-contains-calls? body proc lookup)
"Return true if BODY contains calls to PROC. Use LOOKUP to look up
lexical references."
(define exit
;; The exit label.
(gensym))
(catch exit
(lambda ()
(tree-il-fold (lambda (exp result) result)
(lambda (exp result)
(match exp
(($ <application> _
(and ref ($ <lexical-ref> _ _ gensym)) _)
(and (or (equal? ref proc)
(equal? (lookup gensym) proc))
(throw exit #t)))
(($ <application>
(and proc* ($ <lambda>)))
(and (equal? proc* proc)
(throw exit #t)))
(_ #f)))
(lambda (exp result) result)
#f
body))
(lambda (_ result)
result)))
(define* (peval exp #:optional (cenv (current-module)) (env vlist-null)) (define* (peval exp #:optional (cenv (current-module)) (env vlist-null))
"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
@ -369,14 +397,21 @@ it does not handle <fix> and <let-values>, it should be called before
(nopt (if opt (length opt) 0))) (nopt (if opt (length opt) 0)))
(if (and (>= nargs nreq) (<= nargs (+ nreq nopt)) (if (and (>= nargs nreq) (<= nargs (+ nreq nopt))
(every pure-expression? args)) (every pure-expression? args))
(loop body (let* ((params
(fold vhash-consq env gensyms (append args
(append args (drop inits
(drop inits (max 0
(max 0 (- nargs
(- nargs (+ nreq nopt))))))
(+ nreq nopt)))))) (body
(cons (cons proc args) calls)) (loop body
(fold vhash-consq env gensyms params)
(cons (cons proc args) calls))))
;; If the residual code contains recursive
;; calls, give up inlining.
(if (code-contains-calls? body proc lookup)
app
body))
app))) app)))
(($ <lambda>) (($ <lambda>)
app) app)

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

@ -829,48 +829,27 @@
(toplevel top))))) (toplevel top)))))
(pass-if-peval (pass-if-peval
;; In this example, the two anonymous lambdas are inlined more than ;; Procedure not inlined when residual code contains recursive calls.
;; once; thus, they should use different gensyms for their ;; <http://debbugs.gnu.org/9542>
;; arguments, because the variable allocation process assumes
;; globally unique gensyms. This test in itself doesn't check that;
;; we rely on the next one to catch any error.
;;
;; Bug reported at
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
(letrec ((fold (lambda (f x3 b null? car cdr) (letrec ((fold (lambda (f x3 b null? car cdr)
(if (null? x3) (if (null? x3)
b b
(f (car x3) (fold f (cdr x3) b null? car cdr)))))) (f (car x3) (fold f (cdr x3) b null? car cdr))))))
(fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1)))) (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
(letrec (fold) (_) (_) (letrec (fold) (_) (_)
(if (apply (primitive zero?) (toplevel x)) (apply (lexical fold _)
(const 1) (primitive *)
(apply (primitive *) ; f (toplevel x)
(apply (lambda () ; car (const 1)
(lambda-case (primitive zero?)
(((x1) #f #f #f () (_)) (lambda ()
(lexical x1 _)))) (lambda-case
(toplevel x)) (((x1) #f #f #f () (_))
(apply (lexical fold _) ; fold (lexical x1 _))))
(primitive *) (lambda ()
(apply (lambda () ; cdr (lambda-case
(lambda-case (((x2) #f #f #f () (_))
(((x2) #f #f #f () (_)) (apply (primitive -) (lexical x2 _) (const 1))))))))
(apply (primitive -)
(lexical x2 _) (const 1)))))
(toplevel x))
(const 1)
(primitive zero?)
(lambda () ; car
(lambda-case
(((x1) #f #f #f () (_))
(lexical x1 _))))
(lambda () ; cdr
(lambda-case
(((x2) #f #f #f () (_))
(apply (primitive -)
(lexical x2 _) (const 1))))))))))
(pass-if "inlined lambdas are alpha-renamed" (pass-if "inlined lambdas are alpha-renamed"
;; In this example, the two anonymous lambdas are inlined more than ;; In this example, the two anonymous lambdas are inlined more than
@ -1077,7 +1056,17 @@
(apply (lexical loop _) (toplevel x)))) (apply (lexical loop _) (toplevel x))))
(pass-if-peval (pass-if-peval
;; Inlining stops at recursive calls (mixed static/dynamic arguments). ;; Recursion on the 2nd argument is fully evaluated.
(let loop ((x x) (y 10))
(if (> y 0)
(loop x (1- y))
(foo x y)))
(letrec (loop) (_) (_)
(apply (toplevel foo) (toplevel x) (const 0))))
(pass-if-peval
;; Inlining aborted when residual code contains recursive calls.
;; <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))
@ -1088,11 +1077,7 @@
(if (apply (primitive >) (if (apply (primitive >)
(lexical y _) (const 0)) (lexical y _) (const 0))
_ _))))) _ _)))))
;; call to (loop x 0) is inlined & specialized (apply (lexical loop _) (toplevel x) (const 0))))
(if (apply (primitive <) (toplevel x) (const 0))
(toplevel x)
(apply (lexical loop _)
(apply (primitive 1-) (toplevel x))))))
(pass-if-peval (pass-if-peval
;; Infinite recursion: `peval' gives up and leaves it as is. ;; Infinite recursion: `peval' gives up and leaves it as is.