git » blacktide.git » master » tree

[master] / src / com / tailrecursion / blacktide / compiler / passes / loops.clj 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.loops
  "Find natural loops in the reachable CFG. Every DFS backedge must target a
  dominator; otherwise recovery leaves the irreducible graph to the dispatcher.
  Reverse predecessor walks merge all latches belonging to the same header."
  (:require [clojure.set :as set]
            [com.tailrecursion.nanopass :as np]
            [com.tailrecursion.blacktide.compiler.languages :as l]
            [com.tailrecursion.blacktide.compiler.passes.graph :as graph]
            [typed.clojure :as-alias t]))

(np/defpass dominators
  {:from [l/CFG Facts] :to (t/Map l/CFG-Label l/CFG-Labels)
   :args [l/CFG-Label l/CFG-Predecessors] :body true}
  [entry predecessors facts]
  (let [labels (set (keys facts))]
    ((fn ^{::t/- [(t/Map l/CFG-Label l/CFG-Labels) :-> (t/Map l/CFG-Label l/CFG-Labels)]} solve [known]
       (let [next (reduce
                    (fn [^{::t/- (t/Map l/CFG-Label l/CFG-Labels)} out ^{::t/- l/CFG-Label} id]
                      (assoc out id
                        (if (= entry id) #{id}
                          (conj (reduce set/intersection labels
                                        (map #(get known % #{}) (get predecessors id #{}))) id))))
                    {} labels)]
         (if (= known next) known (recur next)))) (zipmap labels (repeat labels)))))

(np/defpass backedges
  {:from [l/CFG Facts] :to (t/Vec (t/HVec [l/CFG-Label l/CFG-Label]))
   :args [l/CFG-Label] :body true}
  [entry facts]
  (second
    ((fn ^{::t/- [l/CFG-Labels
                   (t/HVec [l/CFG-Labels (t/Vec (t/HVec [l/CFG-Label l/CFG-Label]))])
                   l/CFG-Label :-> (t/HVec [l/CFG-Labels (t/Vec (t/HVec [l/CFG-Label l/CFG-Label]))])]} visit
       [path state id]
       (let [[seen _] state]
         (if (contains? seen id) state
           (let [path (conj path id)]
             (reduce
               (fn [^{::t/- (t/HVec [l/CFG-Labels (t/Vec (t/HVec [l/CFG-Label l/CFG-Label]))])} state
                    ^{::t/- l/CFG-Label} target]
                 (if (contains? path target)
                   [(first state) (conj (second state) [id target])]
                   (visit path state target)))
               [(conj seen id) (second state)] (:successors (graph/fact-at facts id)))))))
     #{} [#{} []] entry)))

(np/defpass natural-loop
  {:from [l/CFG Label] :to [l/CFG Labels]
   :args [l/CFG-Predecessors l/CFG-Label] :body true}
  [predecessors header latch]
  ((fn ^{::t/- [(t/Vec l/CFG-Label) l/CFG-Labels :-> l/CFG-Labels]} visit [pending members]
     (if-let [id (peek pending)]
       (if (contains? members id)
         (recur (pop pending) members)
         (recur (into (pop pending) (get predecessors id #{})) (conj members id)))
       members)) [latch] #{header}))

(np/defpass analyze
  {:from [l/CFG Facts] :to (t/Option l/Planned-LoopBodies) :args [l/CFG-Label] :body true}
  [entry facts]
  (let [facts (select-keys facts (graph/reachable facts entry))
        predecessors (graph/predecessors facts)
        dominance (dominators entry predecessors facts)
        edges (backedges entry facts)]
    (when (every? (fn [[latch header]] (contains? (get dominance latch #{}) header)) edges)
      (reduce (fn [^{::t/- l/Planned-LoopBodies} out ^{::t/- (t/HVec [l/CFG-Label l/CFG-Label])} edge]
                (let [[latch header] edge]
                  (assoc out header (set/union (get out header #{}) (natural-loop predecessors header latch)))))
              {} edges))))