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