$prompt is now its own kind of CPS term.

* module/language/cps.scm ($prompt): Rework to be its own term kind.
  Now $continue always continues to a single continuation.  Adapt
  callers.

.dir-locals.el

@@ -34,6 +34,7 @@
      (eval . (put '$letconst           'scheme-indent-function 1))
      (eval . (put '$continue           'scheme-indent-function 2))
      (eval . (put '$branch             'scheme-indent-function 3))
+     (eval . (put '$prompt             'scheme-indent-function 3))
      (eval . (put '$kargs              'scheme-indent-function 2))
      (eval . (put '$kfun               'scheme-indent-function 4))
      (eval . (put '$letrec             'scheme-indent-function 3))

module/language/cps.scm

@@ -127,11 +127,11 @@
             $kreceive $kargs $kfun $ktail $kclause
 
             ;; Terms.
-            $continue $branch
+            $continue $branch $prompt
 
             ;; Expressions.
             $const $prim $fun $rec $closure
-            $call $callk $primcall $values $prompt
+            $call $callk $primcall $values
 
             ;; Building macros.
             build-cont build-term build-exp
@@ -180,6 +180,7 @@
 ;; Terms.
 (define-cps-type $continue k src exp)
 (define-cps-type $branch kf kt src op param args)
+(define-cps-type $prompt k kh src escape? tag)
 
 ;; Expressions.
 (define-cps-type $const val)
@@ -191,7 +192,6 @@
 (define-cps-type $callk k proc args) ; First-order.
 (define-cps-type $primcall name param args)
 (define-cps-type $values args)
-(define-cps-type $prompt escape? tag handler)
 
 (define-syntax build-arity
   (syntax-rules (unquote)
@@ -229,12 +229,14 @@
     ((_ ($branch kf kt src op param (arg ...)))
      (make-$branch kf kt src op param (list arg ...)))
     ((_ ($branch kf kt src op param args))
-     (make-$branch kf kt src op param args))))
+     (make-$branch kf kt src op param args))
+    ((_ ($prompt k kh src escape? tag))
+     (make-$prompt k kh src escape? tag))))
 
 (define-syntax build-exp
   (syntax-rules (unquote
                  $const $prim $fun $rec $closure
-                 $call $callk $primcall $values $prompt)
+                 $call $callk $primcall $values)
     ((_ (unquote exp)) exp)
     ((_ ($const val)) (make-$const val))
     ((_ ($prim name)) (make-$prim name))
@@ -252,9 +254,7 @@
     ((_ ($primcall name param args)) (make-$primcall name param args))
     ((_ ($values (unquote args))) (make-$values args))
     ((_ ($values (arg ...))) (make-$values (list arg ...)))
-    ((_ ($values args)) (make-$values args))
+    ((_ ($values args)) (make-$values args))))
-    ((_ ($prompt escape? tag handler))
-     (make-$prompt escape? tag handler))))
 
 (define-syntax-rule (rewrite-cont x (pat cont) ...)
   (match x
@@ -290,6 +290,8 @@
      (build-term ($continue k (src exp) ,(parse-cps exp))))
     (('branch kf kt op param arg ...)
      (build-term ($branch kf kt (src exp) op param arg)))
+    (('prompt k kh escape? tag)
+     (build-term ($prompt k kh (src exp) escape? tag)))
 
     ;; Expressions.
     (('unspecified)
@@ -312,8 +314,6 @@
      (build-exp ($primcall name param arg)))
     (('values arg ...)
      (build-exp ($values arg)))
-    (('prompt escape? tag handler)
-     (build-exp ($prompt escape? tag handler)))
     (_
      (error "unexpected cps" exp))))
 
@@ -337,6 +337,8 @@
      `(continue ,k ,(unparse-cps exp)))
     (($ $branch kf kt src op param args)
      `(branch ,kf ,kt ,op ,param ,@args))
+    (($ $prompt k kh src escape? tag)
+     `(prompt ,k ,kh ,escape? ,tag))
 
     ;; Expressions.
     (($ $const val)
@@ -361,7 +363,5 @@
      `(primcall ,name ,param ,@args))
     (($ $values args)
      `(values ,@args))
-    (($ $prompt escape? tag handler)
-     `(prompt ,escape? ,tag ,handler))
     (_
      (error "unexpected cps" exp))))

module/language/cps/closure-conversion.scm

@@ -90,11 +90,11 @@ conts."
            (($ $call proc args)
             (add-uses args uses))
            (($ $primcall name param args)
-            (add-uses args uses))
+            (add-uses args uses))))
-           (($ $prompt escape? tag handler)
-            (add-use tag uses))))
         (($ $kargs _ _ ($ $branch kf kt src op param args))
          (add-uses args uses))
+        (($ $kargs _ _ ($ $prompt k kh src escape? tag))
+         (add-use tag uses))
         (_ uses)))
     conts
     empty-intset)))
