[Guile-commits] 07/08: Simplify prompt slot allocation now that bailouts can't continue

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 824864996695be239a725cd8b0d5548d23bc6118
Author: Andy Wingo <address@hidden>
Date:   Wed Jan 3 18:30:13 2018 +0100

    Simplify prompt slot allocation now that bailouts can't continue
    
    * module/language/cps/slot-allocation.scm (add-prompt-control-flow-edges):
      Simplify now that bailouts don't continue.
---
 module/language/cps/slot-allocation.scm | 35 +++++++++++++--------------------
 1 file changed, 14 insertions(+), 21 deletions(-)

diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index d74b20d..b3bf19e 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -224,27 +224,20 @@ body continuation in the prompt."
         ((zero? level) labels)
         ((intset-ref labels label) labels)
         (else
-         (match (intmap-ref conts label)
-           ;; fixme: remove me?
-           (($ $ktail)
-            ;; Possible for bailouts; never reached and not part of
-            ;; prompt body.
-            labels)
-           (cont
-            (let ((labels (intset-add! labels label)))
-              (match cont
-                (($ $kreceive arity k) (visit-cont k level labels))
-                (($ $kargs names syms ($ $continue k src ($ $primcall 'wind)))
-                 (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))
-                 (visit-cont k level labels))
-                (($ $kargs names syms ($ $branch kf kt))
-                 (visit-cont kf level (visit-cont kt level labels)))
-                (($ $kargs names syms ($ $prompt k kh src escape? tag))
-                 (visit-cont kh level (visit-cont k (1+ level) labels)))
-                (($ $kargs names syms ($ $throw)) labels))))))))))
+         (let ((labels (intset-add! labels label)))
+           (match (intmap-ref conts label)
+             (($ $kreceive arity k) (visit-cont k level labels))
+             (($ $kargs names syms ($ $continue k src ($ $primcall 'wind)))
+              (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))
+              (visit-cont k level labels))
+             (($ $kargs names syms ($ $branch kf kt))
+              (visit-cont kf level (visit-cont kt level labels)))
+             (($ $kargs names syms ($ $prompt k kh src escape? tag))
+              (visit-cont kh level (visit-cont k (1+ level) labels)))
+             (($ $kargs names syms ($ $throw)) labels))))))))
   (define (visit-prompt label handler succs)
     (let ((body (compute-prompt-body label)))
       (define (out-or-back-edge? label)