<prompt> has no pre-unwind-handler, it's unnecessary

* libguile/control.h:
* libguile/control.c (scm_c_make_prompt, SCM_PROMPT_PRE_UNWIND_HANDLER):
* libguile/vm-i-system.c (prompt)
* module/language/tree-il.scm (<prompt> prompt-pre-unwind-handler):
* module/language/tree-il/analyze.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/inline.scm:
* module/language/tree-il/primitives.scm: Remove the "pre-unwind"
  handler from prompt; it turns out not to be necessary. Adapt all
  references.

diff --git a/libguile/control.c b/libguile/control.c
index bcbc6a1..0686924 100644 (file)
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -49,19 +49,19 @@ SCM_DEFINE (scm_atprompt, "@prompt", 4, 0, 0,
 #undef FUNC_NAME
 
 SCM
-scm_c_make_prompt (SCM vm, SCM k, SCM handler, SCM pre_unwind,
-                   scm_t_uint8 inline_p, scm_t_uint8 escape_only_p)
+scm_c_make_prompt (SCM vm, SCM k, SCM handler, scm_t_uint8 inline_handler_p,
+                   scm_t_uint8 escape_only_p)
 {
   scm_t_bits tag;
   SCM ret;
   struct scm_prompt_registers *regs;
 
   tag = scm_tc7_prompt;
-  if (inline_p)
+  if (inline_handler_p)
     tag |= SCM_F_PROMPT_INLINE;
   if (escape_only_p)
     tag |= SCM_F_PROMPT_ESCAPE;
-  ret = scm_words (tag, 6);
+  ret = scm_words (tag, 5);
 
   regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers");
   regs->fp = SCM_VM_DATA (vm)->fp;
@@ -72,7 +72,6 @@ scm_c_make_prompt (SCM vm, SCM k, SCM handler, SCM pre_unwind,
   SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs);
   SCM_SET_CELL_OBJECT (ret, 3, scm_i_dynwinds ());
   SCM_SET_CELL_OBJECT (ret, 4, handler);
-  SCM_SET_CELL_OBJECT (ret, 5, pre_unwind);
 
   return ret;
 }

diff --git a/libguile/control.h b/libguile/control.h
index b498562..9fe880b 100644 (file)
--- a/libguile/control.h
+++ b/libguile/control.h
@@ -31,7 +31,6 @@
 #define SCM_PROMPT_REGISTERS(x)        ((struct scm_prompt_registers*)SCM_CELL_WORD ((x), 2))
 #define SCM_PROMPT_DYNENV(x)   (SCM_CELL_OBJECT ((x), 3))
 #define SCM_PROMPT_HANDLER(x)  (SCM_CELL_OBJECT ((x), 4))
-#define SCM_PROMPT_PRE_UNWIND_HANDLER(x) (SCM_CELL_OBJECT ((x), 5))
 
 #define SCM_PROMPT_SETJMP(p)   (SCM_I_SETJMP (SCM_PROMPT_REGISTERS (p)->regs))
 
@@ -44,8 +43,9 @@ struct scm_prompt_registers
 };
 
 
-SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, SCM handler, SCM pre_unwind,
-                                    scm_t_uint8 inline_p, scm_t_uint8 escape_only_p);
+SCM_INTERNAL SCM scm_c_make_prompt (SCM vm, SCM k, SCM handler,
+                                    scm_t_uint8 inline_handler_p,
+                                    scm_t_uint8 escape_only_p);
 
 
 SCM_INTERNAL void scm_register_control (void);

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 003bdb4..15e3394 100644 (file)
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1450,16 +1450,15 @@ VM_DEFINE_INSTRUCTION (82, make_symbol, "make-symbol", 0, 1, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 5, 3, 0)
+VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 5, 2, 0)
 {
   scm_t_int32 offset;
   scm_t_uint8 inline_handler_p, escape_only_p;
-  SCM k, handler, pre_unwind, prompt;
+  SCM k, handler, prompt;
 
   inline_handler_p = FETCH ();
   escape_only_p = FETCH ();
   FETCH_OFFSET (offset);
-  POP (pre_unwind);
   POP (handler);
   POP (k);
 
@@ -1467,8 +1466,7 @@ VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 5, 3, 0)
   /* Push the prompt onto the dynamic stack. The setjmp itself has to be local
      to this procedure. */
   /* FIXME: do more error checking */
