Fix dominator join function.
[packages/hoopl.git] / src / Compiler / Hoopl / Passes / Dominator.hs
1 {-# LANGUAGE CPP, GADTs #-}
2 {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
3 #if __GLASGOW_HASKELL__ >= 701
4 {-# LANGUAGE Safe #-}
5 #endif
6
7 module Compiler.Hoopl.Passes.Dominator
8 ( Doms, DPath(..), domPath, domEntry, domLattice, extendDom
9 , DominatorNode(..), DominatorTree(..), tree
10 , immediateDominators
11 , domPass
12 )
13 where
14
15 import Data.Maybe
16 import qualified Data.Set as Set
17
18 import Compiler.Hoopl
19
20
21 type Doms = WithBot DPath
22 -- ^ List of labels, extended with a standard bottom element
23
24 -- | The fact that goes into the entry of a dominator analysis: the first node
25 -- is dominated only by the entry point, which is represented by the empty list
26 -- of labels.
27 domEntry :: Doms
28 domEntry = PElem (DPath [])
29
30 newtype DPath = DPath [Label]
31 -- ^ represents part of the domination relation: each label
32 -- in a list is dominated by all its successors. This is a newtype only so
33 -- we can give it a fancy Show instance.
34
35 instance Show DPath where
36 show (DPath ls) = concat (foldr (\l path -> show l : " -> " : path) ["entry"] ls)
37
38 domPath :: Doms -> [Label]
39 domPath Bot = [] -- lies: an unreachable node appears to be dominated by the entry
40 domPath (PElem (DPath ls)) = ls
41
42 extendDom :: Label -> DPath -> DPath
43 extendDom l (DPath ls) = DPath (l:ls)
44
45 domLattice :: DataflowLattice Doms
46 domLattice = addPoints "dominators" extend
47
48 extend :: JoinFun DPath
49 extend _ (OldFact (DPath l)) (NewFact (DPath l')) =
50 (changeIf (l `lengthDiffers` j), DPath j)
51 where j = filter (\elem -> Set.member elem common) l
52 common = Set.intersection (Set.fromList l) (Set.fromList l')
53
54 lengthDiffers [] [] = False
55 lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys
56 lengthDiffers [] (_:_) = True
57 lengthDiffers (_:_) [] = True
58
59
60
61 -- | Dominator pass
62 domPass :: (NonLocal n, Monad m) => FwdPass m n Doms
63 domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite
64 where first n = fmap (extendDom $ entryLabel n)
65
66 ----------------------------------------------------------------
67
68 data DominatorNode = Entry | Labelled Label
69 data DominatorTree = Dominates DominatorNode [DominatorTree]
70 -- ^ This data structure is a *rose tree* in which each node may have
71 -- arbitrarily many children. Each node dominates all its descendants.
72
73 -- | Map from a FactBase for dominator lists into a
74 -- dominator tree.
75 tree :: [(Label, Doms)] -> DominatorTree
76 tree facts = Dominates Entry $ merge $ map reverse $ map mkList facts
77 -- This code has been lightly tested. The key insight is this: to
78 -- find lists that all have the same head, convert from a list of
79 -- lists to a finite map, in 'children'. Then, to convert from the
80 -- finite map to list of dominator trees, use the invariant that
81 -- each key dominates all the lists of values.
82 where merge lists = mapTree $ children $ filter (not . null) lists
83 children = foldl addList noFacts
84 addList :: FactBase [[Label]] -> [Label] -> FactBase [[Label]]
85 addList map (x:xs) = mapInsert x (xs:existing) map
86 where existing = fromMaybe [] $ lookupFact x map
87 addList _ [] = error "this can't happen"
88 mapTree :: FactBase [[Label]] -> [DominatorTree]
89 mapTree map = [Dominates (Labelled x) (merge lists) |
90 (x, lists) <- mapToList map]
91 mkList (l, doms) = l : domPath doms
92
93
94 instance Show DominatorTree where
95 show = tree2dot
96
97 -- | Given a dominator tree, produce a string representation, in the
98 -- input language of dot, that will enable dot to produce a
99 -- visualization of the tree. For more info about dot see
100 -- http://www.graphviz.org.
101
102 tree2dot :: DominatorTree -> String
103 tree2dot t = concat $ "digraph {\n" : dot t ["}\n"]
104 where
105 dot :: DominatorTree -> [String] -> [String]
106 dot (Dominates root trees) =
107 (dotnode root :) . outedges trees . flip (foldl subtree) trees
108 where outedges [] = id
109 outedges (Dominates n _ : ts) =
110 \s -> " " : show root : " -> " : show n : "\n" : outedges ts s
111 dotnode Entry = " entryNode [shape=plaintext, label=\"entry\"]\n"
112 dotnode (Labelled l) = " " ++ show l ++ "\n"
113 subtree = flip dot
114
115 instance Show DominatorNode where
116 show Entry = "entryNode"
117 show (Labelled l) = show l
118
119 ----------------------------------------------------------------
120
121 -- | Takes FactBase from dominator analysis and returns a map from each
122 -- label to its immediate dominator, if any
123 immediateDominators :: FactBase Doms -> LabelMap Label
124 immediateDominators = mapFoldWithKey add mapEmpty
125 where add l (PElem (DPath (idom:_))) = mapInsert l idom
126 add _ _ = id
127