mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

peval: don't propagate expressions that access memory

Browse source 
* module/language/tree-il/optimize.scm (peval): Rename
  `pure-expression?' to `constant-expression?', in the sense of GCC's
  `pure' and `const'.  A <toplevel-ref> is not constant, because it can
  be mutated.  A <dynref> isn't constant either, for the same reason.

* test-suite/tests/tree-il.test ("partial evaluation"): Add a test, and
  update existing tests that assumed that toplevel-ref would propagate.
This commit is contained in:
Andy Wingo 2011-09-24 18:57:59 +02:00
parent 8d06538e82
commit 1eb4886ffa
2 changed files with 83 additions and 74 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -318,11 +318,10 @@ it does not handle <fix> and <let-values>, it should be called before
(define (const*? x) (define (const*? x)
(or (const? x) (lambda? x) (void? x))) (or (const? x) (lambda? x) (void? x)))
(define (pure-expression? x) (define (constant-expression? x)
;; Return true if X is pure---i.e., if it is known to have no ;; Return true if X is constant---i.e., if it is known to have no
;; effects and does not allocate storage for a mutable object. ;; effects, does not allocate storage for a mutable object, and does
;; Note: <module-ref> is not "pure" because it loads a module as a ;; not access mutable data (like `car' or toplevel references).
;; side-effect.
(let loop ((x x)) (let loop ((x x))
(match x (match x
(($ <void>) #t) (($ <void>) #t)
@ -331,9 +330,7 @@ it does not handle <fix> and <let-values>, it should be called before
(($ <lambda-case> _ req opt rest kw inits _ body alternate) (($ <lambda-case> _ req opt rest kw inits _ body alternate)
(and (every loop inits) (loop body) (loop alternate))) (and (every loop inits) (loop body) (loop alternate)))
(($ <lexical-ref>) #t) (($ <lexical-ref>) #t)
(($ <toplevel-ref>) #t)
(($ <primitive-ref>) #t) (($ <primitive-ref>) #t)
(($ <dynref> _ fluid) (loop fluid))
(($ <conditional> _ condition subsequent alternate) (($ <conditional> _ condition subsequent alternate)
(and (loop condition) (loop subsequent) (loop alternate))) (and (loop condition) (loop subsequent) (loop alternate)))
(($ <application> _ ($ <primitive-ref> _ name) args) (($ <application> _ ($ <primitive-ref> _ name) args)
@ -447,7 +444,7 @@ it does not handle <fix> and <let-values>, it should be called before
((effect) (make-void #f)) ((effect) (make-void #f))
(else (else
(let ((val (lookup gensym))) (let ((val (lookup gensym)))
(if (pure-expression? val) (if (constant-expression? val)
(case ctx (case ctx
;; fixme: cache this? it is a divergence from ;; fixme: cache this? it is a divergence from
;; O(n). ;; O(n).
@ -616,7 +613,7 @@ it does not handle <fix> and <let-values>, it should be called before
(nreq (length req)) (nreq (length req))
(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 constant-expression? args))
(let* ((params (let* ((params
(append args (append args
(drop inits (drop inits

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

@ -776,16 +776,23 @@
(const 2) (const 2)
(toplevel top)) (toplevel top))
(const 3))) (const 3)))
(apply (primitive +) ; (f something 2) (apply (lexical f _) ; (f something 2)
(apply (primitive *) ;; This arg is not const, so the lambda does not
(toplevel something) ;; fold. We will fix this in the future when we
(toplevel top)) ;; 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 x) (f 2 y) (f z y))) (+ (f -1 0)
(f 1 0)
(f -1 y)
(f 2 y)
(f z y)))
(let (f) (_) (let (f) (_)
((lambda (_) ((lambda (_)
(lambda-case (lambda-case
@ -794,8 +801,12 @@
(lexical y _) (lexical y _)
(lexical x _)))))) (lexical x _))))))
(apply (primitive +) (apply (primitive +)
(const -1) ; (f -1 x) (const -1) ; (f -1 0)
(toplevel y) ; (f 2 y) (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) (apply (lexical f _) ; (f z y)
(toplevel z) (toplevel y))))) (toplevel z) (toplevel y)))))
@ -821,6 +832,17 @@
(fibo 7)) (fibo 7))
(const 13)) (const 13))
(pass-if-peval
;; Don't propagate toplevel references, as intervening expressions
;; could alter their bindings.
(let ((x top))
(foo)
x)
(let (x) (_) ((toplevel top))
(begin
(apply (toplevel foo))
(lexical x _))))
(pass-if-peval (pass-if-peval
;; Higher order. ;; Higher order.
((lambda (f x) ((lambda (f x)
@ -895,49 +917,35 @@
(apply (primitive -) (lexical x2 _) (const 1)))))))) (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, `make-adder' is inlined more than once; thus,
;; once; thus, they should use different gensyms for their ;; they should use different gensyms for their arguments, because
;; arguments, because the variable allocation process assumes ;; the various optimization passes assume uniquely-named variables.
;; globally unique gensyms.
;; ;;
;; Bug reported at ;; 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/msg00019.html> and
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>. ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
(pmatch (unparse-tree-il (pmatch (unparse-tree-il
(peval (compile (peval (compile
'(let ((f (lambda (g x) '(let ((make-adder
(+ (g x) (g (+ x 1)))))) (lambda (x) (lambda (y) (+ x y)))))
(f (lambda (x0) (* x0 x0)) y)) (cons (make-adder 1) (make-adder 2)))
#:to 'tree-il))) #:to 'tree-il)))
((let (f) (_) ((let (make-adder) (_) (_)
((lambda ((name . f)) (apply (primitive cons)
(lambda-case (lambda ()
(((g x) #f #f #f () (_ _)) (lambda-case
(apply (primitive +) (((y) #f #f #f () (,gensym1))
(apply (lexical g _) (lexical x _)) (apply (primitive +)
(apply (lexical g _) (const 1)
(apply (primitive +) (lexical y ,ref1)))))
(lexical x _) (const 1)))))))) (lambda ()
(apply (primitive +) (lambda-case
(apply (lambda () (((y) #f #f #f () (,gensym2))
(lambda-case (apply (primitive +)
(((x0) #f #f #f () (,gensym1)) (const 2)
(apply (primitive *) (lexical y ,ref2)))))))
(lexical x0 ,ref1a) (and (eq? gensym1 ref1)
(lexical x0 ,ref1b))))) (eq? gensym2 ref2)
(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)))) (not (eq? gensym1 gensym2))))
(_ #f))) (_ #f)))
@ -1017,22 +1025,24 @@
(pass-if-peval (pass-if-peval
;; Procedure only called with dynamic args is not inlined. ;; Procedure only called with dynamic args is not inlined.
(let* ((g (lambda (x y) (+ x y))) (let ((foo top-foo) (bar top-bar))
(f (lambda (g x) (g x x)))) (let* ((g (lambda (x y) (+ x y)))
(+ (f g foo) (f g bar))) (f (lambda (g x) (g x x))))
(let (g) (_) (+ (f g foo) (f g bar))))
((lambda _ ; g (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
(lambda-case (let (g) (_)
(((x y) #f #f #f () (_ _)) ((lambda _ ; g
(apply (primitive +) (lexical x _) (lexical y _)))))) (lambda-case
(let (f) (_) (((x y) #f #f #f () (_ _))
((lambda _ ; f (apply (primitive +) (lexical x _) (lexical y _))))))
(lambda-case (let (f) (_)
(((g x) #f #f #f () (_ _)) ((lambda _ ; f
(apply (lexical g _) (lexical x _) (lexical x _)))))) (lambda-case
(apply (primitive +) (((g x) #f #f #f () (_ _))
(apply (lexical g _) (toplevel foo) (toplevel foo)) (apply (lexical g _) (lexical x _) (lexical x _))))))
(apply (lexical g _) (toplevel bar) (toplevel bar)))))) (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.
@ -1100,12 +1110,14 @@
(pass-if-peval (pass-if-peval
;; Recursion on the 2nd argument is fully evaluated. ;; Recursion on the 2nd argument is fully evaluated.
(let loop ((x x) (y 10)) (let ((x (top)))
(if (> y 0) (let loop ((x x) (y 10))
(loop x (1- y)) (if (> y 0)
(foo x y))) (loop x (1- y))
(letrec (loop) (_) (_) (foo x y))))
(apply (toplevel foo) (toplevel x) (const 0)))) (let (x) (_) ((apply (toplevel top)))
(letrec (loop) (_) (_)
(apply (toplevel foo) (lexical x _) (const 0)))))
(pass-if-peval (pass-if-peval
;; Inlining aborted when residual code contains recursive calls. ;; Inlining aborted when residual code contains recursive calls.