diff options
-rw-r--r-- | doc/ref/compiler.texi | 13 | ||||
-rw-r--r-- | module/language/tree-il.scm | 48 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 12 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 14 | ||||
-rw-r--r-- | module/language/tree-il/debug.scm | 4 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 85 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 21 | ||||
-rw-r--r-- | 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 7f60ac67c..3d6dbf327 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 -@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}) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 1723525f1..69af8d65a 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 868a30249..d6502a65f 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 239309f6c..28c31f387 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 884f3de9a..a32fc4153 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 634f257c5..85865717c 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 20e04212c..8e9d2eb6e 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 5bab593f6..6733f74ec 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)))))) |