Add "pop" field to $prompt

* module/language/cps.scm ($prompt): Add a "pop" field, indicating the
  continuation at which this prompt is popped.  The body of the prompt
  is dominated by the prompt, and post-dominated by the pop.  Adapt all
  builders and users.

* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-rtl.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/verify.scm:
* module/language/tree-il/compile-cps.scm: Adapt.

* module/language/cps/dfg.scm (visit-fun): Add an arc from the pop to
  the handler, to keep handler variables alive through the prompt body.

diff --git a/module/language/cps.scm b/module/language/cps.scm
index ac5642a..d39124e 100644 (file)
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -85,7 +85,8 @@
 ;;;   - $prompt continues to the body of the prompt, having pushed on a
 ;;;     prompt whose handler will continue at its "handler"
 ;;;     continuation.  The continuation of the prompt is responsible for
-;;;     popping the prompt.
+;;;     popping the prompt.  A $prompt also records the continuation
+;;;     that pops the prompt, to make various static analyses easier.
 ;;;
 ;;; In summary:
 ;;;
@@ -185,7 +186,7 @@
 (define-cps-type $call proc args)
 (define-cps-type $primcall name args)
 (define-cps-type $values args)
-(define-cps-type $prompt escape? tag handler)
+(define-cps-type $prompt escape? tag handler pop)
 
 (define-syntax let-gensyms
   (syntax-rules ()
@@ -240,7 +241,8 @@
     ((_ ($primcall name args)) (make-$primcall name args))
     ((_ ($values (arg ...))) (make-$values (list arg ...)))
     ((_ ($values args)) (make-$values args))
-    ((_ ($prompt escape? tag handler)) (make-$prompt escape? tag handler))))
+    ((_ ($prompt escape? tag handler pop))
+     (make-$prompt escape? tag handler pop))))
 
 (define-syntax build-cps-term
   (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
@@ -340,8 +342,8 @@
      (build-cps-exp ($primcall name arg)))
     (('values arg ...)
      (build-cps-exp ($values arg)))
-    (('prompt escape? tag handler)
-     (build-cps-exp ($prompt escape? tag handler)))
+    (('prompt escape? tag handler pop)
+     (build-cps-exp ($prompt escape? tag handler pop)))
     (_
      (error "unexpected cps" exp))))
 
@@ -398,8 +400,8 @@
      `(primcall ,name ,@args))
     (($ $values args)
      `(values ,@args))
-    (($ $prompt escape? tag handler)
-     `(prompt ,escape? ,tag ,handler))
+    (($ $prompt escape? tag handler pop)
+     `(prompt ,escape? ,tag ,handler ,pop))
     (_
      (error "unexpected cps" exp))))
 

diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
index 9a9738b..05d9bdb 100644 (file)
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -217,12 +217,12 @@ convert functions to flat closures."
                                     ($continue k ($values args)))
                                   '()))))
 
-    (($ $continue k ($ $prompt escape? tag handler))
+    (($ $continue k ($ $prompt escape? tag handler pop))
      (convert-free-var
       tag self bound
       (lambda (tag)
         (values (build-cps-term
-                  ($continue k ($prompt escape? tag handler)))
+                  ($continue k ($prompt escape? tag handler pop)))
                 '()))))
 
     (_ (error "what" exp))))

diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
index 26aa87b..6284eb0 100644 (file)
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -272,7 +272,7 @@
         (($ $primcall name args)
          (error "unhandled primcall in seq context" name))
         (($ $values ()) #f)
-        (($ $prompt escape? tag handler)
+        (($ $prompt escape? tag handler pop)
          (match (lookup-cont handler cont-table)
            (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
             (let ((receive-args (gensym "handler"))

diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 45c5dd6..69d5ae4 100644 (file)
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -655,9 +655,20 @@
          (($ $values args)
           (for-each use! args))
 
-         (($ $prompt escape? tag handler)
+         (($ $prompt escape? tag handler pop)
           (use! tag)
-          (use-k! handler))
+          (use-k! handler)
+          ;; Any continuation in the prompt body could cause an abort to
+          ;; the handler, so in theory we could register the handler as
+          ;; a successor of any block in the prompt body.  That would be
+          ;; inefficient, though, besides being a hack.  Instead we take
+          ;; advantage of the fact that pop continuation post-dominates
+          ;; the prompt body, so we add a link from there to the
+          ;; handler.  This creates a primcall node with multiple
+          ;; successors, which is not quite correct, but it does reflect
+          ;; control flow.  It is necessary to ensure that the live
+          ;; variables in the handler are seen as live in the body.
+          (link-blocks! pop handler))
 
          (($ $fun)
           (when global?

diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 07f6e27..9d3dae8 100644 (file)
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -402,7 +402,7 @@ are comparable with eqv?.  A tmp slot may be used."
                            live-slots live-slots*
                            (compute-dst-slots))))
 
-        (($ $prompt escape? tag handler)
+        (($ $prompt escape? tag handler pop)
          (match (lookup-cont handler (dfg-cont-table dfg))
            (($ $ktrunc arity kargs)
             (let* ((live-slots (allocate-prompt-handler! label live-slots))

diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index bb2e857..76fad51 100644 (file)
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -132,10 +132,11 @@
        (for-each (cut check-var <> v-env) arg))
       (($ $values ((? symbol? arg) ...))
        (for-each (cut check-var <> v-env) arg))
-      (($ $prompt escape? tag handler)
+      (($ $prompt escape? tag handler pop)
        (unless (boolean? escape?) (error "escape? should be boolean" escape?))
        (check-var tag v-env)
-       (check-var handler k-env))
+       (check-var handler k-env)
+       (check-var pop k-env))
       (_
        (error "unexpected expression" exp))))
 

diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 7ea82b4..1d68644 100644 (file)
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -387,7 +387,7 @@
                         ($letk ((kbody (tree-il-src body) 
                                        ($kargs () ()
                                          ,(convert body krest subst))))
-                          ($continue kbody ($prompt #t tag khargs))))
+                          ($continue kbody ($prompt #t tag khargs kpop))))
                       (convert-arg body
                         (lambda (thunk)
                           (build-cps-term
@@ -397,7 +397,7 @@
                                                ($primcall 'call-thunk/no-inline
                                                           (thunk))))))
                               ($continue kbody
-                                ($prompt #f tag khargs))))))))))))))
+                                ($prompt #f tag khargs kpop))))))))))))))
 
     ;; Eta-convert prompts without inline handlers.
     (($ <prompt> src escape-only? tag body handler)