dynamic-wind in terms of wind and unwind; remove <dynwind>, @dynamic-wind

* doc/ref/compiler.texi: Remove mention of <dynwind>.
* libguile/eval.c (eval): Remove SCM_M_DYNWIND case.
* libguile/expand.c: Remove scm_sym_at_dynamic_wind.
* libguile/memoize.c (do_wind, do_unwind): A couple of hacky subrs.  If
  we see a wind or unwind primcall, we expand to a call of a quoted subr
  value.  It works and removes a kind of memoized value from the
  interpreter.  For the compiler,primcalls to wind and unwind are
  handled specially.
  (MAKMEMO_DYNWIND): Remove.
  (scm_tc16_memoizer): Remove.  Yay!
  (memoize): Remove speculative lookup for toplevels to see if they are
  memoizers: there are no more memoizers.  Memoize calls to the wind and
  unwind primitives.
  (m_dynamic_wind): Remove.
  (unmemoize): Remove dynwind case.
  (scm_init_memoize): Add wind and unwind local definitions.

* module/ice-9/boot-9.scm (dynamic-wind): Reimplement in terms of "wind"
  and "unwind" primitives.  These primitives are not exposed to other
  modules.

* module/ice-9/eval.scm (primitive-eval): Remove dynwind case.
* module/language/scheme/decompile-tree-il.scm (do-decompile):
  (choose-output-names): Remove dynwind cases.

* module/language/tree-il.scm: Remove <dynwind>.  Yaaay!

* module/language/tree-il/analyze.scm (analyze-lexicals): Remove dynwind
  cases.

* module/language/tree-il/compile-glil.scm (*primcall-ops*): Add wind
  and unwind.
  (flatten-lambda-case): Remove dynwind case.  Yay!

* module/language/tree-il/cse.scm (cse):
* module/language/tree-il/debug.scm (verify-tree-il):
* module/language/tree-il/effects.scm (make-effects-analyzer):
* module/language/tree-il/peval.scm (singly-valued-expression?, peval):
  Remove <dywind> cases.  Inline primcalls to dynamic-wind.  Add
  constant folding for thunk?.

* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
  Remove @dynamic-wind, and add procedure? and thunk?.
  (*effect+exception-free-primitives*): Add procedure? and thunk?.
  (*multiply-valued-primitives*): Remove @dynamic-wind.
  Remove @dynamic-wind expander.

* test-suite/tests/peval.test ("partial evaluation"): Update tests for
  dynwind desugaring.

doc/ref/compiler.texi

@@ -476,16 +476,6 @@ 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 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.  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})
 A dynamic prompt. Instates a prompt named @var{tag}, an expression,

libguile/eval.c

@@ -265,20 +265,6 @@ eval (SCM x, SCM env)
       scm_define (CAR (mx), EVAL1 (CDR (mx), env));
       return SCM_UNSPECIFIED;
 
-    case SCM_M_DYNWIND:
-      {
-        SCM in, out, res;
-        scm_i_thread *t = SCM_I_CURRENT_THREAD;
-        in = EVAL1 (CAR (mx), env);
-        out = EVAL1 (CDDR (mx), env);
-        scm_call_0 (in);
-        scm_dynstack_push_dynwind (&t->dynstack, in, out);
-        res = eval (CADR (mx), env);
-        scm_dynstack_pop (&t->dynstack);
-        scm_call_0 (out);
-        return res;
-      }
-
     case SCM_M_WITH_FLUIDS:
       {
         long i, len;

libguile/expand.c

@@ -184,7 +184,6 @@ SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
 SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
 SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
 SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
-SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind, "@dynamic-wind");
 SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids");
 SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
 SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");

libguile/memoize.c

@@ -60,6 +60,27 @@ SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
 
 
 