-  prompt = scm_c_make_prompt (vm, k, handler, pre_unwind,
-                              inline_handler_p, escape_only_p);
+  prompt = scm_c_make_prompt (vm, k, handler, inline_handler_p, escape_only_p);
   scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
   if (SCM_PROMPT_SETJMP (prompt))
     {

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 726918d..47b2d83 100644 (file)
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -47,7 +47,7 @@
             <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
-            <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler prompt-pre-unwind-handler 
+            <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
             <control> control? make-control control-src control-tag control-type control-args
 
             parse-tree-il
@@ -81,7 +81,7 @@
   (<let-values> exp body)
   (<dynwind> winder body unwinder)
   (<dynlet> fluids vals body)
-  (<prompt> tag body handler pre-unwind-handler)
+  (<prompt> tag body handler)
   (<control> tag type args))
   
 \f
@@ -179,9 +179,8 @@
      ((dynlet ,fluids ,vals ,body)
       (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
      
-     ((prompt ,tag ,body ,handler ,pre-unwind-handler)
-      (make-prompt loc (retrans tag) (retrans body) (retrans handler)
-                   (and=> pre-unwind-handler retrans)))
+     ((prompt ,tag ,body ,handler)
+      (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
      
      ((control ,tag ,type ,args)
       (make-control loc (retrans tag) type (map retrans args)))
@@ -258,9 +257,8 @@
      `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
               ,(unparse-tree-il body)))
     
-    ((<prompt> tag body handler pre-unwind-handler)
-     `(prompt ,tag ,(unparse-tree-il body) ,(unparse-tree-il handler)
-              ,(and=> pre-unwind-handler unparse-tree-il)))
+    ((<prompt> tag body handler)
+     `(prompt ,tag ,(unparse-tree-il body) ,(unparse-tree-il handler)))
     
     ((<control> tag type args)
      `(control ,(unparse-tree-il tag) ,type ,(map unparse-tree-il args)))))
@@ -348,10 +346,10 @@
                          (map tree-il->scheme vals))
         ,(tree-il->scheme body)))
     
