[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-78-g870dfc
From: |
Ludovic Courtès |
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-78-g870dfc6 |
Date: |
Sat, 10 Sep 2011 22:50:30 +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=870dfc609b0bf090d38878d7224e65843c355485
The branch, stable-2.0 has been updated
via 870dfc609b0bf090d38878d7224e65843c355485 (commit)
via 89436781e8758ee4df98f5d720f3ade50c2439fa (commit)
via d5f76917820a00ea94f9904c3fd1dcef1c37bd95 (commit)
from fe1336405062c69ff08fd7ad0d98c3f2aca7766f (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 870dfc609b0bf090d38878d7224e65843c355485
Author: Ludovic Courtès <address@hidden>
Date: Sun Sep 11 00:41:23 2011 +0200
peval: Propagate only pure expressions to lambdas.
* 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.
commit 89436781e8758ee4df98f5d720f3ade50c2439fa
Author: Ludovic Courtès <address@hidden>
Date: Sun Sep 11 00:00:39 2011 +0200
peval: Try hard to preserve mutability.
* module/language/tree-il/optimize.scm (peval)[make-values]: Distinguish
between 1 or another number of values.
[mutable?, make-value-construction, maybe-unconst]: New procedures.
Use it in <let>, <letrec>, <toplevel-define>, and <lambda-case>.
* test-suite/tests/tree-il.test ("partial evaluation"): Add tests
for mutability preservation.
commit d5f76917820a00ea94f9904c3fd1dcef1c37bd95
Author: Ludovic Courtès <address@hidden>
Date: Sat Sep 10 15:31:55 2011 +0200
doc: Fix typo regarding vhashes.
* doc/ref/api-compound.texi (VHashes): s/vlist-/alist-/.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-compound.texi | 2 +-
module/language/tree-il/optimize.scm | 102 ++++++++++++++++++++++++++--------
test-suite/tests/tree-il.test | 99 +++++++++++++++++++++++++++++++++
3 files changed, 178 insertions(+), 25 deletions(-)
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index da8813b..c52fed4 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -3207,7 +3207,7 @@ key is typically a constant-time operation.
The VHash programming interface of @code{(ice-9 vlist)} is mostly the same as
that of association lists found in SRFI-1, with procedure names prefixed by
address@hidden instead of @code{vlist-} (@pxref{SRFI-1 Association Lists}).
address@hidden instead of @code{alist-} (@pxref{SRFI-1 Association Lists}).
In addition, vhashes can be manipulated using VList operations:
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
index 35b1aec..15b8ec0 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -88,8 +88,11 @@ it should be called before `fix-letrec'."
(values #f '()))))
(define (make-values src values)
- (make-application src (make-primitive-ref src 'values)
- (map (cut make-const src <>) values)))
+ (match values
+ ((single) single) ; 1 value
+ ((_ ...) ; 0, or 2 or more values
+ (make-application src (make-primitive-ref src 'values)
+ values))))
(define (const*? x)
(or (const? x) (lambda? x) (void? x)))
@@ -124,6 +127,53 @@ it should be called before `fix-letrec'."
(and (every loop vals) (loop body)))
(_ #f))))
+ (define (mutable? exp)
+ ;; Return #t if EXP is a mutable object.
+ ;; todo: add an option to assume pairs are immutable
+ (or (pair? exp)
+ (vector? exp)
+ (struct? exp)
+ (string? exp)))
+
+ (define (make-value-construction src exp)
+ ;; Return an expression that builds a fresh copy of EXP at run-time,
+ ;; or #f.
+ (let loop ((exp exp))
+ (match exp
+ ((_ _ ...) ; non-empty proper list
+ (let ((args (map loop exp)))
+ (and (every struct? args)
+ (make-application src (make-primitive-ref src 'list)
+ args))))
+ ((h . (? (negate pair?) t)) ; simple pair
+ (let ((h (loop h))
+ (t (loop t)))
+ (and h t
+ (make-application src (make-primitive-ref src 'cons)
+ (list h t)))))
+ ((? vector?) ; vector
+ (let ((args (map loop (vector->list exp))))
+ (and (every struct? args)
+ (make-application src (make-primitive-ref src 'vector)
+ args))))
+ ((? number?) (make-const src exp))
+ ((? string?) (make-const src exp))
+ ((? symbol?) (make-const src exp))
+ ;((? bytevector?) (make-const src exp))
+ (_ #f))))
+
+ (define (maybe-unconst orig new)
+ ;; If NEW is a constant, change it to a non-constant if need be.
+ ;; Expressions that build a mutable object, such as `(list 1 2)',
+ ;; must not be replaced by a constant; this procedure "undoes" the
+ ;; change from `(list 1 2)' to `'(1 2)'.
+ (match new
+ (($ <const> src (? mutable? value))
+ (if (equal? new orig)
+ new
+ (or (make-value-construction src value) orig)))
+ (_ new)))
+
(catch 'match-error
(lambda ()
(let loop ((exp exp)
@@ -142,11 +192,13 @@ it should be called before `fix-letrec'."
(let ((val (lookup gensym)))
(or (and (pure-expression? val) val) exp)))
(($ <let> src names gensyms vals body)
- (let* ((vals (map (cut loop <> env calls) vals))
- (body (loop body
- (fold vhash-consq env gensyms vals)
- calls)))
- (if (const? body)
+ (let* ((vals* (map (cut loop <> env calls) vals))
+ (vals (map maybe-unconst vals vals*))
+ (body* (loop body
+ (fold vhash-consq env gensyms vals)
+ calls))
+ (body (maybe-unconst body body*)))
+ (if (const? body*)
body
(let*-values (((stripped) (remove (compose const? car)
(zip vals gensyms names)))
@@ -158,11 +210,13 @@ it should be called before `fix-letrec'."
;; 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 (cut loop <> env calls) vals))
- (body (loop body
+ (let* ((vals* (map (cut loop <> env calls) vals))
+ (vals (map maybe-unconst vals vals*))
+ (body* (loop body
(fold vhash-consq env gensyms vals)
- calls)))
- (if (const? body)
+ calls))
+ (body (maybe-unconst body body*)))
+ (if (const? body*)
body
(make-letrec src in-order? names gensyms vals body))))
(($ <toplevel-ref> src (? effect-free-primitive? name))
@@ -177,7 +231,8 @@ it should be called before `fix-letrec'."
(($ <module-ref>)
exp)
(($ <toplevel-define> src name exp)
- (make-toplevel-define src name (loop exp env '())))
+ (make-toplevel-define src name
+ (maybe-unconst exp (loop exp env '()))))
(($ <primitive-ref>)
exp)
(($ <conditional> src condition subsequent alternate)
@@ -190,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.)
@@ -207,11 +263,8 @@ it should be called before `fix-letrec'."
(apply-primitive name
(map const-exp args))))
(if success?
- (match values
- ((value)
- (make-const src value))
- (_
- (make-values src values)))
+ (make-values src (map (cut make-const src <>)
+ values))
app))
app))
(($ <primitive-ref>)
@@ -224,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
@@ -247,14 +301,14 @@ 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)
(make-lambda src meta (loop body env calls)))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
(make-lambda-case src req opt rest kw inits gensyms
- (loop body env calls)
+ (maybe-unconst body (loop body env calls))
alt))
(($ <sequence> src exps)
(let ((exps (map (cut loop <> env calls) exps)))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index ab42215..cffd3ac 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -614,6 +614,50 @@
(const 3))
(pass-if-peval
+ ;; First order, coalesced.
+ (cons 0 (cons 1 (cons 2 (list 3 4 5))))
+ (const (0 1 2 3 4 5)))
+
+ (pass-if-peval
+ ;; First order, coalesced, mutability preserved.
+ (define mutable
+ (cons 0 (cons 1 (cons 2 (list 3 4 5)))))
+ (define mutable
+ ;; This must not be a constant.
+ (apply (primitive list)
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))))
+
+ (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)))))
+
+ (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.
+ (define one
+ (let loop ((i 7)
+ (r '()))
+ (if (<= i 0)
+ (car r)
+ (loop (1- i) (cons i r)))))
+ (define one (const 1)))
+
+ (pass-if-peval
;; First order, aliased primitive.
(let* ((x *) (y (x 1 2))) y)
(const 2))
@@ -783,6 +827,18 @@
(lexical v _) (lexical n _) (lexical n _)))))))
(pass-if-peval
+ ;; Mutable lexical is not propagated.
+ (let ((v (vector 1 2 3)))
+ (lambda ()
+ v))
+ (let (v) (_)
+ ((apply (primitive vector) (const 1) (const 2) (const 3)))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ())
+ (lexical v _))))))
+
+ (pass-if-peval
;; Lexical that is not provably pure is not inlined nor propagated.
(let* ((x (if (> p q) (frob!) (display 'chbouib)))
(y (* x 2)))
@@ -795,6 +851,29 @@
(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)))
(f (lambda (g x) (g x x))))
@@ -814,6 +893,16 @@
(apply (lexical g _) (toplevel bar) (toplevel bar))))))
(pass-if-peval
+ ;; Fresh objects are not turned into constants.
+ (let* ((c '(2 3))
+ (x (cons 1 c))
+ (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 _))))
+
+ (pass-if-peval
;; Bindings mutated.
(let ((x 2))
(set! x 3)
@@ -845,6 +934,16 @@
(letrec _ . _))
(pass-if-peval
+ ;; Bindings possibly mutated.
+ (let ((x (make-foo)))
+ (frob! x) ; may mutate `x'
+ x)
+ (let (x) (_) ((apply (toplevel make-foo)))
+ (begin
+ (apply (toplevel frob!) (lexical x _))
+ (lexical x _))))
+
+ (pass-if-peval
;; Infinite recursion: `peval' gives up and leaves it as is.
(letrec ((f (lambda (x) (g (1- x))))
(g (lambda (x) (h (1+ x))))
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-78-g870dfc6,
Ludovic Courtès <=