@@ -117,9 +117,9 @@ conts."
       (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
       (($ $ktail) (ref0))
       (($ $kclause arity kbody kalt) (ref2 kbody kalt))
-      (($ $kargs _ _ ($ $continue k _ ($ $prompt _ _ h))) (ref2 k h))
       (($ $kargs _ _ ($ $continue k)) (ref1 k))
-      (($ $kargs _ _ ($ $branch kf kt)) (ref2 kf kt))))
+      (($ $kargs _ _ ($ $branch kf kt)) (ref2 kf kt))
+      (($ $kargs _ _ ($ $prompt k kh)) (ref2 k kh))))
   (let*-values (((single multiple) (values empty-intset empty-intset))
                 ((single multiple) (intset-fold add-ref body single multiple)))
     (intset-subtract (persistent-intset single)
@@ -244,16 +244,16 @@ shared closures to use the appropriate 'self' variable, if possible."
         (($ $primcall name param args)
          ($primcall name param ,(map subst args)))
         (($ $values args)
-         ($values ,(map subst args)))
+         ($values ,(map subst args)))))
-        (($ $prompt escape? tag handler)
-         ($prompt escape? (subst tag) handler))))
 
     (define (visit-term term)
       (rewrite-term term
         (($ $continue k src exp)
          ($continue k src ,(visit-exp exp)))
         (($ $branch kf kt src op param args)
-         ($branch kf kt src op param ,(map subst args)))))
+         ($branch kf kt src op param ,(map subst args)))
+        (($ $prompt k kh src escape? tag)
+         ($prompt k kh src escape? (subst tag)))))
 
     (define (visit-rec labels vars cps)
       (define (compute-env label bound self rec-bound rec-labels env)
@@ -374,11 +374,11 @@ references."
                         (($ $callk label proc args)
                          (add-use proc (add-uses args uses)))
                         (($ $primcall name param args)
-                         (add-uses args uses))
+                         (add-uses args uses))))
-                        (($ $prompt escape? tag handler)
-                         (add-use tag uses))))
                      (($ $branch kf kt src op param args)
-                      (add-uses args uses)))))
+                      (add-uses args uses))
+                     (($ $prompt k kh src escape? tag)
+                      (add-use tag uses)))))
                  (($ $kfun src meta self)
                   (values (add-def self defs) uses))
                  (_ (values defs uses))))
@@ -726,13 +726,12 @@ bound to @var{var}, and continue to @var{k}."
                (build-term
                  ($continue k src ($values args)))))))
 
-        (($ $continue k src ($ $prompt escape? tag handler))
+        (($ $prompt k kh src escape? tag)
          (convert-arg cps tag
            (lambda (cps tag)
              (with-cps cps
                (build-term
-                 ($continue k src
+                 ($prompt k kh src escape? tag))))))
-                   ($prompt escape? tag handler)))))))
 
         (($ $branch kf kt src op param args)
          (convert-args cps args

module/language/cps/compile-bytecode.scm

@@ -307,28 +307,6 @@
     (define (compile-effect label exp k)
       (match exp
         (($ $values ()) #f)
-        (($ $prompt escape? tag handler)
-         (match (intmap-ref cps handler)
-           (($ $kreceive ($ $arity req () rest () #f) khandler-body)
-            (let ((receive-args (gensym "handler"))
-                  (nreq (length req))
-                  (proc-slot (lookup-call-proc-slot label allocation)))
-              (emit-prompt asm (from-sp (slot tag)) escape? proc-slot
-                           receive-args)
-              (emit-j asm k)
-              (emit-label asm receive-args)
-              (unless (and rest (zero? nreq))
-                (emit-receive-values asm proc-slot (->bool rest) nreq))
-              (when (and rest
-                         (match (intmap-ref cps khandler-body)
-                           (($ $kargs names (_ ... rest))
-                            (maybe-slot rest))))
-                (emit-bind-rest asm (+ proc-slot 1 nreq)))
-              (for-each (match-lambda
-                          ((src . dst) (emit-fmov asm dst src)))
-                        (lookup-parallel-moves handler allocation))
-              (emit-reset-frame asm frame-size)
-              (emit-j asm (forward-label khandler-body))))))
         (($ $primcall 'cache-current-module! (scope) (mod))
          (emit-cache-current-module! asm (from-sp (slot mod)) scope))
         (($ $primcall 'scm-set! annotation (obj idx val))
@@ -428,6 +406,29 @@
         (($ $primcall 'throw/value+data param (val))
          (emit-throw/value+data asm (from-sp (slot val)) param))))
 
+    (define (compile-prompt label k kh escape? tag)
+      (match (intmap-ref cps kh)
+        (($ $kreceive ($ $arity req () rest () #f) khandler-body)
+         (let ((receive-args (gensym "handler"))
+               (nreq (length req))
+               (proc-slot (lookup-call-proc-slot label allocation)))
+           (emit-prompt asm (from-sp (slot tag)) escape? proc-slot
+                        receive-args)
+           (emit-j asm k)
+           (emit-label asm receive-args)
+           (unless (and rest (zero? nreq))
+             (emit-receive-values asm proc-slot (->bool rest) nreq))
+           (when (and rest
+                      (match (intmap-ref cps khandler-body)
+                        (($ $kargs names (_ ... rest))
+                         (maybe-slot rest))))
+             (emit-bind-rest asm (+ proc-slot 1 nreq)))
+           (for-each (match-lambda
+                      ((src . dst) (emit-fmov asm dst src)))
+                     (lookup-parallel-moves kh allocation))
+           (emit-reset-frame asm frame-size)
+           (emit-j asm (forward-label khandler-body))))))
+
     (define (compile-values label exp syms)
       (match exp
         (($ $values args)
@@ -627,7 +628,11 @@
            (emit-source asm src))
          (compile-test label (skip-elided-conts (1+ label))
                        (forward-label kf) (forward-label kt)
-                       op param args))))
+                       op param args))
+        (($ $prompt k kh src escape? tag)
+         (when src
+           (emit-source asm src))
+         (compile-prompt label (skip-elided-conts k) kh escape? tag))))
 
     (define (compile-cont label cont)
       (match cont

module/language/cps/contification.scm

@@ -60,12 +60,9 @@ predecessor."
       (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
       (($ $ktail) (ref0))
       (($ $kclause arity kbody kalt) (ref2 kbody kalt))
-      (($ $kargs names syms ($ $branch kf kt))
+      (($ $kargs names syms ($ $continue k)) (ref1 k))
-       (ref2 kf kt))
+      (($ $kargs names syms ($ $branch kf kt)) (ref2 kf kt))
-      (($ $kargs names syms ($ $continue k src exp))
+      (($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))))
-       (match exp
-         (($ $prompt escape-only? tag handler) (ref2 k handler))
-         (_ (ref1 k))))))
   (let*-values (((single multiple) (values empty-intset empty-intset))
                 ((single multiple) (intmap-fold add-ref conts single multiple)))
     (intset-subtract (persistent-intset single)
@@ -192,11 +189,11 @@ $call, and are always called with a compatible arity."
            (($ $callk k proc args)
             (exclude-vars functions (cons proc args)))
            (($ $primcall name param args)
-            (exclude-vars functions args))
+            (exclude-vars functions args))))
-           (($ $prompt escape? tag handler)
-            (exclude-var functions tag))))
         (($ $kargs _ _ ($ $branch kf kt src op param args))
          (exclude-vars functions args))
+        (($ $kargs _ _ ($ $prompt k kh src escape? tag))
+         (exclude-var functions tag))
         (_ functions)))
     (intmap-fold visit-cont conts functions)))
 