-    ((<prompt> tag body handler pre-unwind-handler)
+    ((<prompt> tag body handler)
      `((@ (ice-9 control) prompt) 
        ,(tree-il->scheme tag) (lambda () ,(tree-il->scheme body))
-       ,(tree-il->scheme handler) ,(and=> pre-unwind-handler tree-il->scheme)))
+       ,(tree-il->scheme handler)))
     
 
     ((<control> tag type args)
@@ -418,14 +416,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
            (up tree (loop body
                           (loop vals
                                 (loop fluids (down tree result))))))
-          ((<prompt> tag body handler pre-unwind-handler)
-           (up tree (loop tag
-                          (loop body
-                                (loop handler
-                                      (if pre-unwind-handler
-                                          (loop pre-unwind-handler
-                                                (down tree result))
-                                          (down tree result)))))))
+          ((<prompt> tag body handler)
+           (up tree
+               (loop tag (loop body (loop handler
+                                          (down tree result))))))
           ((<control> tag type args)
            (up tree (loop tag (loop args (down tree result)))))
           (else
@@ -491,13 +485,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
                   (let*-values (((seed ...) (fold-values foldts fluids seed ...))
                                 ((seed ...) (fold-values foldts vals seed ...)))
                     (foldts body seed ...)))
-                 ((<prompt> tag body handler pre-unwind-handler)
+                 ((<prompt> tag body handler)
                   (let*-values (((seed ...) (foldts tag seed ...))
-                                ((seed ...) (foldts body seed ...))
-                                ((seed ...) (foldts handler seed ...)))
-                    (if pre-unwind-handler
-                        (values seed ...)
-                        (foldts pre-unwind-handler seed ...))))
+                                ((seed ...) (foldts body seed ...)))
+                    (foldts handler seed ...)))
                  ((<control> tag args)
                   (let*-values (((seed ...) (foldts tag seed ...)))
                     (fold-values foldts args seed ...)))
@@ -567,12 +558,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
        (set! (dynlet-vals x) (map lp vals))
        (set! (dynlet-body x) (lp body)))
       
-      ((<prompt> tag body handler pre-unwind-handler)
+      ((<prompt> tag body handler)
        (set! (prompt-tag x) (lp tag))
        (set! (prompt-body x) (lp body))
-       (set! (prompt-handler x) (lp handler))
-       (if pre-unwind-handler
-           (set! (prompt-pre-unwind-handler x) (lp pre-unwind-handler))))
+       (set! (prompt-handler x) (lp handler)))
       
       ((<control> tag args)
        (set! (control-tag x) (lp tag))
@@ -644,12 +633,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
          (set! (dynlet-vals x) (map lp vals))
          (set! (dynlet-body x) (lp body)))
       
-        ((<prompt> tag body handler pre-unwind-handler)
+        ((<prompt> tag body handler)
          (set! (prompt-tag x) (lp tag))
          (set! (prompt-body x) (lp body))
-         (set! (prompt-handler x) (lp handler))
-         (if pre-unwind-handler
-             (set! (prompt-pre-unwind-handler x) (lp pre-unwind-handler))))
+         (set! (prompt-handler x) (lp handler)))
         
         ((<control> tag args)
          (set! (control-tag x) (lp tag))

diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index c60bcce..3363103 100644 (file)
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -342,9 +342,8 @@
       ((<dynlet> fluids vals body)
        (apply lset-union eq? (step body) (map step (append fluids vals))))
       
-      ((<prompt> tag body handler pre-unwind-handler)
-       (lset-union eq? (step tag) (step handler)
-                   (if pre-unwind-handler (step pre-unwind-handler) '())))
+      ((<prompt> tag body handler)
+       (lset-union eq? (step tag) (step handler)))
       
       ((<control> tag type args)
        (apply lset-union eq? (step tag) (map step args)))
@@ -506,14 +505,13 @@
       ((<dynlet> fluids vals body)
        (apply max (recur body) (map recur (append fluids vals))))
       
-      ((<prompt> tag body handler pre-unwind-handler)
+      ((<prompt> tag body handler)
        (let ((cont-var (and (lambda-case? handler)
                             (pair? (lambda-case-vars handler))
                             (car (lambda-case-vars handler)))))
          (hashq-set! allocation x
                      (and cont-var (zero? (hashq-ref refcounts cont-var 0))))
-         (max (recur tag) (recur body) (recur handler)
-              (if pre-unwind-handler (recur pre-unwind-handler) 0))))
+         (max (recur tag) (recur body) (recur handler))))
       
       ((<control> tag type args)
        (apply max (recur tag) (map recur args)))

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 887a247..d85de2a 100644 (file)
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -1020,7 +1020,7 @@
       ;; if the continuation isn't referenced, we don't reify it. This makes it
       ;; possible to implement catch and throw with delimited continuations,
       ;; without any overhead.
-      ((<prompt> src tag body handler pre-unwind-handler)
+      ((<prompt> src tag body handler)
        (let ((H (make-label))
              (POST (make-label))
              (inline? (lambda-case? handler))
@@ -1030,9 +1030,6 @@
          (if inline?
              (emit-code #f (make-glil-const #f)) ;; push #f as handler
              (comp-push handler))
-         (if pre-unwind-handler
-             (comp-push pre-unwind-handler)
-             (emit-code #f (make-glil-const #f)))
          (emit-code src (make-glil-prompt H inline? escape-only?))
 
          ;; Then we compile the body, with its normal return path, unwinding

diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
index ec030c8..0653db1 100644 (file)
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -110,14 +110,14 @@
       ((<fix> vars body)
        (if (null? vars) body x))
        
-      ((<prompt> src tag body handler pre-unwind-handler)
+      ((<prompt> src tag body handler)
        ;; If the handler is a simple lambda, inline it.
        (if (and (lambda? handler)
                 (record-case (lambda-body handler)
                   ((<lambda-case> req opt kw rest alternate)
                    (and (pair? req) (not opt) (not kw) (not alternate)))
                   (else #f)))
-           (make-prompt src tag body (lambda-body handler) pre-unwind-handler)
+           (make-prompt src tag body (lambda-body handler))
            x))
        
       (else #f)))

diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 2593426..76bc88b 100644 (file)
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -426,16 +426,13 @@
               ((src tag thunk handler)
                (make-prompt src tag (make-application #f thunk '())
                             handler #f))
-              ((src tag thunk handler pre)
-               (make-prompt src tag (make-application #f thunk '())
-                            handler pre))
               (else #f)))
 (hashq-set! *primitive-expand-table*
             '@prompt
             (case-lambda
-              ((src tag thunk handler pre)
+              ((src tag thunk handler)
                (make-prompt src tag (make-application #f thunk '())
-                            handler pre))
+                            handler))
               (else #f)))
 
 (hashq-set! *primitive-expand-table*