+/* Primitives not exposed to general Scheme. */
+static SCM wind;
+static SCM unwind;
+
+static SCM
+do_wind (SCM in, SCM out)
+{
+  scm_dynstack_push_dynwind (&SCM_I_CURRENT_THREAD->dynstack, in, out);
+  return SCM_UNSPECIFIED;
+}
+
+static SCM
+do_unwind (void)
+{
+  scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
+  return SCM_UNSPECIFIED;
+}
+
+
+
+
 /* {Evaluator memoized expressions}
  */
 
@@ -88,8 +109,6 @@ scm_t_bits scm_tc16_memoized;
   MAKMEMO (SCM_M_QUOTE, exp)
 #define MAKMEMO_DEFINE(var, val) \
   MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
-#define MAKMEMO_DYNWIND(in, expr, out) \
-  MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out)))
 #define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
   MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
 #define MAKMEMO_APPLY(proc, args)\
@@ -116,11 +135,6 @@ scm_t_bits scm_tc16_memoized;
   MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
 
 
-/* Primitives for the evaluator */
-scm_t_bits scm_tc16_memoizer;
-#define SCM_MEMOIZER_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoizer, (x)))
-#define SCM_MEMOIZER(M) (SCM_SMOB_OBJECT_1 (M))
-
 
 
 /* This table must agree with the list of M_ constants in memoize.h */
@@ -132,7 +146,6 @@ static const char *const memoized_tags[] =
   "let",
   "quote",
   "define",
-  "dynwind",
   "with-fluids",
   "apply",
   "call/cc",
@@ -250,18 +263,6 @@ memoize (SCM exp, SCM env)
         proc = REF (exp, CALL, PROC);
         args = memoize_exps (REF (exp, CALL, ARGS), env);
 
-        if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_TOPLEVEL_REF)
-          {
-            SCM var = scm_module_variable (scm_current_module (),
-                                           REF (proc, TOPLEVEL_REF, NAME));
-            if (SCM_VARIABLEP (var))
-              {
-                SCM val = SCM_VARIABLE_REF (var);
-                if (SCM_MEMOIZER_P (val))
-                  return scm_apply (SCM_SMOB_OBJECT_1 (val), args, SCM_EOL);
-              }
-          }
-        /* otherwise we all fall down here */
         return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
       }
 
@@ -291,6 +292,12 @@ memoize (SCM exp, SCM env)
                  && scm_is_eq (name,
                                scm_from_latin1_symbol ("call-with-values")))
           return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
+        else if (nargs == 2
+                 && scm_is_eq (name, scm_from_latin1_symbol ("wind")))
+          return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args);
+        else if (nargs == 0
+                 && scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
+          return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
         else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
           return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
         else
@@ -528,32 +535,6 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
 #undef FUNC_NAME
 
 
-
-
-#define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N)                             \
-  (scm_cell (scm_tc16_memoizer,                                         \
-             SCM_UNPACK (scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
-#define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N)                           \
-SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N)))
-
-static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post);
-
-SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
-
-
-
-
-static SCM m_dynamic_wind (SCM in, SCM expr, SCM out)
-#define FUNC_NAME "memoize-dynwind"
-{
-  SCM_VALIDATE_MEMOIZED (1, in);
-  SCM_VALIDATE_MEMOIZED (2, expr);
-  SCM_VALIDATE_MEMOIZED (3, out);
-  return MAKMEMO_DYNWIND (in, expr, out);
-}
-#undef FUNC_NAME
-
-
 
 
 SCM_SYMBOL (sym_placeholder, "_");
@@ -630,11 +611,6 @@ unmemoize (const SCM expr)
                          unmemoize (CAR (args)), unmemoize (CDR (args)));
     case SCM_M_DEFINE:
       return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