@@ -459,7 +456,7 @@ function set."
     (match term
       (($ $continue k src exp)
        (visit-exp cps k src exp))
-      (($ $branch)
+      ((or ($ $branch) ($ $prompt))
        (with-cps cps term))))
 
   ;; Renumbering is not strictly necessary but some passes may not be

module/language/cps/cse.scm

@@ -116,11 +116,9 @@ false.  It could be that both true and false proofs are available."
       (match (intmap-ref conts label)
         (($ $kargs names vars term)
          (match term
-           (($ $continue k src exp)
+           (($ $continue k) (propagate1 k))
-            (match exp
+           (($ $branch kf kt) (propagate-branch kf kt))
-              (($ $prompt escape? tag handler) (propagate2 k handler))
+           (($ $prompt k kh) (propagate2 k kh))))
-              (_ (propagate1 k))))
-           (($ $branch kf kt) (propagate-branch kf kt))))
         (($ $kreceive arity k)
          (propagate1 k))
         (($ $kfun src meta self tail clause)
@@ -168,7 +166,7 @@ false.  It could be that both true and false proofs are available."
                       (match (intmap-ref conts k)
                         (($ $kargs names vars) vars)
                         (_ #f)))
-                     (($ $branch)
+                     ((or ($ $branch) ($ $prompt))
                       '())))))
                (compute-function-body conts kfun)))
 
@@ -218,10 +216,10 @@ false.  It could be that both true and false proofs are available."
              (($ $callk k proc args) #f)
              (($ $primcall name param args)
               (cons* name param (subst-vars var-substs args)))
-             (($ $values args) #f)
+             (($ $values args) #f)))
-             (($ $prompt escape? tag handler) #f)))
           (($ $branch kf kt src op param args)
-           (cons* op param (subst-vars var-substs args)))))
+           (cons* op param (subst-vars var-substs args)))
+          (($ $prompt) #f)))
 
       (define (add-auxiliary-definitions! label var-substs term-key)
         (let ((defs (and=> (intmap-ref defs label)
@@ -377,9 +375,7 @@ false.  It could be that both true and false proofs are available."
       (($ $primcall name param args)
        ($primcall name param ,(map subst-var args)))
       (($ $values args)
-       ($values ,(map subst-var args)))
+       ($values ,(map subst-var args)))))
-      (($ $prompt escape? tag handler)
-       ($prompt escape? (subst-var tag) handler))))
 
   (define (visit-term label term)
     (match term
@@ -403,7 +399,10 @@ false.  It could be that both true and false proofs are available."
           (build-term ($continue k src ($values vars))))
          (#f
           (build-term
-            ($continue k src ,(visit-exp exp))))))))
+            ($continue k src ,(visit-exp exp))))))
+      (($ $prompt k kh src escape? tag)
+       (build-term
+         ($prompt k kh src escape? (subst-var tag))))))
 
   (intmap-map
    (lambda (label cont)

module/language/cps/dce.scm

@@ -84,6 +84,9 @@ sites."
                           ;; Branches pass no values to their
                           ;; continuations.
                           (values known unknown))
+                         (($ $kargs _ _ ($ $prompt))
+                          ;; Likewise for prompts.
+                          (values known unknown))
                          (($ $kreceive arity kargs)
                           (values known (intset-add! unknown kargs)))
                          (($ $kfun src meta self tail clause)
@@ -239,6 +242,11 @@ sites."
             (visit-exp label k exp live-labels live-vars))
            (($ $kargs _ _ ($ $branch kf kt src op param args))
             (visit-branch label kf kt args live-labels live-vars))
+           (($ $kargs _ _ ($ $prompt k kh src escape? tag))
+            ;; Prompts need special elision passes that would contify
+            ;; aborts and remove corresponding "unwind" primcalls.
+            (values (intset-add live-labels label)
+                    (adjoin-var tag live-vars)))
            (($ $kreceive arity kargs)
             (values live-labels live-vars))
            (($ $kclause arity kargs kalt)
@@ -346,7 +354,9 @@ sites."
            (values cps term)
            ;; Dead branches continue to the same continuation
            ;; (eventually).
-           (values cps (build-term ($continue kf src ($values ()))))))))
+           (values cps (build-term ($continue kf src ($values ()))))))
+      (($ $prompt)
+       (values cps term))))
   (define (visit-cont label cont cps)
     (match cont
       (($ $kargs names vars term)

module/language/cps/devirtualize-integers.scm

@@ -72,11 +72,11 @@
               (($ $callk kfun proc args)
                (add-uses (add-use use-counts proc) args))
               (($ $primcall name param args)
-               (add-uses use-counts args))
+               (add-uses use-counts args))))
-              (($ $prompt escape? tag handler)
-               (add-use use-counts tag))))
            (($ $branch kf kt src op param args)
-            (add-uses use-counts args))))
+            (add-uses use-counts args))
+           (($ $prompt k kh src escape? tag)
+            (add-use use-counts tag))))
         (_ use-counts)))
     cps
     (transient-intmap))))

