mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +02:00
Code Activity

inline dynwind guards for normal control flow

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2011-11-09 19:36:10 +01:00
parent 2f4aae6bce
commit 880e794812
8 changed files with 115 additions and 92 deletions
Download patch file Download diff file Expand all files Collapse all files

13
doc/ref/compiler.texi
View file

@ -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
@deftp {Scheme Variable} <dynwind> winder body unwinder
@deftpx {External Representation} (dynwind @var{winder} @var{body} @var{unwinder})
@deftp {Scheme Variable} <dynwind> winder pre body post unwinder
@deftpx {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})

48
module/language/tree-il.scm
View file

@ -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)

12
module/language/tree-il/analyze.scm
View file

@ -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))))

14
module/language/tree-il/compile-glil.scm
View file

@ -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)))))

4
module/language/tree-il/debug.scm
View file

@ -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))

85
module/language/tree-il/peval.scm
View file

@ -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))

21
module/language/tree-il/primitives.scm
View file

@ -483,25 +483,6 @@
(define-primitive-expander f64vector-set! (vec i x)
(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
@ -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*

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

@ -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))))))