[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-126-g880e794
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-126-g880e794 |
|
Date: |
Wed, 09 Nov 2011 18:38:54 +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=880e7948126e594d64cbf45c75a66ad3308ce1b3
The branch, master has been updated
via 880e7948126e594d64cbf45c75a66ad3308ce1b3 (commit)
from 2f4aae6bce7986ad724b374d1a72a6d4c48b462c (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 880e7948126e594d64cbf45c75a66ad3308ce1b3
Author: Andy Wingo <address@hidden>
Date: Wed Nov 9 19:36:10 2011 +0100
inline dynwind guards for normal control flow
* module/language/tree-il.scm (<tree-il>): Add `pre' and `post' fields
to <dynwind>, so that we can inline the guard bodies in the normal
control-flow case. It also avoids duplicating code in compile-glil,
which probably hides more bugs in 2.0.
(parse-tree-il, unparse-tree-il, tree-il->scheme, tree-il-fold)
(make-tree-il-folder, post-order!, pre-order!): Update.
* module/language/tree-il/analyze.scm (analyze-lexicals): Update.
* module/language/tree-il/compile-glil.scm (flatten-lambda-case): Update
to use `pre' and `post' instead of compiling code twice.
* module/language/tree-il/debug.scm (verify-tree-il): Update.
* module/language/tree-il/peval.scm (peval): Update. Instead of doing
complicated things in <dynwind>, handle 'dynamic-wind primcalls.
* module/language/tree-il/primitives.scm (*primitive-expand-table*):
Remove 'dynamic-wind mess. Adapt '@dynamic-wind.
* test-suite/tests/tree-il.test ("partial evaluation"): Update tests.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/compiler.texi | 13 +++--
module/language/tree-il.scm | 48 +++++++++++------
module/language/tree-il/analyze.scm | 12 +++--
module/language/tree-il/compile-glil.scm | 14 +++---
module/language/tree-il/debug.scm | 4 +-
module/language/tree-il/peval.scm | 85 +++++++++++++++++-------------
module/language/tree-il/primitives.scm | 21 +-------
test-suite/tests/tree-il.test | 10 +++-
8 files changed, 115 insertions(+), 92 deletions(-)
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index 7f60ac6..3d6dbf3 100644
--- a/doc/ref/compiler.texi
+++ b/doc/ref/compiler.texi
@@ -473,12 +473,15 @@ expression evaluating to a fluid.
A dynamic variable set. @var{fluid}, a Tree-IL expression evaluating
to a fluid, will be set to the result of evaluating @var{exp}.
@end deftp
address@hidden {Scheme Variable} <dynwind> winder body unwinder
address@hidden {External Representation} (dynwind @var{winder} @var{body}
@var{unwinder})
address@hidden {Scheme Variable} <dynwind> winder pre body post unwinder
address@hidden {External Representation} (dynwind @var{winder} @var{pre}
@var{body} @var{post} @var{unwinder})
A @code{dynamic-wind}. @var{winder} and @var{unwinder} should both
-evaluate to thunks. Ensure that the winder and the unwinder are called
-before entering and after leaving @var{body}. Note that @var{body} is
-an expression, without a thunk wrapper.
+evaluate to thunks. Ensure that the winder and the unwinder are called
+before entering and after leaving @var{body}. Note that @var{body} is
+an expression, without a thunk wrapper. Guile actually inlines the
+bodies of @var{winder} and @var{unwinder} for the case of normal control
+flow, compiling the expressions in @var{pre} and @var{post},
+respectively.
@end deftp
@deftp {Scheme Variable} <prompt> tag body handler
@deftpx {External Representation} (prompt @var{tag} @var{body} @var{handler})
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1723525..69af8d6 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -46,7 +46,7 @@
<letrec> letrec? make-letrec letrec-src letrec-in-order?
letrec-names letrec-gensyms letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src
let-values-exp let-values-body
- <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder
dynwind-body dynwind-unwinder
+ <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder
dynwind-pre dynwind-body dynwind-post dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals
dynlet-body
<dynref> dynref? make-dynref dynref-src dynref-fluid
<dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
@@ -133,7 +133,7 @@
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
(<let-values> exp body)
- (<dynwind> winder body unwinder)
+ (<dynwind> winder pre body post unwinder)
(<dynref> fluid)
(<dynset> fluid exp)
(<prompt> tag body handler)
@@ -246,8 +246,10 @@
((let-values ,exp ,body)
(make-let-values loc (retrans exp) (retrans body)))
- ((dynwind ,winder ,body ,unwinder)
- (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
+ ((dynwind ,winder ,pre ,body ,post ,unwinder)
+ (make-dynwind loc (retrans winder) (retrans pre)
+ (retrans body)
+ (retrans post) (retrans unwinder)))
((dynlet ,fluids ,vals ,body)
(make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
@@ -332,9 +334,10 @@
((<let-values> exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
- ((<dynwind> winder body unwinder)
- `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
- ,(unparse-tree-il unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il pre)
+ ,(unparse-tree-il body)
+ ,(unparse-tree-il post) ,(unparse-tree-il unwinder)))
((<dynlet> fluids vals body)
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
@@ -484,7 +487,7 @@
`(call-with-values (lambda () ,(tree-il->scheme exp))
,(tree-il->scheme (make-lambda #f '() body))))
- ((<dynwind> body winder unwinder)
+ ((<dynwind> winder body unwinder)
`(dynamic-wind ,(tree-il->scheme winder)
(lambda () ,(tree-il->scheme body))
,(tree-il->scheme unwinder)))
@@ -566,10 +569,13 @@ This is an implementation of `foldts' as described by
Andy Wingo in
(down tree result)))))
((<let-values> exp body)
(up tree (loop body (loop exp (down tree result)))))
- ((<dynwind> body winder unwinder)
+ ((<dynwind> winder pre body post unwinder)
(up tree (loop unwinder
- (loop winder
- (loop body (down tree result))))))
+ (loop post
+ (loop body
+ (loop pre
+ (loop winder
+ (down tree result))))))))
((<dynlet> fluids vals body)
(up tree (loop body
(loop vals
@@ -640,9 +646,11 @@ This is an implementation of `foldts' as described by Andy
Wingo in
((<let-values> exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
- ((<dynwind> body winder unwinder)
- (let*-values (((seed ...) (foldts body seed ...))
- ((seed ...) (foldts winder seed ...)))
+ ((<dynwind> winder pre body post unwinder)
+ (let*-values (((seed ...) (foldts winder seed ...))
+ ((seed ...) (foldts pre seed ...))
+ ((seed ...) (foldts body seed ...))
+ ((seed ...) (foldts post seed ...)))
(foldts unwinder seed ...)))
((<dynlet> fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
@@ -721,9 +729,11 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
+ ((<dynwind> winder pre body post unwinder)
(set! (dynwind-winder x) (lp winder))
+ (set! (dynwind-pre x) (lp pre))
+ (set! (dynwind-body x) (lp body))
+ (set! (dynwind-post x) (lp post))
(set! (dynwind-unwinder x) (lp unwinder)))
((<dynlet> fluids vals body)
@@ -808,9 +818,11 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
+ ((<dynwind> winder pre body post unwinder)
(set! (dynwind-winder x) (lp winder))
+ (set! (dynwind-pre x) (lp pre))
+ (set! (dynwind-body x) (lp body))
+ (set! (dynwind-post x) (lp post))
(set! (dynwind-unwinder x) (lp unwinder)))
((<dynlet> fluids vals body)
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 868a302..d6502a6 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -336,8 +336,10 @@
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
- ((<dynwind> body winder unwinder)
- (lset-union eq? (step body) (step winder) (step unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ (lset-union eq? (step winder) (step pre)
+ (step body)
+ (step post) (step unwinder)))
((<dynlet> fluids vals body)
(apply lset-union eq? (step body) (map step (append fluids vals))))
@@ -509,8 +511,10 @@
((<let-values> exp body)
(max (recur exp) (recur body)))
- ((<dynwind> body winder unwinder)
- (max (recur body) (recur winder) (recur unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ (max (recur winder) (recur pre)
+ (recur body)
+ (recur post) (recur unwinder)))
((<dynlet> fluids vals body)
(apply max (recur body) (map recur (append fluids vals))))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 239309f..28c31f3 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -899,10 +899,10 @@
;; to have body's return value(s) on the stack while the unwinder runs,
;; then proceed with returning or dropping or what-have-you, interacting
;; with RA and MVRA. What have you, I say.
- ((<dynwind> src body winder unwinder)
+ ((<dynwind> src winder pre body post unwinder)
(comp-push winder)
(comp-push unwinder)
- (comp-drop (make-call src winder '()))
+ (comp-drop pre)
(emit-code #f (make-glil-call 'wind 2))
(case context
@@ -911,14 +911,14 @@
(comp-vals body MV)
;; one value: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-call src unwinder '()))
+ (comp-drop post)
;; ...and return the val
(emit-code #f (make-glil-call 'return 1))
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-call src unwinder '()))
+ (comp-drop post)
;; and return the values.
(emit-code #f (make-glil-call 'return/nvalues 1))))
@@ -927,7 +927,7 @@
(comp-push body)
;; and unwind, leaving the val on the stack
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-call src unwinder '())))
+ (comp-drop post))
((vals)
(let ((MV (make-label)))
@@ -938,7 +938,7 @@
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-call src unwinder '()))
+ (comp-drop post)
;; and goto the MVRA.
(emit-branch #f 'br MVRA)))
@@ -946,7 +946,7 @@
;; compile body, discarding values. then unwind...
(comp-drop body)
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-call src unwinder '()))
+ (comp-drop post)
;; and fall through, or goto RA if there is one.
(if RA
(emit-branch #f 'br RA)))))
diff --git a/module/language/tree-il/debug.scm
b/module/language/tree-il/debug.scm
index 884f3de..a32fc41 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -215,9 +215,11 @@
(for-each (cut visit <> env) fluids)
(for-each (cut visit <> env) vals)
(visit body env))))
- (($ <dynwind> src winder body unwinder)
+ (($ <dynwind> src winder pre body post unwinder)
(visit winder env)
+ (visit pre env)
(visit body env)
+ (visit post env)
(visit unwinder env))
(($ <dynref> src fluid)
(visit fluid env))
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 634f257..8586571 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -510,10 +510,10 @@ top-level bindings from ENV and return the resulting
expression."
(make-let-values src exp
(make-lambda-case src2 req opt rest kw
inits gensyms body #f)))))
- (($ <dynwind> src winder body unwinder)
+ (($ <dynwind> src winder pre body post unwinder)
(let ((body (loop body)))
(and body
- (make-dynwind src winder body unwinder))))
+ (make-dynwind src winder pre body post unwinder))))
(($ <dynlet> src fluids vals body)
(let ((body (loop body)))
(and body
@@ -863,40 +863,10 @@ top-level bindings from ENV and return the resulting
expression."
(else #f)))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <dynwind> src winder body unwinder)
- (let ((pre (for-value winder))
- (body (for-tail body))
- (post (for-value unwinder)))
- (cond
- ((not (constant-expression? pre))
- (cond
- ((not (constant-expression? post))
- (let ((pre-sym (gensym "pre ")) (post-sym (gensym "post ")))
- (record-new-temporary! 'pre pre-sym 1)
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(pre post) (list pre-sym post-sym) (list pre
post)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (let ((pre-sym (gensym "pre ")))
- (record-new-temporary! 'pre pre-sym 1)
- (make-let src '(pre) (list pre-sym) (list pre)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- post))))))
- ((not (constant-expression? post))
- (let ((post-sym (gensym "post ")))
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(post) (list post-sym) (list post)
- (make-dynwind src
- pre
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (make-dynwind src pre body post)))))
+ (($ <dynwind> src winder pre body post unwinder)
+ (make-dynwind src (for-value winder) (for-effect pre)
+ (for-tail body)
+ (for-effect post) (for-value unwinder)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map for-value fluids) (map for-value vals)
(for-tail body)))
@@ -950,6 +920,49 @@ top-level bindings from ENV and return the resulting
expression."
(for-tail (make-let-values src (make-call src producer '())
consumer)))
+ (($ <primcall> src 'dynamic-wind (w thunk u))
+ (for-tail
+ (cond
+ ((not (constant-expression? w))
+ (cond
+ ((not (constant-expression? u))
+ (let ((w-sym (gensym "w ")) (u-sym (gensym "u ")))
+ (record-new-temporary! 'w w-sym 2)
+ (record-new-temporary! 'u u-sym 2)
+ (make-let src '(w u) (list w-sym u-sym) (list w u)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'w w-sym)
+ (make-call #f (make-lexical-ref #f 'w w-sym) '())
+ (make-call #f thunk '())
+ (make-call #f (make-lexical-ref #f 'u u-sym) '())
+ (make-lexical-ref #f 'u u-sym)))))
+ (else
+ (let ((w-sym (gensym "w ")))
+ (record-new-temporary! 'w w-sym 2)
+ (make-let src '(w) (list w-sym) (list w)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'w w-sym)
+ (make-call #f (make-lexical-ref #f 'w w-sym) '())
+ (make-call #f thunk '())
+ (make-call #f u '())
+ u))))))
+ ((not (constant-expression? u))
+ (let ((u-sym (gensym "u ")))
+ (record-new-temporary! 'u u-sym 2)
+ (make-let src '(u) (list u-sym) (list u)
+ (make-dynwind
+ src
+ w
+ (make-call #f w '())
+ (make-call #f thunk '())
+ (make-call #f (make-lexical-ref #f 'u u-sym) '())
+ (make-lexical-ref #f 'u u-sym)))))
+ (else
+ (make-dynwind src w (make-call #f w '()) (make-call #f thunk '())
+ (make-call #f u '()) u)))))
+
(($ <primcall> src (? constructor-primitive? name) args)
(cond
((and (memq ctx '(effect test))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 20e0421..8e9d2eb 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -484,25 +484,6 @@
(bytevector-ieee-double-native-set! vec (* i 8) x))
(hashq-set! *primitive-expand-table*
- 'dynamic-wind
- (case-lambda
- ((src pre thunk post)
- (let ((PRE (gensym " pre"))
- (THUNK (gensym " thunk"))
- (POST (gensym " post")))
- (make-let
- src
- '(pre thunk post)
- (list PRE THUNK POST)
- (list pre thunk post)
- (make-dynwind
- src
- (make-lexical-ref #f 'pre PRE)
- (make-call #f (make-lexical-ref #f 'thunk THUNK) '())
- (make-lexical-ref #f 'post POST)))))
- (else #f)))
-
-(hashq-set! *primitive-expand-table*
'@dynamic-wind
(case-lambda
((src pre expr post)
@@ -516,7 +497,9 @@
(make-dynwind
src
(make-lexical-ref #f 'pre PRE)
+ (make-call #f (make-lexical-ref #f 'pre PRE) '())
expr
+ (make-call #f (make-lexical-ref #f 'post POST) '())
(make-lexical-ref #f 'post POST)))))))
(hashq-set! *primitive-expand-table*
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 5bab593..6733f74 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1464,8 +1464,12 @@
(pass-if-peval
;; Non-constant guards get lexical bindings.
(dynamic-wind foo (lambda () bar) baz)
- (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
- (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
+ (let (w u) (_ _) ((toplevel foo) (toplevel baz))
+ (dynwind (lexical w _)
+ (call (lexical w _))
+ (toplevel bar)
+ (call (lexical u _))
+ (lexical u _))))
(pass-if-peval
;; Constant guards don't need lexical bindings.
@@ -1474,7 +1478,9 @@
(lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel foo))))
+ (toplevel foo)
(toplevel bar)
+ (toplevel baz)
(lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel baz))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-126-g880e794,
Andy Wingo <=