module/language/cps/effects-analysis.scm

@@ -596,11 +596,6 @@ the LABELS that are clobbered by the effects of LABEL."
      &no-effects)
     ((or ($ $fun) ($ $rec) ($ $closure))
      (&allocate &unknown-memory-kinds))
-    (($ $prompt)
-     ;; Although the "main" path just writes &prompt, we don't know what
-     ;; nonlocal predecessors of the handler do, so we conservatively
-     ;; assume &all-effects.
-     &all-effects)
     ((or ($ $call) ($ $callk))
      &all-effects)
     (($ $primcall name param args)
@@ -614,6 +609,11 @@ the LABELS that are clobbered by the effects of LABEL."
         (expression-effects exp))
        (($ $kargs names syms ($ $branch kf kt src op param args))
         (primitive-effects param op args))
+       (($ $kargs names syms ($ $prompt))
+        ;; Although the "main" path just writes &prompt, we don't know
+        ;; what nonlocal predecessors of the handler do, so we
+        ;; conservatively assume &all-effects.
+        &all-effects)
        (($ $kreceive arity kargs)
         (match arity
           (($ $arity _ () #f () #f) &type-check)

module/language/cps/licm.scm

@@ -68,7 +68,6 @@
                       loop-effects #t))
      (match exp
        ((or ($ $const) ($ $prim) ($ $closure)) #t)
-       (($ $prompt) #f) ;; ?
        (($ $primcall name param args)
         (and-map (lambda (arg) (not (intset-ref loop-vars arg)))
                  args))
@@ -137,14 +136,6 @@
               ((not (loop-invariant? label exp loop-vars loop-effects
                                      always-reached?))
                (let* ((loop-vars (adjoin-loop-vars loop-vars def-vars))
-                      (loop-vars (match exp
-                                   (($ $prompt escape? tag handler)
-                                    (match (intmap-ref cps handler)
-                                      (($ $kreceive arity kargs)
-                                       (match (intmap-ref cps kargs)
-                                         (($ $kargs names vars)
-                                          (adjoin-loop-vars loop-vars vars))))))
-                                   (_ loop-vars)))
                       (cont (build-cont
                               ($kargs names vars
                                 ($continue k src ,exp))))
@@ -216,6 +207,16 @@
          (($ $branch)
           (let* ((cont (build-cont ($kargs names vars ,term)))
                  (always-reached? #f))
+            (values cps cont loop-vars loop-effects
+                    pre-header-label always-reached?)))
+         (($ $prompt k kh src escape? tag)
+          (let* ((loop-vars (match (intmap-ref cps kh)
+                              (($ $kreceive arity kargs)
+                               (match (intmap-ref cps kargs)
+                                 (($ $kargs names vars)
+                                  (adjoin-loop-vars loop-vars vars))))))
+                 (cont (build-cont ($kargs names vars ,term)))
+                 (always-reached? #f))
             (values cps cont loop-vars loop-effects
                     pre-header-label always-reached?))))))
     (($ $kreceive ($ $arity req () rest) kargs)
@@ -259,6 +260,9 @@
         (($ $kargs names vars ($ $branch kf kt src op param args))
          ($kargs names vars
            ($branch (rename kf) (rename kt) src op param args)))
+        (($ $kargs names vars ($ $prompt k kh src escape? tag))
+         ($kargs names vars
+           ($prompt (rename k) (rename kh) src escape? tag)))
         (($ $kargs names vars ($ $continue k src exp))
          ($kargs names vars
            ($continue (rename k) src ,exp)))

module/language/cps/peel-loops.scm

@@ -142,16 +142,17 @@
       (($ $callk k proc args)
        ($callk k (rename-var proc) ,(map rename-var args)))
       (($ $primcall name param args)
-       ($primcall name param ,(map rename-var args)))
+       ($primcall name param ,(map rename-var args)))))
-      (($ $prompt escape? tag handler)
-       ($prompt escape? (rename-var tag) (rename-label handler)))))
   (define (rename-term term)
     (rewrite-term term
       (($ $continue k src exp)
        ($continue (rename-label k) src ,(rename-exp exp)))
       (($ $branch kf kt src op param args)
        ($branch (rename-label kf) (rename-label kt) src
-         op param ,(map rename-var args)))))
+         op param ,(map rename-var args)))
+      (($ $prompt k kh src escape? tag)
+       ($prompt (rename-label k) (rename-label kh) src
+         escape? (rename-var tag)))))
   (rewrite-cont cont
     (($ $kargs names vars term)
      ($kargs names (map rename-var vars) ,(rename-term term)))

module/language/cps/renumber.scm

@@ -87,16 +87,14 @@
                   (match (intmap-ref conts k)
                     (($ $kargs names syms term)
                      (match term
-                       (($ $continue k src exp)
+                       (($ $continue k)
-                        (match exp
+                        (visit k order visited))
-                          (($ $prompt escape? tag handler)
-                           (visit2 k handler order visited))
-                          (_
-                           (visit k order visited))))
                        (($ $branch kf kt)
                         (if (visit-kf-first? kf kt)
                             (visit2 kf kt order visited)
-                            (visit2 kt kf order visited)))))
+                            (visit2 kt kf order visited)))
+                       (($ $prompt k kh)
+                        (visit2 k kh order visited))))
                     (($ $kreceive arity k) (visit k order visited))
                     (($ $kclause arity kbody kalt)
                      (if kalt
@@ -180,9 +178,7 @@
         (($ $callk k proc args)
          ($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
         (($ $primcall name param args)
-         ($primcall name param ,(map rename-var args)))
+         ($primcall name param ,(map rename-var args)))))
-        (($ $prompt escape? tag handler)
-         ($prompt escape? (rename-var tag) (rename-label handler)))))
     (define (rename-arity arity)
       (match arity
         (($ $arity req opt rest () aok?)
@@ -207,7 +203,10 @@
                   ($continue (rename-label k) src ,(rename-exp exp)))
                  (($ $branch kf kt src op param args)
                   ($branch (rename-label kf) (rename-label kt) src
-                    op param ,(map rename-var args))))))
+                    op param ,(map rename-var args)))
+                 (($ $prompt k kh src escape? tag)
+                  ($prompt (rename-label k) (rename-label kh) src
+                    escape? (rename-var tag))))))
            (($ $kreceive ($ $arity req () rest () #f) k)
             ($kreceive req rest (rename-label k)))
            (($ $ktail)

module/language/cps/rotate-loops.scm

@@ -118,11 +118,11 @@ corresponding var from REPLACEMENTS; otherwise return VAR."
                  (($ $callk k proc args)
                   ($callk k (rename proc) ,(rename* args)))
                  (($ $primcall name param args)
-                  ($primcall name param ,(rename* args)))
+                  ($primcall name param ,(rename* args))))))
-                 (($ $prompt escape? tag handler)
-                  ($prompt escape? (rename tag) handler)))))
            (($ $branch kf kt src op param args)
-            ($branch kf kt src op param ,(rename* args)))))
+            ($branch kf kt src op param ,(rename* args)))
+           (($ $prompt k kh src escape? tag)
+            ($prompt k kh src escape? (rename tag)))))
        (define (attach-trampoline cps label src names vars args)
          (with-cps cps
            (letk ktramp-out ,(make-trampoline join-label src args))
@@ -211,7 +211,7 @@ corresponding var from REPLACEMENTS; otherwise return VAR."
                          (trivial-intset (loop-successors scc succs))
                          (match (intmap-ref cps entry)
                            ;; Can't rotate $prompt out of loop header.
-                           (($ $kargs _ _ ($ $continue _ _ ($ $prompt))) #f)
+                           (($ $kargs _ _ ($ $prompt)) #f)
                            (_ #t)))
                     ;; Loop header is an exit, and there is only one
                     ;; exit continuation.  Loop header isn't a prompt,

module/language/cps/self-references.scm

@@ -46,16 +46,16 @@
       (($ $primcall name param args)
        ($primcall name param ,(map subst args)))
       (($ $values args)
-       ($values ,(map subst args)))
+       ($values ,(map subst args)))))
-      (($ $prompt escape? tag handler)
-       ($prompt escape? (subst tag) handler))))
 
   (define (rename-term term)
     (rewrite-term term
       (($ $continue k src exp)
        ($continue k src ,(rename-exp exp)))
       (($ $branch kf kt src op param args)
-       ($branch kf kt src op param ,(map subst args)))))
+       ($branch kf kt src op param ,(map subst args)))
+      (($ $prompt k kh src escape? tag)
+       ($prompt k kh src escape? (subst tag)))))
 
   (define (visit-label label cps)
     (match (intmap-ref cps label)

module/language/cps/simplify.scm

@@ -77,11 +77,11 @@
          (($ $primcall name param args)
           (ref* args))
          (($ $values args)
-          (ref* args))
+          (ref* args))))
-         (($ $prompt escape? tag handler)
-          (ref tag))))
       (($ $kargs _ _ ($ $branch kf kt src op param args))
        (ref* args))
