mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

peval: Propagate only pure expressions to lambdas.

Browse source 
* module/language/tree-il/optimize.scm (peval): Propagate ARGS to BODY
  only when all of ARGS are pure.  Change APP to use `maybe-unconst' for
  its arguments.

* test-suite/tests/tree-il.test ("partial evaluation"): Add tests for
  mutability preservation and non-propagation of non-constant arguments
  to lambdas.
This commit is contained in:
Ludovic Courtès 2011-09-11 00:41:23 +02:00
parent 89436781e8
commit 870dfc609b
2 changed files with 37 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -245,11 +245,12 @@ it should be called before `fix-letrec'."
(make-conditional src condition
(loop subsequent env calls)
(loop alternate env calls)))))
(($ <application> src proc* args*)
(($ <application> src proc* orig-args)
;; todo: augment the global env with specialized functions
(let* ((proc (loop proc* env calls))
(args (map (cut loop <> env calls) args*))
(app (make-application src proc args)))
(let* ((proc (loop proc* env calls))
(args (map (cut loop <> env calls) orig-args))
(args* (map maybe-unconst orig-args args))
(app (make-application src proc args*)))
;; If ARGS are constants and this call hasn't already been
;; expanded before (to avoid infinite recursion), then
;; expand it (todo: emit an infinite recursion warning.)
@ -276,7 +277,8 @@ it should be called before `fix-letrec'."
(let ((nargs (length args))
(nreq (length req))
(nopt (if opt (length opt) 0)))
(if (and (>= nargs nreq) (<= nargs (+ nreq nopt)))
(if (and (>= nargs nreq) (<= nargs (+ nreq nopt))
(every pure-expression? args))
(loop body
(fold vhash-consq env gensyms
(append args
@ -299,7 +301,7 @@ it should be called before `fix-letrec'."
(if (lambda? evaled)
raw
evaled))
args*
orig-args
args)))
(make-application src proc args)))))
(($ <lambda> src meta body)

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

@ -640,11 +640,12 @@
(apply (primitive cons) (const 2) (const 2))
(apply (primitive cons) (const 3) (const 3)))))
;; FIXME: The test below fails.
;; (pass-if-peval
;; ;; Mutability preserved.
;; ((lambda (x y z) (list x y z)) 1 2 3)
;; (apply (primitive list) (const 1) (const 2) (const 3)))
(pass-if-peval
;; Mutability preserved.
(define mutable
((lambda (x y z) (list x y z)) 1 2 3))
(define mutable
(apply (primitive list) (const 1) (const 2) (const 3))))
(pass-if-peval
;; First order, evaluated.
@ -849,6 +850,29 @@
(apply (primitive +) (lexical x _) (lexical x _)
(apply (primitive *) (lexical x _) (const 2))))))
(pass-if-peval
;; Non-constant arguments not propagated to lambdas.
((lambda (x y z)
(vector-set! x 0 0)
(set-car! y 0)
(set-cdr! z '()))
(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))))
(pass-if-peval
;; Procedure only called with non-constant args is not inlined.
(let* ((g (lambda (x y) (+ x y)))