[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-110-g8d065
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-110-g8d06538 |
|
Date: |
Sat, 24 Sep 2011 15:34:39 +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=8d06538e821c3e6cdd4861e1d8b1ec25ed930453
The branch, stable-2.0 has been updated
via 8d06538e821c3e6cdd4861e1d8b1ec25ed930453 (commit)
via e535a37db891323708d375ad9c9c6f2b407261f1 (commit)
via 8f6dfb9ad226eb1b017cc08fda8b03350c9a209a (commit)
via 250991010f08d6a9e16dabad32941c948a8b4ba4 (commit)
via 9e8a5b6637c71b909a0c3ca42e6756d0b2177a05 (commit)
via dd7ab5d8a44a34112b3992a711db2851f503ce00 (commit)
via c829531a4652b2cf4d4aac1eb0af08c3231bdecf (commit)
from a4c7fe5cde907f3bc4cbc5190bfc7e748d6bac45 (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 8d06538e821c3e6cdd4861e1d8b1ec25ed930453
Author: Andy Wingo <address@hidden>
Date: Thu Sep 22 12:06:21 2011 +0200
context-specific folding for peval in test and effect contexts
* module/language/tree-il/optimize.scm (peval): Add a "test" context,
which folds statically decidable values to <const>. Fold pure
expressions to <void> in "effect" contexts. Adapt the <conditional>
and <sequence> tests to simply look for <const> or <void> expressions,
respectively.
commit e535a37db891323708d375ad9c9c6f2b407261f1
Author: Andy Wingo <address@hidden>
Date: Thu Sep 22 11:23:06 2011 +0200
thread a context through peval
* module/language/tree-il/optimize.scm (peval): Thread a "context"
through the evaluator.
commit 8f6dfb9ad226eb1b017cc08fda8b03350c9a209a
Author: Andy Wingo <address@hidden>
Date: Sat Sep 24 17:05:30 2011 +0200
paper around `match' bug
* module/ice-9/match.scm (match): Always introduce a lexical binding, to
avoid http://debbugs.gnu.org/9567. Real fix ongoing. Patch and
original report by Stefan Israelsson Tampe.
* test-suite/tests/match.test: Add test.
commit 250991010f08d6a9e16dabad32941c948a8b4ba4
Author: Andy Wingo <address@hidden>
Date: Sat Sep 24 17:15:32 2011 +0200
peval: various bugfixes
* module/language/tree-il/optimize.scm (alpha-rename): Rename the
init
expressions of a <lambda-case>.
(peval): Coalesce the <let-values> clauses.
Fix pure-expression? matching of <lambda> clauses.
Loop over and maybe-unconst the inits of a <lambda-case>.
commit 9e8a5b6637c71b909a0c3ca42e6756d0b2177a05
Author: Andy Wingo <address@hidden>
Date: Thu Sep 22 14:14:02 2011 +0200
tree-il-any bugfix
* module/language/tree-il/optimize.scm (tree-il-any): Fix to be called
on all values, including leaves. It didn't matter for the use case,
though.
commit dd7ab5d8a44a34112b3992a711db2851f503ce00
Author: Andy Wingo <address@hidden>
Date: Thu Sep 22 12:26:02 2011 +0200
minor peval style tweak
* module/language/tree-il/optimize.scm (peval): Minor refactor to
<lexical-ref> copy propagation.
commit c829531a4652b2cf4d4aac1eb0af08c3231bdecf
Author: Andy Wingo <address@hidden>
Date: Thu Sep 22 17:43:36 2011 +0200
fix alpha-rename for kwargs
* module/language/tree-il/optimize.scm (alpha-rename): Fix
alpha-renaming of keyword arguments.
-----------------------------------------------------------------------
Summary of changes:
module/ice-9/match.scm | 18 +++
module/language/tree-il/optimize.scm | 212 ++++++++++++++++++++++------------
test-suite/tests/match.test | 12 ++
3 files changed, 167 insertions(+), 75 deletions(-)
diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm
index 686539b..0384f69 100644
--- a/module/ice-9/match.scm
+++ b/module/ice-9/match.scm
@@ -57,3 +57,21 @@
;; Note: Make sure to update `match.test.upstream' when updating this
;; file.
(include-from-path "ice-9/match.upstream.scm")
+
+(define-syntax match
+ (syntax-rules ()
+ ((match)
+ (match-syntax-error "missing match expression"))
+ ((match atom)
+ (match-syntax-error "no match clauses"))
+ ((match (app ...) (pat . body) ...)
+ (let ((v (app ...)))
+ (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
+ ((match #(vec ...) (pat . body) ...)
+ (let ((v #(vec ...)))
+ (match-next v (v (set! v)) (pat . body) ...)))
+ ((match atom (pat . body) ...)
+ (let ((v atom))
+ (match-next v (atom (set! atom)) (pat . body) ...)))
+ ))
+
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
index 0cc51a0..8d626ea 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -65,9 +65,20 @@ references to the new symbols."
(append req
(or opt '())
(if rest (list rest) '())
- (if kw (map cadr (cdr kw)) '()))))
+ (match kw
+ ((aok? (_ name _) ...) name)
+ (_ '())))))
(mapping (fold vhash-consq mapping gensyms new)))
- (make-lambda-case src req opt rest kw inits new
+ (make-lambda-case src req opt rest
+ (match kw
+ ((aok? (kw name old) ...)
+ (cons aok? (map list
+ kw
+ name
+ (take-right new (length old)))))
+ (_ #f))
+ (map (cut loop <> mapping) inits)
+ new
(loop body mapping)
(and alt (loop alt mapping)))))
(($ <lexical-ref> src name gensym)
@@ -151,7 +162,9 @@ references to the new symbols."
(define (tree-il-any proc exp)
(let/ec k
- (tree-il-fold (lambda (exp res) #f)
+ (tree-il-fold (lambda (exp res)
+ (let ((res (proc exp)))
+ (if res (k res) #f)))
(lambda (exp res)
(let ((res (proc exp)))
(if res (k res) #f)))
@@ -327,7 +340,7 @@ it does not handle <fix> and <let-values>, it should be
called before
(and (effect-free-primitive? name)
(not (constructor-primitive? name))
(every loop args)))
- (($ <application> _ ($ <lambda> _ body) args)
+ (($ <application> _ ($ <lambda> _ _ body) args)
(and (loop body) (every loop args)))
(($ <sequence> _ exps)
(every loop exps))
@@ -414,29 +427,46 @@ it does not handle <fix> and <let-values>, it should be
called before
(lambda ()
(let loop ((exp exp)
(env vlist-null) ; static environment
- (calls '())) ; inlined call stack
+ (calls '()) ; inlined call stack
+ (ctx 'value)) ; effect, value, test, or call
(define (lookup var)
(and=> (vhash-assq var env) cdr))
(match exp
(($ <const>)
- exp)
+ (case ctx
+ ((effect) (make-void #f))
+ (else exp)))
(($ <void>)
- exp)
+ (case ctx
+ ((test) (make-const #f #t))
+ (else exp)))
(($ <lexical-ref> _ _ gensym)
- ;; Propagate only pure expressions.
- (let ((val (lookup gensym)))
- (or (and (pure-expression? val) val) exp)))
+ ;; Propagate only pure expressions that are not assigned to.
+ (case ctx
+ ((effect) (make-void #f))
+ (else
+ (let ((val (lookup gensym)))
+ (if (pure-expression? val)
+ (case ctx
+ ;; fixme: cache this? it is a divergence from
+ ;; O(n).
+ ((test) (loop val env calls 'test))
+ (else val))
+ exp)))))
;; Lexical set! causes a bailout.
(($ <let> src names gensyms vals body)
- (let* ((vals* (map (cut loop <> env calls) vals))
+ (let* ((vals* (map (cut loop <> env calls 'value) vals))
(vals (map maybe-unconst vals vals*))
(body* (loop body
(fold vhash-consq env gensyms vals)
- calls))
+ calls
+ ctx))
(body (maybe-unconst body body*)))
(if (const? body*)
body
+ ;; Constants have already been propagated, so there is
+ ;; no need to bind them to lexicals.
(let*-values (((stripped) (remove (compose const? car)
(zip vals gensyms names)))
((vals gensyms names) (unzip3 stripped)))
@@ -447,52 +477,55 @@ it does not handle <fix> and <let-values>, it should be
called before
;; 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))
+ (let* ((vals* (map (cut loop <> env calls 'value) vals))
(vals (map maybe-unconst vals vals*))
(body* (loop body
(fold vhash-consq env gensyms vals)
- calls))
+ calls
+ ctx))
(body (maybe-unconst body body*)))
(if (const? body*)
body
(make-letrec src in-order? names gensyms vals body))))
(($ <fix> src names gensyms vals body)
- (let* ((vals (map (cut loop <> env calls) vals))
+ (let* ((vals (map (cut loop <> env calls 'value) vals))
(body* (loop body
- (fold vhash-consq env gensyms vals)
- calls))
+ (fold vhash-consq env gensyms vals)
+ calls
+ ctx))
(body (maybe-unconst body body*)))
(if (const? body*)
body
(make-fix src names gensyms vals body))))
- (($ <let-values> lv-src producer
- ($ <lambda-case> src req #f #f #f () gensyms body #f))
- ;; Peval both producer and consumer, then try to inline. If
- ;; that succeeds, peval again.
- (let* ((producer (maybe-unconst producer (loop producer env calls)))
- (body (maybe-unconst body (loop body env calls))))
- (cond
- ((inline-values producer src req gensyms body)
- => (lambda (exp) (loop exp env calls)))
- (else
- (make-let-values lv-src producer
- (make-lambda-case src req #f #f #f '()
- gensyms body #f))))))
- (($ <let-values>)
- exp)
+ (($ <let-values> lv-src producer consumer)
+ ;; Peval the producer, then try to inline the consumer into
+ ;; the producer. If that succeeds, peval again. Otherwise
+ ;; reconstruct the let-values, pevaling the consumer.
+ (let ((producer (maybe-unconst producer
+ (loop producer env calls 'value))))
+ (or (match consumer
+ (($ <lambda-case> src req #f #f #f () gensyms body #f)
+ (cond
+ ((inline-values producer src req gensyms body)
+ => (cut loop <> env calls ctx))
+ (else #f)))
+ (_ #f))
+ (make-let-values lv-src producer
+ (loop consumer env calls ctx)))))
(($ <dynwind> src winder body unwinder)
- (make-dynwind src (loop winder env calls)
- (loop body env calls)
- (loop unwinder env calls)))
+ (make-dynwind src (loop winder env calls 'value)
+ (loop body env calls ctx)
+ (loop unwinder env calls 'value)))
(($ <dynlet> src fluids vals body)
(make-dynlet src
(map maybe-unconst fluids
- (map (cut loop <> env calls) fluids))
+ (map (cut loop <> env calls 'value) fluids))
(map maybe-unconst vals
- (map (cut loop <> env calls) vals))
- (maybe-unconst body (loop body env calls))))
+ (map (cut loop <> env calls 'value) vals))
+ (maybe-unconst body (loop body env calls ctx))))
(($ <dynref> src fluid)
- (make-dynref src (maybe-unconst fluid (loop fluid env calls))))
+ (make-dynref src
+ (maybe-unconst fluid (loop fluid env calls 'value))))
(($ <toplevel-ref> src (? effect-free-primitive? name))
(if (local-toplevel? name)
exp
@@ -504,42 +537,44 @@ it does not handle <fix> and <let-values>, it should be
called before
exp)
(($ <module-set> src mod name public? exp)
(make-module-set src mod name public?
- (maybe-unconst exp (loop exp env '()))))
+ (maybe-unconst exp (loop exp env '() 'value))))
(($ <toplevel-define> src name exp)
(make-toplevel-define src name
- (maybe-unconst exp (loop exp env '()))))
+ (maybe-unconst exp (loop exp env '()
'value))))
(($ <toplevel-set> src name exp)
(make-toplevel-set src name
- (maybe-unconst exp (loop exp env '()))))
+ (maybe-unconst exp (loop exp env '() 'value))))
(($ <primitive-ref>)
- exp)
+ (case ctx
+ ((effect) (make-void #f))
+ ((test) (make-const #f #t))
+ (else exp)))
(($ <conditional> src condition subsequent alternate)
- (let ((condition (loop condition env calls)))
- (if (const*? condition)
- (if (or (lambda? condition) (void? condition)
- (const-exp condition))
- (loop subsequent env calls)
- (loop alternate env calls))
+ (let ((condition (loop condition env calls 'test)))
+ (if (const? condition)
+ (if (const-exp condition)
+ (loop subsequent env calls ctx)
+ (loop alternate env calls ctx))
(make-conditional src condition
- (loop subsequent env calls)
- (loop alternate env calls)))))
+ (loop subsequent env calls ctx)
+ (loop alternate env calls ctx)))))
(($ <application> src
- ($ <primitive-ref> _ '@call-with-values)
- (producer
- ($ <lambda> _ _
- (and consumer
- ;; No optional or kwargs.
- ($ <lambda-case>
- _ req #f rest #f () gensyms body #f)))))
+ ($ <primitive-ref> _ '@call-with-values)
+ (producer
+ ($ <lambda> _ _
+ (and consumer
+ ;; No optional or kwargs.
+ ($ <lambda-case>
+ _ req #f rest #f () gensyms body #f)))))
(loop (make-let-values src (make-application src producer '())
consumer)
- env calls))
+ env calls ctx))
(($ <application> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
- (let* ((proc (loop orig-proc env calls))
+ (let* ((proc (loop orig-proc env calls 'call))
(proc* (maybe-unlambda orig-proc proc env))
- (args (map (cut loop <> env calls) orig-args))
+ (args (map (cut loop <> env calls 'value) orig-args))
(args* (map (cut maybe-unlambda <> <> env)
orig-args
(map maybe-unconst orig-args args)))
@@ -557,8 +592,17 @@ it does not handle <fix> and <let-values>, it should be
called before
(apply-primitive name
(map const-exp args))))
(if success?
- (make-values src (map (cut make-const src <>)
- values))
+ (case ctx
+ ((effect) (make-void #f))
+ ((test)
+ ;; Values truncation: only take the first
+ ;; value.
+ (if (pair? values)
+ (make-const #f (car values))
+ (make-values src '())))
+ (else
+ (make-values src (map (cut make-const src <>)
+ values))))
app))
app))
(($ <primitive-ref>)
@@ -582,7 +626,8 @@ it does not handle <fix> and <let-values>, it should be
called before
(body
(loop body
(fold vhash-consq env gensyms params)
- (cons (cons proc args) calls))))
+ (cons (cons proc args) calls)
+ ctx)))
;; If the residual code contains recursive
;; calls, give up inlining.
(if (code-contains-calls? body proc lookup)
@@ -602,20 +647,37 @@ it does not handle <fix> and <let-values>, it should be
called before
app)))
(($ <lambda> src meta body)
- (make-lambda src meta (loop body env calls)))
+ (case ctx
+ ((effect) (make-void #f))
+ ((test) (make-const #f #t))
+ (else
+ (make-lambda src meta (loop body env calls 'value)))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
- (make-lambda-case src req opt rest kw inits gensyms
- (maybe-unconst body (loop body env calls))
+ (make-lambda-case src req opt rest kw
+ (map maybe-unconst inits
+ (map (cut loop <> env calls 'value) inits))
+ gensyms
+ (maybe-unconst body (loop body env calls ctx))
alt))
(($ <sequence> src exps)
- (let ((exps (map (cut loop <> env calls) exps)))
- (if (every pure-expression? exps)
- (last exps)
- (match (reverse exps)
- ;; Remove all expressions but the last one.
- ((keep rest ...)
- (let ((rest (remove pure-expression? rest)))
- (make-sequence src (reverse (cons keep rest))))))))))))
+ (let lp ((exps exps) (effects '()))
+ (match exps
+ ((last)
+ (if (null? effects)
+ (loop last env calls ctx)
+ (make-sequence src (append (reverse effects)
+ (list
+ (maybe-unconst last
+ (loop last env
calls ctx)))))))
+ ((head . rest)
+ (let ((head (loop head env calls 'effect)))
+ (cond
+ ((sequence? head)
+ (lp (append (sequence-exps head) rest) effects))
+ ((void? head)
+ (lp rest effects))
+ (else
+ (lp rest (cons head effects))))))))))))
(lambda _
;; We encountered something we don't handle, like `<lexical-set>',
;; <abort>, or some other effecting construct, so bail out.
diff --git a/test-suite/tests/match.test b/test-suite/tests/match.test
index 93358fc..8b19ff7 100644
--- a/test-suite/tests/match.test
+++ b/test-suite/tests/match.test
@@ -102,6 +102,18 @@
(('one ('two x) ('three y ('and z '(and 5))))
(equal? (list x y z) '(2 3 4))))))
+ (pass-if "and, unique names"
+ (let ((tree '(1 2)))
+ (match tree
+ ((and (a 2) (1 b))
+ (equal? 3 (+ a b))))))
+
+ (pass-if "and, same names"
+ (let ((a '(1 2)))
+ (match a
+ ((and (a 2) (1 b))
+ (equal? 3 (+ a b))))))
+
(with-test-prefix "records"
(pass-if "all slots, bind"
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-110-g8d06538,
Andy Wingo <=