[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-88-g72b2ca
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-88-g72b2ca5 |
|
Date: |
Sun, 18 Sep 2011 21:02:21 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=72b2ca55f6e115927aa4e76401c992f21198681f
The branch, stable-2.0 has been updated
via 72b2ca55f6e115927aa4e76401c992f21198681f (commit)
via 239b4b2ac6fda615e117193076df0b6b2bccb5d7 (commit)
from 1e2b4920cac71e6750673a84642db97c404092a7 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 72b2ca55f6e115927aa4e76401c992f21198681f
Author: Ludovic Courtès <address@hidden>
Date: Sun Sep 18 23:01:51 2011 +0200
peval: Abort inlining when the residual code contains recursive calls.
* 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.
commit 239b4b2ac6fda615e117193076df0b6b2bccb5d7
Author: Ludovic Courtès <address@hidden>
Date: Sun Sep 18 22:34:40 2011 +0200
peval: Improve alpha-renaming test.
* test-suite/tests/tree-il.test ("partial evaluation")["inlined lambdas
are alpha-renamed"]: Rewrite.
-----------------------------------------------------------------------
Summary of changes:
module/language/tree-il/optimize.scm | 51 ++++++++++++--
test-suite/tests/tree-il.test | 126 +++++++++++++++++++--------------
2 files changed, 115 insertions(+), 62 deletions(-)
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
index 5e95ca1..19ef54d 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -105,6 +105,34 @@ references to the new symbols."
(($ <sequence> src 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))
"Partially evaluate EXP in compilation environment CENV, with
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)))
(if (and (>= nargs nreq) (<= nargs (+ nreq nopt))
(every pure-expression? args))
- (loop body
- (fold vhash-consq env gensyms
- (append args
- (drop inits
- (max 0
- (- nargs
- (+ nreq nopt))))))
- (cons (cons proc args) calls))
+ (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))))
+ ;; If the residual code contains recursive
+ ;; calls, give up inlining.
+ (if (code-contains-calls? body proc lookup)
+ app
+ body))
app)))
(($ <lambda>)
app)
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 156a435..63b74ad 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -829,62 +829,74 @@
(toplevel top)))))
(pass-if-peval
- ;; In this example, the two anonymous lambdas are inlined more than
- ;; once; thus, they should use different gensyms for their
- ;; 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>.
+ ;; Procedure not inlined when residual code contains recursive calls.
+ ;; <http://debbugs.gnu.org/9542>
(letrec ((fold (lambda (f x3 b null? car cdr)
(if (null? x3)
b
(f (car x3) (fold f (cdr x3) b null? car cdr))))))
(fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
(letrec (fold) (_) (_)
- (if (apply (primitive zero?) (toplevel x))
- (const 1)
- (apply (primitive *) ; f
- (apply (lambda () ; car
- (lambda-case
- (((x1) #f #f #f () (_))
- (lexical x1 _))))
- (toplevel x))
- (apply (lexical fold _) ; fold
- (primitive *)
- (apply (lambda () ; cdr
- (lambda-case
- (((x2) #f #f #f () (_))
- (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))))))))))
+ (apply (lexical fold _)
+ (primitive *)
+ (toplevel x)
+ (const 1)
+ (primitive zero?)
+ (lambda ()
+ (lambda-case
+ (((x1) #f #f #f () (_))
+ (lexical x1 _))))
+ (lambda ()
+ (lambda-case
+ (((x2) #f #f #f () (_))
+ (apply (primitive -) (lexical x2 _) (const 1))))))))
(pass-if "inlined lambdas are alpha-renamed"
- ;; This one should compile without errors; see above for an
- ;; explanation.
- (and (compile
- '(letrec ((fold (lambda (f x3 b null? car cdr)
- (if (null? x3)
- b
- (f (car x3)
- (fold f (cdr x3) b null? car cdr))))))
- (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
- #:opts '(#:partial-eval? #t)
- #:to 'glil)
- #t))
+ ;; In this example, the two anonymous lambdas are inlined more than
+ ;; once; thus, they should use different gensyms for their
+ ;; arguments, because the variable allocation process assumes
+ ;; globally unique gensyms.
+ ;;
+ ;; 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>.
+ (pmatch (unparse-tree-il
+ (peval (compile
+ '(let ((f (lambda (g x)
+ (+ (g x) (g (+ x 1))))))
+ (f (lambda (x0) (* x0 x0)) y))
+ #:to 'tree-il)))
+ ((let (f) (_)
+ ((lambda ((name . f))
+ (lambda-case
+ (((g x) #f #f #f () (_ _))
+ (apply (primitive +)
+ (apply (lexical g _) (lexical x _))
+ (apply (lexical g _)
+ (apply (primitive +)
+ (lexical x _) (const 1))))))))
+ (apply (primitive +)
+ (apply (lambda ()
+ (lambda-case
+ (((x0) #f #f #f () (,gensym1))
+ (apply (primitive *)
+ (lexical x0 ,ref1a)
+ (lexical x0 ,ref1b)))))
+ (toplevel y))
+ (apply (lambda ()
+ (lambda-case
+ (((x0) #f #f #f () (,gensym2))
+ (apply (primitive *)
+ (lexical x0 ,ref2a)
+ (lexical x0 ,ref2b)))))
+ (apply (primitive +)
+ (toplevel y) (const 1)))))
+ (and (eq? gensym1 ref1a)
+ (eq? gensym1 ref1b)
+ (eq? gensym2 ref2a)
+ (eq? gensym2 ref2b)
+ (not (eq? gensym1 gensym2))))
+ (_ #f)))
(pass-if-peval
;; Higher order, mutually recursive procedures.
@@ -1044,7 +1056,17 @@
(apply (lexical loop _) (toplevel x))))
(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))
(if (> y 0)
(loop (1+ x) (1+ y))
@@ -1055,11 +1077,7 @@
(if (apply (primitive >)
(lexical y _) (const 0))
_ _)))))
- ;; call to (loop x 0) is inlined & specialized
- (if (apply (primitive <) (toplevel x) (const 0))
- (toplevel x)
- (apply (lexical loop _)
- (apply (primitive 1-) (toplevel x))))))
+ (apply (lexical loop _) (toplevel x) (const 0))))
(pass-if-peval
;; Infinite recursion: `peval' gives up and leaves it as is.
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-88-g72b2ca5,
Ludovic Courtès <=