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.

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
+@deftp {Scheme Variable} <dynwind> winder pre body post unwinder
-@deftpx {External Representation} (dynwind @var{winder} @var{body} @var{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
+evaluate to thunks.  Ensure that the winder and the unwinder are called
-before entering and after leaving @var{body}. Note that @var{body} is
+before entering and after leaving @var{body}.  Note that @var{body} is
-an expression, without a thunk wrapper.
+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})

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)
+     ((dynwind ,winder ,pre ,body ,post ,unwinder)
-      (make-dynwind loc (retrans winder) (retrans body) (retrans 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> winder pre body post unwinder)
-     `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
+     `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il pre)
-               ,(unparse-tree-il unwinder)))
+               ,(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 post
-                                (loop body (down tree result))))))
+                        (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)
+              ((<dynwind> winder pre body post unwinder)
-               (let*-values (((seed ...) (foldts body seed ...))
+               (let*-values (((seed ...) (foldts winder seed ...))
-                             ((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)
+      ((<dynwind> winder pre body post unwinder)
-       (set! (dynwind-body x) (lp body))
        (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)
+        ((<dynwind> winder pre body post unwinder)
-         (set! (dynwind-body x) (lp body))
          (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)

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)
+      ((<dynwind> winder pre body post unwinder)
-       (lset-union eq? (step body) (step winder) (step 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)
+      ((<dynwind> winder pre body post unwinder)
-       (max (recur body) (recur winder) (recur 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))))

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

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

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)
+      (($ <dynwind> src winder pre body post unwinder)
-       (let ((pre (for-value winder))
+       (make-dynwind src (for-value winder) (for-effect pre)
-             (body (for-tail body))
+                     (for-tail body)
-             (post (for-value unwinder)))
+                     (for-effect 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)))))
       (($ <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))

module/language/tree-il/primitives.scm

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

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))
+   (let (w u) (_ _) ((toplevel foo) (toplevel baz))
-        (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
+        (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))))))