DFG refactor to allow dominator tree construction

* module/language/cps/dfg.scm: Refactor so that we can think about
  building a dominator tree.  Split continuations out of use maps and
  put them in a separate table, which will have more flow information.
  (visit-fun): Mark clauses as using their bodies.
  (lookup-predecessors, lookup-successors): New exports.
  (find-defining-expression): Add an exception for clauses, now that
  clauses are in the flow graph.
  (continuation-bound-in?): Rename from variable-bound-in?, as it can
  currently only be used for continuations.

* module/language/cps/contification.scm (contify): Adapt to use
  lookup-predecessors and continuation-bound-in?.

module/language/cps/contification.scm

@@ -90,7 +90,7 @@
     (define (bound-symbol k)
       (match (lookup-cont k cont-table)
         (($ $kargs (_) (sym))
-         (match (lookup-uses k dfg)
+         (match (lookup-predecessors k dfg)
            ((_)
             ;; K has one predecessor, the one that defined SYM.
             sym)
@@ -148,7 +148,7 @@
                 ;; We have a common continuation.  High fives!
                 ;;
                 ;; (1) Find the scope at which to contify.
-                (let ((scope (if (variable-bound-in? k term-k dfg)
+                (let ((scope (if (continuation-bound-in? k term-k dfg)
                                  term-k
                                  (lookup-def k dfg))))
                   ;; (2) Mark all SYMs for replacement in calls, and

module/language/cps/dfg.scm

@@ -21,7 +21,7 @@
 ;;; Many passes rely on a local or global static analysis of a function.
 ;;; This module implements a simple data-flow graph (DFG) analysis,
 ;;; tracking the definitions and uses of variables and continuations.
-;;; It also builds a table of continuations and parent links, to be able
+;;; It also builds a table of continuations and scope links, to be able
 ;;; to easily determine if one continuation is in the scope of another,
 ;;; and to get to the expression inside a continuation.
 ;;;
@@ -48,13 +48,15 @@
             dfg-cont-table
             lookup-def
             lookup-uses
+            lookup-predecessors
+            lookup-successors
             find-call
             call-expression
             find-expression
             find-defining-expression
             find-constant-value
             lift-definition!
-            variable-bound-in?
+            continuation-bound-in?
             variable-free-in?
             constant-needs-allocation?
             dead-after-def?
@@ -86,14 +88,14 @@
 
 ;; Data-flow graph for CPS: both for values and continuations.
 (define-record-type $dfg
-  (make-dfg conts use-maps uplinks)
+  (make-dfg conts blocks use-maps)
   dfg?
-  ;; hash table of sym -> $kargs, $kif, etc
+  ;; hash table of sym -> $kif, $kargs, etc
   (conts dfg-cont-table)
+  ;; hash table of sym -> $block
+  (blocks dfg-blocks)
   ;; hash table of sym -> $use-map
-  (use-maps dfg-use-maps)
+  (use-maps dfg-use-maps))
-  ;; hash table of sym -> $parent-link
-  (uplinks dfg-uplinks))
 
 (define-record-type $use-map
   (make-use-map sym def uses)
@@ -102,13 +104,21 @@
   (def use-map-def)
   (uses use-map-uses set-use-map-uses!))
 
-(define-record-type $uplink
+(define-record-type $block
-  (make-uplink parent level)
+  (%make-block scope scope-level preds succs idom dom-level loop-header)
-  uplink?
+  block?
-  (parent uplink-parent)
+  (scope block-scope set-block-scope!)
-  (level uplink-level))
+  (scope-level block-scope-level set-block-scope-level!)
+  (preds block-preds set-block-preds!)
+  (succs block-succs set-block-succs!)
+  (idom block-idom set-block-idom!)
+  (dom-level block-dom-level set-block-dom-level!)
+  (loop-header block-loop-header set-block-loop-header!))
 
-(define (visit-fun fun conts use-maps uplinks global?)
+(define (make-block scope scope-level)
+  (%make-block scope scope-level '() '() #f #f #f))
+
+(define (visit-fun fun conts blocks use-maps global?)
   (define (add-def! sym def-k)
     (unless def-k
       (error "Term outside labelled continuation?"))
@@ -120,25 +130,34 @@
       ((and use-map ($ $use-map sym def uses))
        (set-use-map-uses! use-map (cons use-k uses)))))
 
-  (define (link-parent! k parent)
+  (define* (declare-block! label cont parent
-    (match (hashq-ref uplinks parent)
+                           #:optional (level
-      (($ $uplink _ level)
+                                       (1+ (lookup-scope-level parent blocks))))
-       (hashq-set! uplinks k (make-uplink parent (1+ level))))))
+    (hashq-set! conts label cont)
+    (hashq-set! blocks label (make-block parent level)))
+
+  (define (link-blocks! pred succ)
+    (let ((pred-block (hashq-ref blocks pred))
+          (succ-block (hashq-ref blocks succ)))
+      (unless (and pred-block succ-block)
+        (error "internal error"))
+      (set-block-succs! pred-block (cons succ (block-succs pred-block)))
+      (set-block-preds! succ-block (cons pred (block-preds succ-block)))))
 
   (define (visit exp exp-k)
     (define (def! sym)
       (add-def! sym exp-k))
     (define (use! sym)
       (add-use! sym exp-k))
+    (define (use-k! sym)
+      (link-blocks! exp-k sym))
     (define (recur exp)
       (visit exp exp-k))
     (match exp
       (($ $letk (($ $cont k src cont) ...) body)
        ;; Set up recursive environment before visiting cont bodies.
        (for-each (lambda (cont k)
-                   (def! k)
+                   (declare-block! k cont exp-k))
-                   (hashq-set! conts k cont)
-                   (link-parent! k exp-k))
                  cont k)
        (for-each visit cont k)
        (recur body))
@@ -148,21 +167,21 @@
        (recur body))
 
       (($ $kif kt kf)
-       (use! kt)
+       (use-k! kt)
-       (use! kf))
+       (use-k! kf))
 
       (($ $ktrunc arity k)
-       (use! k))
+       (use-k! k))
 
       (($ $letrec names syms funs body)
        (unless global?
          (error "$letrec should not be present when building a local DFG"))
        (for-each def! syms)
-       (for-each (cut visit-fun <> conts use-maps uplinks global?) funs)
+       (for-each (cut visit-fun <> conts blocks use-maps global?) funs)
        (visit body exp-k))
 
       (($ $continue k exp)
-       (use! k)
+       (use-k! k)
        (match exp
          (($ $var sym)
           (use! sym))
@@ -179,11 +198,11 @@
 
          (($ $prompt escape? tag handler)
           (use! tag)
-          (use! handler))
+          (use-k! handler))
 
          (($ $fun)
           (when global?
-            (visit-fun exp conts use-maps uplinks global?)))
+            (visit-fun exp conts blocks use-maps global?)))
 
          (_ #f)))))
 
@@ -192,44 +211,45 @@
         ($ $cont kentry src
            (and entry
                 ($ $kentry self ($ $cont ktail _ tail) clauses))))
-     ;; Treat the fun continuation as its own parent.
+     (declare-block! kentry entry #f 0)
-     (add-def! kentry kentry)
      (add-def! self kentry)
-     (hashq-set! uplinks kentry (make-uplink #f 0))
-     (hashq-set! conts kentry entry)
 
-     (add-def! ktail kentry)
+     (declare-block! ktail tail kentry)
-     (hashq-set! conts ktail tail)
-     (link-parent! ktail kentry)
 
      (for-each
       (match-lambda
        (($ $cont kclause _
            (and clause ($ $kclause arity ($ $cont kbody _ body))))
-        (add-def! kclause kentry)
+        (declare-block! kclause clause kentry)
-        (hashq-set! conts kclause clause)
+        (link-blocks! kentry kclause)
-        (link-parent! kclause kentry)
 
-        (add-def! kbody kclause)
+        (declare-block! kbody body kclause)
-        (hashq-set! conts kbody body)
+        (link-blocks! kclause kbody)
-        (link-parent! kbody kclause)
 
         (visit body kbody)))
+
+      #;
+      (compute-dominator-tree kentry use-maps dnodes)
+
       clauses))))
 
 (define* (compute-dfg fun #:key (global? #t))
   (let* ((conts (make-hash-table))
-         (use-maps (make-hash-table))
+         (blocks (make-hash-table))
-         (uplinks (make-hash-table)))
+         (use-maps (make-hash-table)))
-    (visit-fun fun conts use-maps uplinks global?)
+    (visit-fun fun conts blocks use-maps global?)
-    (make-dfg conts use-maps uplinks)))
+    (make-dfg conts blocks use-maps)))
 
-(define (lookup-uplink k uplinks)
+(define (lookup-block k blocks)
-  (let ((res (hashq-ref uplinks k)))
+  (let ((res (hashq-ref blocks k)))
     (unless res
-      (error "Unknown continuation!" k (hash-fold acons '() uplinks)))
+      (error "Unknown continuation!" k (hash-fold acons '() blocks)))
     res))
 
+(define (lookup-scope-level k blocks)
+  (match (lookup-block k blocks)
+    (($ $block _ scope-level) scope-level)))
+
 (define (lookup-use-map sym use-maps)
   (let ((res (hashq-ref use-maps sym)))
     (unless res
@@ -238,20 +258,28 @@
 
 (define (lookup-def sym dfg)
   (match dfg
-    (($ $dfg conts use-maps uplinks)
+    (($ $dfg conts blocks use-maps)
      (match (lookup-use-map sym use-maps)
        (($ $use-map sym def uses)
         def)))))
 
 (define (lookup-uses sym dfg)
   (match dfg
-    (($ $dfg conts use-maps uplinks)
+    (($ $dfg conts blocks use-maps)
      (match (lookup-use-map sym use-maps)
        (($ $use-map sym def uses)
         uses)))))
 
+(define (lookup-predecessors k dfg)
+  (match (lookup-block k (dfg-blocks dfg))
+    (($ $block _ _ preds succs) preds)))
+
+(define (lookup-successors k dfg)
+  (match (lookup-block k (dfg-blocks dfg))
+    (($ $block _ _ preds succs) succs)))
+
 (define (find-defining-term sym dfg)
-  (match (lookup-uses (lookup-def sym dfg) dfg)
+  (match (lookup-predecessors (lookup-def sym dfg) dfg)
     ((def-exp-k)
      (lookup-cont def-exp-k (dfg-cont-table dfg)))
     (else #f)))
@@ -274,6 +302,7 @@
   (match (find-defining-term sym dfg)
     (#f #f)
     (($ $ktrunc) #f)
+    (($ $kclause) #f)
     (term (find-expression term))))
 
 (define (find-constant-value sym dfg)
@@ -292,7 +321,7 @@
       (($ $letk conts body) (find-exp body))
       (else term)))
   (match dfg
-    (($ $dfg conts use-maps uplinks)
+    (($ $dfg conts blocks use-maps)
      (match (lookup-use-map sym use-maps)
        (($ $use-map _ def uses)
         (or-map
@@ -315,45 +344,50 @@
              (_ #t)))
          uses))))))
 
-(define (continuation-scope-contains? parent-k k uplinks)
+(define (continuation-scope-contains? scope-k k blocks)
-  (match (lookup-uplink parent-k uplinks)
+  (let ((scope-level (lookup-scope-level scope-k blocks)))
-    (($ $uplink _ parent-level)
     (let lp ((k k))
-       (or (eq? parent-k k)
+      (or (eq? scope-k k)
-           (match (lookup-uplink k uplinks)
+          (match (lookup-block k blocks)
-             (($ $uplink parent level)
+            (($ $block scope level)
-              (and (< parent-level level)
+             (and (< scope-level level)
-                   (lp parent)))))))))
+                  (lp scope))))))))
 
-(define (lift-definition! k parent-k dfg)
+;; FIXME: Splice preds, succs, dom tree.
+(define (lift-definition! k scope-k dfg)
   (match dfg
-    (($ $dfg conts use-maps uplinks)
+    (($ $dfg conts blocks use-maps)
-     (match (lookup-uplink parent-k uplinks)
+     (let ((scope-level (1+ (lookup-scope-level scope-k blocks))))
-       (($ $uplink parent level)
+       ;; Fix parent scope link of K.
-        (hashq-set! uplinks k
+       (match (lookup-block k blocks)
-                    (make-uplink parent-k (1+ level)))
+         ((and block ($ $block))
-        ;; Lift definitions of all conts in K.
+          (set-block-scope! block scope-k)))
+       ;; Fix up scope levels of K and all contained scopes.
+       (let update-levels! ((k k) (level scope-level))
+         (match (lookup-block k blocks)
+           ((and block ($ $block))
+            (set-block-scope-level! block scope-level)))
          (let lp ((cont (lookup-cont k conts)))
            (match cont
              (($ $letk (($ $cont kid) ...) body)
-             (for-each (cut lift-definition! <> k dfg) kid)
+              (for-each (cut update-levels! <> (1+ scope-level)) kid)
               (lp body))
              (($ $letrec names syms funs body)
               (lp body))
              (_ #t))))))))
 
-(define (variable-bound-in? var k dfg)
+(define (continuation-bound-in? k use-k dfg)
   (match dfg
-    (($ $dfg conts use-maps uplinks)
+    (($ $dfg conts blocks use-maps)
-     (match (lookup-use-map var use-maps)
+     (match (lookup-block k blocks)
-       (($ $use-map sym def uses)
+       (($ $block def-k)
-        (continuation-scope-contains? def k uplinks))))))
+        (continuation-scope-contains? def-k use-k blocks))))))
 
 (define (variable-free-in? var k dfg)
   (match dfg
-    (($ $dfg conts use-maps uplinks)
+    (($ $dfg conts blocks use-maps)
      (or-map (lambda (use)
-               (continuation-scope-contains? k use uplinks))
+               (continuation-scope-contains? k use blocks))
              (match (lookup-use-map var use-maps)
                (($ $use-map sym def uses)
                 uses))))))
@@ -366,59 +400,52 @@
 ;; relationship.  See
 ;; http://mlton.org/pipermail/mlton/2003-January/023054.html for a
 ;; deeper discussion.
-(define (conservatively-dominates? k1 k2 uplinks)
+(define (conservatively-dominates? k1 k2 blocks)
-  (continuation-scope-contains? k1 k2 uplinks))
+  (continuation-scope-contains? k1 k2 blocks))
 
 (define (dead-after-def? sym dfg)
   (match dfg
-    (($ $dfg conts use-maps uplinks)
+    (($ $dfg conts blocks use-maps)
      (match (lookup-use-map sym use-maps)
        (($ $use-map sym def uses)
         (null? uses))))))
 
 (define (dead-after-use? sym use-k dfg)
   (match dfg
-    (($ $dfg conts use-maps uplinks)
+    (($ $dfg conts blocks use-maps)
      (match (lookup-use-map sym use-maps)
        (($ $use-map sym def uses)
         ;; If all other uses dominate this use, it is now dead.  There
         ;; are other ways for it to be dead, but this is an
         ;; approximation.  A better check would be if the successor
         ;; post-dominates all uses.
-        (and-map (cut conservatively-dominates? <> use-k uplinks)
+        (and-map (cut conservatively-dominates? <> use-k blocks)
                  uses))))))
 
 ;; A continuation is a "branch" if all of its predecessors are $kif
 ;; continuations.
 (define (branch? k dfg)
-  (match dfg
+  (let ((preds (lookup-predecessors k dfg)))
-    (($ $dfg conts use-maps uplinks)
+    (and (not (null? preds))
-     (match (lookup-use-map k use-maps)
-       (($ $use-map sym def uses)
-        (and (not (null? uses))
          (and-map (lambda (k)
-                        (match (lookup-cont k conts)
+                    (match (lookup-cont k (dfg-cont-table dfg))
                       (($ $kif) #t)
                       (_ #f)))
-                      uses)))))))
+                  preds))))
 
 (define (find-other-branches k dfg)
-  (match dfg
-    (($ $dfg conts use-maps uplinks)
-     (match (lookup-use-map k use-maps)
-       (($ $use-map sym def (uses ..1))
   (map (lambda (kif)
-               (match (lookup-cont kif conts)
+         (match (lookup-cont kif (dfg-cont-table dfg))
            (($ $kif (? (cut eq? <> k)) kf)
             kf)
            (($ $kif kt (? (cut eq? <> k)))
             kt)
            (_ (error "Not all predecessors are branches"))))
-             uses))))))
+       (lookup-predecessors k dfg)))
 
 (define (dead-after-branch? sym branch other-branches dfg)
   (match dfg
-    (($ $dfg conts use-maps uplinks)
+    (($ $dfg conts blocks use-maps)
      (match (lookup-use-map sym use-maps)
        (($ $use-map sym def uses)
         (and-map
@@ -426,15 +453,15 @@
            ;; A symbol is dead after a branch if at least one of the
            ;; other branches dominates a use of the symbol, and all
            ;; other uses of the symbol dominate the test.
-           (if (or-map (cut conservatively-dominates? <> use-k uplinks)
+           (if (or-map (cut conservatively-dominates? <> use-k blocks)
                        other-branches)
-               (not (conservatively-dominates? branch use-k uplinks))
+               (not (conservatively-dominates? branch use-k blocks))
-               (conservatively-dominates? use-k branch uplinks)))
+               (conservatively-dominates? use-k branch blocks)))
          uses))))))
 
 (define (lookup-bound-syms k dfg)
   (match dfg
-    (($ $dfg conts use-maps uplinks)
+    (($ $dfg conts blocks use-maps)
      (match (lookup-cont k conts)
        (($ $kargs names syms body)
         syms)))))