-    case SCM_M_DYNWIND:
-      return scm_list_4 (scm_sym_at_dynamic_wind,
-                         unmemoize (CAR (args)),
-                         unmemoize (CADR (args)),
-                         unmemoize (CDDR (args)));
     case SCM_M_WITH_FLUIDS:
       {
         SCM binds = SCM_EOL, fluids, vals;
@@ -879,10 +855,11 @@ scm_init_memoize ()
   scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
   scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
 
-  scm_tc16_memoizer = scm_make_smob_type ("memoizer", 0);
-
 #include "libguile/memoize.x"
 
+  wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
+  unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
+
   list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
 }
 

libguile/memoize.h

@@ -49,7 +49,6 @@ SCM_API SCM scm_sym_with_fluids;
 SCM_API SCM scm_sym_at;
 SCM_API SCM scm_sym_atat;
 SCM_API SCM scm_sym_delay;
-SCM_API SCM scm_sym_at_dynamic_wind;
 SCM_API SCM scm_sym_eval_when;
 SCM_API SCM scm_sym_arrow;
 SCM_API SCM scm_sym_else;
@@ -74,7 +73,6 @@ enum
     SCM_M_LET,
     SCM_M_QUOTE,
     SCM_M_DEFINE,
-    SCM_M_DYNWIND,
     SCM_M_WITH_FLUIDS,
     SCM_M_APPLY,
     SCM_M_CONT,

module/ice-9/boot-9.scm

@@ -266,7 +266,16 @@ x
 a-cont
 @result{} special-binding
 @end lisp"
-  (@dynamic-wind in (thunk) out))
+  (if (thunk? out)
+      (in)
+      (scm-error 'wrong-type-arg "dynamic-wind" "Not a thunk: ~S"
+                 (list out) #f))
+  ((@@ primitive wind) in out)
+  (call-with-values thunk
+    (lambda vals
+      ((@@ primitive unwind))
+      (out)
+      (apply values vals))))
 
 
 

module/ice-9/eval.scm

@@ -203,7 +203,6 @@
 ;;;       module-ref: 14468
 ;;;           define: 1259
 ;;;     toplevel-set: 328
-;;;          dynwind: 162
 ;;;      with-fluids: 0
 ;;;          call/cc: 0
 ;;;       module-set: 0
@@ -463,11 +462,6 @@
                                                          env))))
           (eval x env)))
       
