Add $branch expression type

[bpt/guile.git] / module / language / cps / dce.scm

diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 5f5e58c..1318a81 100644 (file)
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -66,7 +66,10 @@
          (match (lookup-cont (idx->label n) dfg)
            (($ $kargs _ _ body)
             (match (find-call body)
-              (($ $continue k) (cont-defs k))))
+              (($ $continue k src exp)
+               (match exp
+                 (($ $branch) #f)
+                 (_ (cont-defs k))))))
            (($ $kreceive arity kargs)
             (cont-defs kargs))
            (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
@@ -84,6 +87,13 @@
       (let ((typev (infer-types fun dfg)))
         (define (idx->label idx) (+ idx min-label))
         (define (var->idx var) (- var min-var))
+        (define (visit-primcall lidx fx name args)
+          (let ((args (map var->idx args)))
+            ;; Negative args are closure variables.
+            (unless (or-map negative? args)
+              (when (primcall-types-check? lidx typev name args)
+                (vector-set! effects lidx
+                             (logand fx (lognot &type-check)))))))
         (let lp ((lidx 0))
           (when (< lidx label-count)
             (let ((fx (vector-ref effects lidx)))
@@ -93,12 +103,9 @@
                     (($ $kargs _ _ term)
                      (match (find-call term)
                        (($ $continue k src ($ $primcall name args))
-                        (let ((args (map var->idx args)))
-                          ;; Negative args are closure variables.
-                          (unless (or-map negative? args)
-                            (when (primcall-types-check? lidx typev name args)
-                              (vector-set! effects lidx
-                                           (logand fx (lognot &type-check)))))))
+                        (visit-primcall lidx fx name args))
+                       (($ $continue k src ($ $branch _ ($primcall name args)))
+                        (visit-primcall lidx fx name args))
                        (_ #f)))
                     (_ #f)))))
             (lp (1+ lidx)))))))))
@@ -217,6 +224,10 @@
                             (for-each mark-live! args))
                            (($ $primcall name args)
                             (for-each mark-live! args))
+                           (($ $branch k ($ $primcall name args))
+                            (for-each mark-live! args))
+                           (($ $branch k ($ $values (arg)))
+                            (mark-live! arg))
                            (($ $values args)
                             (match (vector-ref defs n)
                               (#f (for-each mark-live! args))