+      (($ $kargs _ _ ($ $prompt k kh src escape? tag))
+       (ref tag))
       (_
        (values single multiple))))
   (let*-values (((single multiple) (values empty-intset empty-intset))
@@ -188,12 +188,9 @@
       (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
       (($ $ktail) (ref0))
       (($ $kclause arity kbody kalt) (ref2 kbody kalt))
-      (($ $kargs names syms ($ $continue k src exp))
+      (($ $kargs names syms ($ $continue k)) (ref1 k))
-       (match exp
+      (($ $kargs names syms ($ $branch kf kt)) (ref2 kf kt))
-         (($ $prompt _ _ handler) (ref2 k handler))
+      (($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))))
-         (_ (ref1 k))))
-      (($ $kargs names syms ($ $branch kf kt))
-       (ref2 kf kt))))
   (let*-values (((single multiple) (values empty-intset empty-intset))
                 ((single multiple) (intset-fold add-ref body single multiple)))
     (intset-subtract (persistent-intset single)
@@ -259,11 +256,11 @@
                   (($ $primcall name param args)
                    ($primcall name param ,(map subst args)))
                   (($ $values args)
-                   ($values ,(map subst args)))
+                   ($values ,(map subst args))))))
-                  (($ $prompt escape? tag handler)
-                   ($prompt escape? (subst tag) handler)))))
             (($ $branch kf kt src op param args)
-             ($branch kf kt src op param ,(map subst args))))))
+             ($branch kf kt src op param ,(map subst args)))
+            (($ $prompt k kh src escape? tag)
+             ($prompt k kh src escape? (subst tag))))))
     (transform-conts
      (lambda (label cont)
        (rewrite-cont cont

module/language/cps/slot-allocation.scm

@@ -57,7 +57,7 @@
   (representations allocation-representations)
 
   ;; A map of LABEL to /call allocs/, for expressions that continue to
-  ;; $kreceive continuations: non-tail calls and $prompt expressions.
+  ;; $kreceive continuations: non-tail calls and $prompt terms.
   ;;
   ;; A call alloc contains two pieces of information: the call's /proc
   ;; slot/ and a /dead slot map/.  The proc slot indicates the slot of a
@@ -155,11 +155,11 @@ by a label, respectively."
            (($ $primcall name param args)
             (return (get-defs k) (vars->intset args)))
            (($ $values args)
-            (return (get-defs k) (vars->intset args)))
+            (return (get-defs k) (vars->intset args)))))
-           (($ $prompt escape? tag handler)
-            (return empty-intset (intset tag)))))
         (($ $kargs _ _ ($ $branch kf kt src op param args))
          (return empty-intset (vars->intset args)))