-        (('dynwind (in exp . out))
-         (dynamic-wind (eval in env)
-                       (lambda () (eval exp env))
-                       (eval out env)))
-        
         (('with-fluids (fluids vals . exp))
          (let* ((fluids (map (lambda (x) (eval x env)) fluids))
                 (vals (map (lambda (x) (eval x env)) vals)))

module/language/scheme/decompile-tree-il.scm

@@ -432,11 +432,6 @@
          `(call-with-values (lambda () ,@(recurse-body exp))
             ,(recurse (make-lambda #f '() body))))
 
-        ((<dynwind> body winder unwinder)
-         `(dynamic-wind ,(recurse winder)
-                        (lambda () ,@(recurse-body body))
-                        ,(recurse unwinder)))
-
         ((<dynlet> fluids vals body)
          `(with-fluids ,(map list
                              (map recurse fluids)
@@ -761,10 +756,6 @@
              (primitive 'call-with-values)
              (recurse exp) (recurse body))
 
-            ((<dynwind> winder body unwinder)
-             (primitive 'dynamic-wind)
-             (recurse winder) (recurse body) (recurse unwinder))
-
             ((<dynlet> fluids vals body)
              (primitive 'with-fluids)
              (for-each recurse fluids)

module/language/tree-il.scm

@@ -46,7 +46,6 @@
             <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
             <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
@@ -136,7 +135,6 @@
 (define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
   (<fix> names gensyms vals body)
   (<let-values> exp body)
-  (<dynwind> winder body unwinder)
   (<dynref> fluid)
   (<dynset> fluid exp)
   (<prompt> tag body handler)
@@ -249,9 +247,6 @@
      (('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)))
-
      (('dynlet fluids vals body)
       (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
 
@@ -339,11 +334,6 @@
     (($ <let-values> src exp body)
      `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
 
-    (($ <dynwind> src winder body unwinder)
-     `(dynwind ,(unparse-tree-il winder)
-               ,(unparse-tree-il body)
-               ,(unparse-tree-il unwinder)))
-
     (($ <dynlet> src fluids vals body)
      `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
               ,(unparse-tree-il body)))
@@ -424,10 +414,6 @@
               (($ <let-values> src exp body)
                (let*-values (((seed ...) (foldts exp seed ...)))
                  (foldts body seed ...)))
-              (($ <dynwind> src winder body unwinder)
-               (let*-values (((seed ...) (foldts winder seed ...))
-                             ((seed ...) (foldts unwinder seed ...)))
-                 (foldts body seed ...)))
               (($ <dynlet> src fluids vals body)
                (let*-values (((seed ...) (fold-values foldts fluids seed ...))
                              ((seed ...) (fold-values foldts vals seed ...)))
@@ -527,9 +513,6 @@ This is an implementation of `foldts' as described by Andy Wingo in
        (($ <let-values> src exp body)
         (make-let-values src (lp exp) (lp body)))
 
-       (($ <dynwind> src winder body unwinder)
-        (make-dynwind src (lp winder) (lp body) (lp unwinder)))
-
        (($ <dynlet> src fluids vals body)
         (make-dynlet src (map lp fluids) (map lp vals) (lp body)))
 

module/language/tree-il/analyze.scm

@@ -337,9 +337,6 @@
       ((<let-values> exp body)
        (lset-union eq? (step exp) (step body)))
       
-      ((<dynwind> winder body unwinder)
-       (lset-union eq? (step winder) (step body) (step unwinder)))
-      
       ((<dynlet> fluids vals body)
        (apply lset-union eq? (step body) (map step (append fluids vals))))
       
@@ -511,9 +508,6 @@
       ((<let-values> exp body)
        (max (recur exp) (recur body)))
       
-      ((<dynwind> winder body unwinder)
-       (max (recur winder) (recur body) (recur unwinder)))
-      
       ((<dynlet> fluids vals body)
        (apply max (recur body) (map recur (append fluids vals))))
       

module/language/tree-il/compile-glil.scm

@@ -135,6 +135,9 @@
    ;; hack for lua
    (return/values . return/values)
 
+   ((wind . 2) . wind)
+   ((unwind . 0) . unwind)
+
    ((bytevector-u8-ref . 2) . bv-u8-ref)
    ((bytevector-u8-set! . 3) . bv-u8-set)
    ((bytevector-s8-ref . 2) . bv-s8-ref)
@@ -940,74 +943,6 @@
             (clear-stack-slots context gensyms)
             (emit-code #f (make-glil-unbind))))))
 
-      ((<dynwind> src winder body unwinder)
-       (define (thunk? x)
-         (and (lambda? x)
-              (null? (lambda-case-gensyms (lambda-body x)))))
-       (define (make-wrong-type-arg x)
-         (make-primcall src 'scm-error
-                        (list
-                         (make-const #f 'wrong-type-arg)
-                         (make-const #f "dynamic-wind")
-                         (make-const #f "Wrong type (expecting thunk): ~S")
-                         (make-primcall #f 'list (list x))
-                         (make-primcall #f 'list (list x)))))
-       (define (emit-thunk-check x)
-         (comp-drop (make-conditional
-                     src
-                     (make-primcall src 'thunk? (list x))
-                     (make-void #f)
-                     (make-wrong-type-arg x))))
-
-       ;; The `winder' and `unwinder' of a dynwind are constant
-       ;; expressions and can be duplicated.
-       (if (not (thunk? winder))
-           (emit-thunk-check winder))
-       (comp-push winder)
-       (if (not (thunk? unwinder))
-           (emit-thunk-check unwinder))
-       (comp-push unwinder)
-       (emit-code #f (make-glil-call 'wind 2))
-
-       (case context
-         ((tail)
-          (let ((MV (make-label)))
-            (comp-vals body MV)
-            ;; One value.  Unwind and return the value.
-            (emit-code #f (make-glil-call 'unwind 0))
-            (emit-code #f (make-glil-call 'return 1))
-            
-            (emit-label MV)
-            ;; Multiple values.  Unwind and return the values.
-            (emit-code #f (make-glil-call 'unwind 0))
-            (emit-code #f (make-glil-call 'return/nvalues 1))))
-         
-         ((push)
-          ;; We only want one value, so ask for one value and then
-          ;; unwind, leaving the value on the stack.
-          (comp-push body)
-          (emit-code #f (make-glil-call 'unwind 0)))
-         
-         ((vals)
-          (let ((MV (make-label)))
-            (comp-vals body MV)
-            ;; Transform a singly-valued return to a multiple-value
-            ;; return and fall through to MV case.
-            (emit-code #f (make-glil-const 1))
-            
-            (emit-label MV)
-            ;; Multiple values: unwind and go to the MVRA.
-            (emit-code #f (make-glil-call 'unwind 0))
-            (emit-branch #f 'br MVRA)))
-         
-         ((drop)
-          ;; Compile body, discarding values.  Then unwind and fall
-          ;; through, or goto RA if there is one.
-          (comp-drop body)
-          (emit-code #f (make-glil-call 'unwind 0))
-          (if RA
-              (emit-branch #f 'br RA)))))
-
       ((<dynlet> src fluids vals body)
        (for-each comp-push fluids)
        (for-each comp-push vals)

module/language/tree-il/cse.scm

@@ -442,15 +442,6 @@
                      ((consumer db**) (visit consumer (concat db* db) env ctx)))
          (return (make-let-values src producer consumer)
                  (concat db** db*))))
-      (($ <dynwind> src winder body unwinder)
-       (let*-values (((winder db*) (visit winder db env 'value))
-                     ((db**) db*)
-                     ((unwinder db*) (visit unwinder db env 'value))
-                     ((db**) (concat db* db**))
-                     ((body db*) (visit body (concat db** db) env ctx))
-                     ((db**) (concat db* db**)))
-         (return (make-dynwind src winder body unwinder)
-                 db**)))
       (($ <dynlet> src fluids vals body)
        (let*-values (((fluids db*) (parallel-visit fluids db env 'value))
                      ((vals db**) (parallel-visit vals db env 'value))

module/language/tree-il/debug.scm

@@ -216,10 +216,6 @@
          (for-each (cut visit <> env) fluids)
          (for-each (cut visit <> env) vals)
          (visit body env))))
-      (($ <dynwind> src winder body unwinder)
-       (visit winder env)
-       (visit body env)
-       (visit unwinder env))
       (($ <dynref> src fluid)
        (visit fluid env))
       (($ <dynset> src fluid exp)

module/language/tree-il/effects.scm

@@ -211,10 +211,6 @@ of an expression."
            (logior (compute-effects producer)
                    (compute-effects consumer)
                    (cause &type-check)))
-          (($ <dynwind> _ winder body unwinder)
-           (logior (compute-effects winder)
-                   (compute-effects body)
-                   (compute-effects unwinder)))
           (($ <dynlet> _ fluids vals body)
            (logior (accumulate-effects fluids)
                    (accumulate-effects vals)

module/language/tree-il/peval.scm

@@ -104,8 +104,6 @@
     (($ <conditional> _ test consequent alternate)
      (and (singly-valued-expression? consequent)
           (singly-valued-expression? alternate)))
-    (($ <dynwind> _ winder body unwinder)
-     (singly-valued-expression? body))
     (else #f)))
 
 (define (truncate-values x)
@@ -543,10 +541,6 @@ top-level bindings from ENV and return the resulting expression."
         (($ <prompt>) #f)
         (($ <abort>) #f)
         
-        ;; Bail on dynwinds, as that would cause the consumer to run in
-        ;; the wrong dynamic context.
-        (($ <dynwind>) #f)
-
         ;; Propagate to tail positions.
         (($ <let> src names gensyms vals body)
          (let ((body (loop body)))
@@ -1002,11 +996,6 @@ 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)
-       (make-dynwind src
-                     (for-value winder)
-                     (for-tail body)
-                     (for-value unwinder)))
       (($ <dynlet> src fluids vals body)
        (make-dynlet src (map for-value fluids) (map for-value vals)
                     (for-tail body)))
@@ -1169,13 +1158,29 @@ top-level bindings from ENV and return the resulting expression."
          (list w u) 2
          (match-lambda
           ((w u)
-           (make-seq src
+           (make-seq
-                     (make-call src w '())
+            src
-                     (make-begin0 src
+            (make-seq
-                                  (make-dynwind src w
+             src
-                                                (make-call src thunk '())
+             (make-conditional
-                                                u)
+              src
-                                  (make-call src u '()))))))))
+              ;; fixme: introduce logic to fold thunk?
+              (make-primcall src 'thunk? (list u))
+              (make-call src w '())
+              (make-primcall
+               src 'scm-error
+               (list
+                (make-const #f 'wrong-type-arg)
+                (make-const #f "dynamic-wind")
+                (make-const #f "Wrong type (expecting thunk): ~S")
+                (make-primcall #f 'list (list u))
+                (make-primcall #f 'list (list u)))))
+             (make-primcall src 'wind (list w u)))
+            (make-begin0 src
+                         (make-call src thunk '())
+                         (make-seq src
+                                   (make-primcall src 'unwind '())
+                                   (make-call src u '())))))))))
 
       (($ <primcall> src 'values exps)
        (cond
@@ -1244,6 +1249,15 @@ top-level bindings from ENV and return the resulting expression."
            ((name . args)
             (make-primcall src name args))))))
 
+      (($ <primcall> src 'thunk? (proc))
+       (match (for-value proc)
+         (($ <lambda> _ _ ($ <lambda-case> _ req))
+          (for-tail (make-const src (null? req))))
+         (proc
+          (case ctx
+            ((effect) (make-void src))
+            (else (make-primcall src 'thunk? (list proc)))))))
+
       (($ <primcall> src (? accessor-primitive? name) args)
        (match (cons name (map for-value args))
          ;; FIXME: these for-tail recursions could take place outside

module/language/tree-il/primitives.scm

@@ -41,7 +41,6 @@
     call-with-current-continuation
     call/cc
     dynamic-wind
-    @dynamic-wind
     values
     eq? eqv? equal?
     memq memv
@@ -51,6 +50,8 @@
     not
     pair? null? list? symbol? vector? string? struct? number? char? nil?
 
+    procedure? thunk?
+
     complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
 
     char<? char<=? char>=? char>?
@@ -176,6 +177,7 @@
     eq? eqv? equal?
     not
     pair? null? list? symbol? vector? struct? string? number? char?
+    procedure? thunk?
     acons cons cons* list vector))
 
 ;; Primitives that don't always return one value.
@@ -185,7 +187,6 @@
     call-with-current-continuation
     call/cc
     dynamic-wind
-    @dynamic-wind
     values
     call-with-prompt
     @abort abort-to-prompt))
@@ -533,38 +534,6 @@
 (hashq-set! *primitive-expand-table* 'eqv?   maybe-simplify-to-eq)
 (hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
 
-(hashq-set! *primitive-expand-table*
-            '@dynamic-wind
-            (case-lambda
-              ((src pre expr post)
-               (let* ((PRE (gensym "pre-"))
-                      (POST (gensym "post-"))
-                      (winder (make-lexical-ref #f 'winder PRE))
-                      (unwinder (make-lexical-ref #f 'unwinder POST)))
-                 (define (make-begin0 src first second)
-                   (make-let-values
-                    src
-                    first
-                    (let ((vals (gensym "vals ")))
-                      (make-lambda-case
-                       #f
-                       '() #f 'vals #f '() (list vals)
-                       (make-seq
-                        src
-                        second
-                        (make-primcall #f 'apply
-                                       (list
-                                        (make-primitive-ref #f 'values)
-                                        (make-lexical-ref #f 'vals vals))))
-                       #f))))
-                 (make-let src '(pre post) (list PRE POST) (list pre post)
-                           (make-seq src
-                                     (make-call src winder '())
-                                     (make-begin0
-                                      src
-                                      (make-dynwind src winder expr unwinder)
-                                      (make-call src unwinder '()))))))))
-
 (hashq-set! *primitive-expand-table*
             'fluid-ref
             (case-lambda

test-suite/tests/peval.test

@@ -1070,42 +1070,48 @@
    ;; the dynwind; alack.
    (dynamic-wind foo (lambda () bar) baz)
    (let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
-        (seq (call (lexical tmp _))
+        (seq (seq (if (primcall thunk? (lexical tmp _))
-             (let (tmp) (_) ((dynwind (lexical tmp _)
+                      (call (lexical tmp _))
-                                      (toplevel bar)
+                      (primcall scm-error . _))
-                                      (lexical tmp _)))
+                  (primcall wind (lexical tmp _) (lexical tmp _)))
-                  (seq (call (lexical tmp _))
+             (let (tmp) (_) ((toplevel bar))
+                  (seq (seq (primcall unwind)
+                            (call (lexical tmp _)))
                        (lexical tmp _))))))
   
   (pass-if-peval
-   ;; Constant guards don't need lexical bindings.
+   ;; Constant guards don't need lexical bindings or thunk? checks.
    (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
-   (seq (toplevel foo)
+   (seq (seq (toplevel foo)
-        (let (tmp) (_) ((dynwind (lambda ()
+             (primcall wind
-                                   (lambda-case
+                       (lambda ()
-                                    ((() #f #f #f () ()) (toplevel foo))))
+                         (lambda-case
-                                 (toplevel bar)
+                          ((() #f #f #f () ()) (toplevel foo))))
-                                 (lambda ()
+                       (lambda ()
-                                   (lambda-case
+                         (lambda-case
-                                    ((() #f #f #f () ()) (toplevel baz))))))
+                          ((() #f #f #f () ()) (toplevel baz))))))
-             (seq (toplevel baz)
+        (let (tmp) (_) ((toplevel bar))
+             (seq (seq (primcall unwind)
+                       (toplevel baz))
                   (lexical tmp _)))))
   
   (pass-if-peval
    ;; Dynwind bodies that return an unknown number of values need a
    ;; let-values.
    (dynamic-wind (lambda () foo) (lambda () (bar)) (lambda () baz))
-   (seq (toplevel foo)
+   (seq (seq (toplevel foo)
-        (let-values (dynwind (lambda ()
+             (primcall wind
-                               (lambda-case
+                       (lambda ()
-                                ((() #f #f #f () ()) (toplevel foo))))
+                         (lambda-case
-                             (call (toplevel bar))
+                          ((() #f #f #f () ()) (toplevel foo))))
-                             (lambda ()
+                       (lambda ()
-                               (lambda-case
+                         (lambda-case
-                                ((() #f #f #f () ()) (toplevel baz)))))
+                          ((() #f #f #f () ()) (toplevel baz))))))
+        (let-values (call (toplevel bar))
           (lambda-case
            ((() #f vals #f () (_))
-            (seq (toplevel baz)
+            (seq (seq (primcall unwind)
+                      (toplevel baz))
                  (primcall apply (primitive values) (lexical vals _))))))))
   
   (pass-if-peval