+        (($ $kargs _ _ ($ $prompt k kh src escape? tag))
+         (return empty-intset (intset tag)))
         (($ $kclause arity body alt)
          (return (get-defs body) empty-intset))
         (($ $kreceive arity kargs)
@@ -231,11 +231,10 @@ body continuation in the prompt."
             (let ((labels (intset-add! labels label)))
               (match cont
                 (($ $kreceive arity k) (visit-cont k level labels))
+                (($ $kargs names syms ($ $prompt k kh src escape? tag))
+                 (visit-cont kh level (visit-cont k (1+ level) labels)))
                 (($ $kargs names syms ($ $continue k src ($ $primcall 'wind)))
                  (visit-cont k (1+ level) labels))
-                (($ $kargs names syms
-                           ($ $continue k src ($ $prompt escape? tag handler)))
-                 (visit-cont handler level (visit-cont k (1+ level) labels)))
                 (($ $kargs names syms ($ $continue k src ($ $primcall 'unwind)))
                  (visit-cont k (1- level) labels))
                 (($ $kargs names syms ($ $continue k src exp))
@@ -261,9 +260,8 @@ body continuation in the prompt."
   (intmap-fold
    (lambda (label cont succs)
      (match cont
-       (($ $kargs _ _
+       (($ $kargs _ _ ($ $prompt k kh))
-           ($ $continue k _ ($ $prompt escape? tag handler)))
+        (visit-prompt k kh succs))
-        (visit-prompt k handler succs))
        (_ succs)))
    conts
    succs))
@@ -596,9 +594,9 @@ are comparable with eqv?.  A tmp slot may be used."
           (add-call-shuffles label k (cons proc args) shuffles))
          (($ $values args)
           (add-values-shuffles label k args shuffles))
-         (($ $prompt escape? tag handler)
-          (add-prompt-shuffles label k handler shuffles))
          (_ shuffles)))
+      (($ $kargs names vars ($ $prompt k kh src escape? tag))
+       (add-prompt-shuffles label k kh shuffles))
       (_ shuffles)))
 
   (persistent-intmap
@@ -746,6 +744,8 @@ are comparable with eqv?.  A tmp slot may be used."
      (match cont
        (($ $kargs _ _ ($ $branch))
         representations)
+       (($ $kargs _ _ ($ $prompt))
+        representations)
        (($ $kargs _ _ ($ $continue k _ exp))
         (match (get-defs k)
           (() representations)
@@ -981,8 +981,8 @@ are comparable with eqv?.  A tmp slot may be used."
               (allocate-call label k (cons proc args) slots call-allocs live))
              (($ $continue k src ($ $values args))
               (allocate-values label k args slots call-allocs))
-             (($ $continue k src ($ $prompt escape? tag handler))
+             (($ $prompt k kh src escape? tag)
-              (allocate-prompt label k handler slots call-allocs))
+              (allocate-prompt label k kh slots call-allocs))
              (_
               (values slots call-allocs)))))
         (_

module/language/cps/specialize-numbers.scm

@@ -335,11 +335,11 @@ BITS indicating the significant bits needed for a variable.  BITS may be
                              (match (intmap-ref cps k)
                                (($ $kargs _ defs)
                                 (h label types out param args defs)))
-                             (add-unknown-uses out args))))
+                             (add-unknown-uses out args))))))
-                      (($ $prompt escape? tag handler)
-                       (add-unknown-use out tag))))
                    (($ $branch kf kt src op param args)
-                    (add-unknown-uses out args)))))
+                    (add-unknown-uses out args))
+                   (($ $prompt k kh src escape? tag)
+                    (add-unknown-use out tag)))))
               (_ out)))))))))
 
 (define (specialize-operations cps)

module/language/cps/split-rec.scm

@@ -90,11 +90,11 @@ references."
                         (($ $call proc args)
                          (add-use proc (add-uses args uses)))
                         (($ $primcall name param args)
-                         (add-uses args uses))
+                         (add-uses args uses))))
-                        (($ $prompt escape? tag handler)
-                         (add-use tag uses))))
                      (($ $branch kf kt src op param args)
-                      (add-uses args uses)))))
+                      (add-uses args uses))
+                     (($ $prompt k kh src escape? tag)
+                      (add-use tag uses)))))
                  (($ $kfun src meta self)
                   (values (add-def self defs) uses))
                  (_ (values defs uses))))

module/language/cps/types.scm

@@ -1775,11 +1775,9 @@ minimum, and maximum."
 
 (define (successor-count cont)
   (match cont
-    (($ $kargs _ _ ($ $continue k src exp))
+    (($ $kargs _ _ ($ $continue)) 1)
-     (match exp
-       (($ $prompt) 2)
-       (_ 1)))
     (($ $kargs _ _ ($ $branch)) 2)
+    (($ $kargs _ _ ($ $prompt)) 2)
     (($ $kfun src meta self tail clause) (if clause 1 0))
     (($ $kclause arity body alt) (if alt 2 1))
     (($ $kreceive) 1)
@@ -1916,9 +1914,6 @@ maximum, where type is a bitset as a fixnum."
         (values (append changed0 changed1) typev)))
     ;; Each of these branches must propagate to its successors.
     (match exp
-      (($ $prompt escape? tag handler)
-       ;; The "normal" continuation enters the prompt.
-       (propagate2 k types handler types))
       (($ $primcall name param args)
        (propagate1 k
                    (match (intmap-ref conts k)
@@ -1979,6 +1974,9 @@ maximum, where type is a bitset as a fixnum."
          ;; The "normal" continuation is the #f branch.
          (propagate2 kf (infer-primcall types 0 op param args #f)
                      kt (infer-primcall types 1 op param args #f)))
+        (($ $kargs names vars ($ $prompt k kh src escape? tag))
+         ;; The "normal" continuation enters the prompt.
+         (propagate2 k types kh types))
         (($ $kreceive arity k)
          (match (intmap-ref conts k)
            (($ $kargs names vars)

module/language/cps/utils.scm

@@ -200,12 +200,12 @@ disjoint, an error will be signalled."
                 (visit-cont kbody labels)))
            (($ $kargs names syms term)
             (match term
-              (($ $continue k src ($ $prompt escape? tag handler))
-               (visit-cont k (visit-cont handler labels)))
               (($ $continue k)
                (visit-cont k labels))
               (($ $branch kf kt)
-               (visit-cont kf (visit-cont kt labels))))))))))))
+               (visit-cont kf (visit-cont kt labels)))
+              (($ $prompt k kh)
+               (visit-cont k (visit-cont kh labels))))))))))))
 
 (define* (compute-reachable-functions conts #:optional (kfun 0))
   "Compute a mapping LABEL->LABEL..., where each key is a reachable
@@ -260,11 +260,9 @@ intset."
           (match (intmap-ref conts label)
             (($ $kargs names vars term)
              (match term
-               (($ $continue k src exp)
+               (($ $continue k) (propagate1 k))
-                (match exp
+               (($ $branch kf kt) (propagate2 kf kt))
-                  (($ $prompt escape? tag handler) (propagate2 k handler))
+               (($ $prompt k kh) (propagate2 k kh))))
-                  (_ (propagate1 k))))
-               (($ $branch kf kt) (propagate2 kf kt))))
             (($ $kreceive arity k)
              (propagate1 k))
             (($ $kfun src meta self tail clause)
@@ -296,13 +294,9 @@ intset."
        (add-pred kbody (if kalt (add-pred kalt preds) preds)))
       (($ $kargs names syms term)
        (match term
-         (($ $continue k src exp)
+         (($ $continue k)   (add-pred k preds))
-          (add-pred k
+         (($ $branch kf kt) (add-pred kf (add-pred kt preds)))
-                    (match exp
+         (($ $prompt k kh)  (add-pred k (add-pred kh preds)))))))
-                      (($ $prompt _ _ k) (add-pred k preds))
-                      (_ preds))))
-         (($ $branch kf kt)
-          (add-pred kf (add-pred kt preds)))))))
   (persistent-intmap
    (intset-fold add-preds labels
                 (intset->intmap (lambda (label) '()) labels))))

module/language/cps/verify.scm

@@ -102,12 +102,12 @@ definitions that are available at LABEL."
         (($ $kargs names vars term)
          (let ((out (fold1 adjoin-def vars in)))
            (match term
-             (($ $continue k src exp)
+             (($ $continue k)
-              (match exp
+              (propagate1 k out))
-                (($ $prompt escape? tag handler) (propagate2 k handler out))
-                (_ (propagate1 k out))))
              (($ $branch kf kt)
-              (propagate2 kf kt out)))))
+              (propagate2 kf kt out))
+             (($ $prompt k kh)
+              (propagate2 k kh out)))))
         (($ $kreceive arity k)
          (propagate1 k in))
         (($ $kfun src meta self tail clause)
@@ -164,9 +164,6 @@ definitions that are available at LABEL."
          (visit-first-order kfun))
         (($ $primcall name param args)
          (for-each check-use args)
-         first-order)
-        (($ $prompt escape? tag handler)
-         (check-use tag)
          first-order)))
     (define (visit-term term bound first-order)
       (define (check-use var)
@@ -203,12 +200,12 @@ definitions that are available at LABEL."
             (visit-first-order kfun))
            (($ $primcall name param args)
             (for-each check-use args)
-            first-order)
-           (($ $prompt escape? tag handler)
-            (check-use tag)
             first-order)))
         (($ $branch kf kt src name param args)
          (for-each check-use args)
+         first-order)
+        (($ $prompt k kh src escape? tag)
+         (check-use tag)
          first-order)))
     (intmap-fold
      (lambda (label bound first-order)
@@ -285,12 +282,7 @@ definitions that are available at LABEL."
          (($ $kreceive) #t)
          (($ $ktail)
           (unless (memv name '(throw throw/value throw/value+data))
-            (error "primitive should continue to $kargs, not $ktail" name)))))
+            (error "primitive should continue to $kargs, not $ktail" name)))))))
-      (($ $prompt escape? tag handler)
-       (assert-nullary)
-       (match (intmap-ref conts handler)
-         (($ $kreceive) #t)
-         (cont (error "bad handler" cont))))))
   (define (check-term term)
     (match term
       (($ $continue k src exp)
@@ -301,7 +293,14 @@ definitions that are available at LABEL."
          (cont (error "bad kf" cont)))
        (match (intmap-ref conts kt)
          (($ $kargs () ()) #t)
-         (cont (error "bad kt" cont))))))
+         (cont (error "bad kt" cont))))
+      (($ $prompt k kh src escape? tag)
+       (match (intmap-ref conts k)
+         (($ $kargs () ()) #t)
+         (cont (error "bad prompt body" cont)))
+       (match (intmap-ref conts kh)
+         (($ $kreceive) #t)
+         (cont (error "bad prompt handler" cont))))))
   (let ((reachable (compute-reachable-labels conts kfun)))
     (intmap-for-each
      (lambda (label cont)

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

@@ -853,7 +853,7 @@
                  (with-cps cps
                    (let$ body (convert body krest subst))
                    (letk kbody ($kargs () () ,body))
-                   (build-term ($continue kbody src ($prompt #t tag khargs))))
+                   (build-term ($prompt kbody khargs src #t tag)))
                  (convert-arg cps body
                    (lambda (cps thunk)
                      (with-cps cps
@@ -861,8 +861,8 @@
                                      ($continue krest (tree-il-src body)
                                        ($primcall 'call-thunk/no-inline #f
                                                   (thunk)))))
-                       (build-term ($continue kbody (tree-il-src body)
+                       (build-term ($prompt kbody khargs (tree-il-src body)
-                                     ($prompt #f tag khargs))))))))
+                                     #f tag)))))))
            (with-cps cps
              (letv prim vals apply)
              (let$ hbody (convert hbody k subst))