Merge branch 'master' of /home/nr/papers/simon/dfopt/ into with-passes
[packages/hoopl.git] / src / Compiler / Hoopl / Util.hs
1 {-# LANGUAGE GADTs, ScopedTypeVariables, FlexibleInstances #-}
2
3 module Compiler.Hoopl.Util
4 ( gUnitOO, gUnitOC, gUnitCO, gUnitCC
5 , zblockGraph
6 , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
7 , preorder_dfs, preorder_dfs_from_except
8 , labelsDefined, labelsUsed, externalEntryLabels
9 , LabelsPtr(..)
10 )
11 where
12
13 import Control.Monad
14
15 import Compiler.Hoopl.Graph
16 import Compiler.Hoopl.Label
17 import Compiler.Hoopl.Zipper
18
19 gUnitOO :: block n O O -> Graph' block n O O
20 gUnitOC :: block n O C -> Graph' block n O C
21 gUnitCO :: block n C O -> Graph' block n C O
22 gUnitCC :: block n C C -> Graph' block n C C
23 gUnitOO b = GUnit b
24 gUnitOC b = GMany (JustO b) BodyEmpty NothingO
25 gUnitCO b = GMany NothingO BodyEmpty (JustO b)
26 gUnitCC b = GMany NothingO (BodyUnit b) NothingO
27
28 zblockGraph :: ZBlock n e x -> ZGraph n e x
29 zblockGraph b@(ZFirst {}) = gUnitCO b
30 zblockGraph b@(ZMiddle {}) = gUnitOO b
31 zblockGraph b@(ZLast {}) = gUnitOC b
32 zblockGraph b@(ZCat {}) = gUnitOO b
33 zblockGraph b@(ZHead {}) = gUnitCO b
34 zblockGraph b@(ZTail {}) = gUnitOC b
35 zblockGraph b@(ZClosed {}) = gUnitCC b
36
37
38 class LabelsPtr l where
39 targetLabels :: l -> [Label]
40
41 instance Edges n => LabelsPtr (n e C) where
42 targetLabels n = successors n
43
44 instance LabelsPtr Label where
45 targetLabels l = [l]
46
47 instance LabelsPtr LabelSet where
48 targetLabels = labelSetElems
49
50 instance LabelsPtr l => LabelsPtr [l] where
51 targetLabels = concatMap targetLabels
52
53
54 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
55 -- from the entry of enterable graph. The entry and exit are *not* included.
56 -- The list has the following property:
57 --
58 -- Say a "back reference" exists if one of a block's
59 -- control-flow successors precedes it in the output list
60 --
61 -- Then there are as few back references as possible
62 --
63 -- The output is suitable for use in
64 -- a forward dataflow problem. For a backward problem, simply reverse
65 -- the list. ('postorder_dfs' is sufficiently tricky to implement that
66 -- one doesn't want to try and maintain both forward and backward
67 -- versions.)
68
69 postorder_dfs :: Edges (block n) => Graph' block n O x -> [block n C C]
70 preorder_dfs :: Edges (block n) => Graph' block n O x -> [block n C C]
71
72 -- | This is the most important traversal over this data structure. It drops
73 -- unreachable code and puts blocks in an order that is good for solving forward
74 -- dataflow problems quickly. The reverse order is good for solving backward
75 -- dataflow problems quickly. The forward order is also reasonably good for
76 -- emitting instructions, except that it will not usually exploit Forrest
77 -- Baskett's trick of eliminating the unconditional branch from a loop. For
78 -- that you would need a more serious analysis, probably based on dominators, to
79 -- identify loop headers.
80 --
81 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
82 -- representation, when for most purposes the plain 'Graph' representation is
83 -- more mathematically elegant (but results in more complicated code).
84 --
85 -- Here's an easy way to go wrong! Consider
86 -- @
87 -- A -> [B,C]
88 -- B -> D
89 -- C -> D
90 -- @
91 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
92 -- Better to get [A,B,C,D]
93
94
95 graphDfs :: (Edges (block n))
96 => (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C])
97 -> (Graph' block n O x -> [block n C C])
98 graphDfs order (GNil) = []
99 graphDfs order (GUnit{}) = []
100 graphDfs order (GMany (JustO entry) body _) = order blockenv entry emptyLabelSet
101 where blockenv = bodyMap body
102
103 postorder_dfs = graphDfs postorder_dfs_from_except
104 preorder_dfs = graphDfs preorder_dfs_from_except
105
106 postorder_dfs_from_except :: forall block e . (Edges block, LabelsPtr e)
107 => LabelMap (block C C) -> e -> LabelSet -> [block C C]
108 postorder_dfs_from_except blocks b visited =
109 vchildren (get_children b) (\acc _visited -> acc) [] visited
110 where
111 vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
112 vnode block cont acc visited =
113 if elemLabelSet id visited then
114 cont acc visited
115 else
116 let cont' acc visited = cont (block:acc) visited in
117 vchildren (get_children block) cont' acc (extendLabelSet visited id)
118 where id = entryLabel block
119 vchildren bs cont acc visited = next bs acc visited
120 where next children acc visited =
121 case children of [] -> cont acc visited
122 (b:bs) -> vnode b (next bs) acc visited
123 get_children block = foldr add_id [] $ targetLabels block
124 add_id id rst = case lookupFact blocks id of
125 Just b -> b : rst
126 Nothing -> rst
127
128 postorder_dfs_from
129 :: (Edges block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]
130 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyLabelSet
131
132
133 ----------------------------------------------------------------
134
135 data VM a = VM { unVM :: LabelSet -> (a, LabelSet) }
136 marked :: Label -> VM Bool
137 mark :: Label -> VM ()
138 instance Monad VM where
139 return a = VM $ \visited -> (a, visited)
140 m >>= k = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v'
141 marked l = VM $ \v -> (elemLabelSet l v, v)
142 mark l = VM $ \v -> ((), extendLabelSet v l)
143
144 preorder_dfs_from_except :: forall block e . (Edges block, LabelsPtr e)
145 => LabelMap (block C C) -> e -> LabelSet -> [block C C]
146 preorder_dfs_from_except blocks b visited =
147 (fst $ unVM (children (get_children b)) visited) []
148 where children [] = return id
149 children (b:bs) = liftM2 (.) (visit b) (children bs)
150 visit :: block C C -> VM (HL (block C C))
151 visit b = do already <- marked (entryLabel b)
152 if already then return id
153 else do mark (entryLabel b)
154 bs <- children $ get_children b
155 return $ b `cons` bs
156 get_children block = foldr add_id [] $ targetLabels block
157 add_id id rst = case lookupFact blocks id of
158 Just b -> b : rst
159 Nothing -> rst
160
161 type HL a = [a] -> [a] -- Hughes list (constant-time concatenation)
162 cons :: a -> HL a -> HL a
163 cons a as tail = a : as tail
164
165 ----------------------------------------------------------------
166
167 labelsDefined :: forall block n e x . Edges (block n) => Graph' block n e x -> LabelSet
168 labelsDefined GNil = emptyLabelSet
169 labelsDefined (GUnit{}) = emptyLabelSet
170 labelsDefined (GMany _ body x) = foldBodyBlocks addEntry body $ exitLabel x
171 where addEntry block labels = extendLabelSet labels (entryLabel block)
172 exitLabel :: MaybeO x (block n C O) -> LabelSet
173 exitLabel NothingO = emptyLabelSet
174 exitLabel (JustO b) = mkLabelSet [entryLabel b]
175
176 labelsUsed :: forall block n e x. Edges (block n) => Graph' block n e x -> LabelSet
177 labelsUsed GNil = emptyLabelSet
178 labelsUsed (GUnit{}) = emptyLabelSet
179 labelsUsed (GMany e body _) = foldBodyBlocks addTargets body $ entryTargets e
180 where addTargets block labels = foldl extendLabelSet labels (successors block)
181 entryTargets :: MaybeO e (block n O C) -> LabelSet
182 entryTargets NothingO = emptyLabelSet
183 entryTargets (JustO b) = addTargets b emptyLabelSet
184
185 foldBodyBlocks :: (block n C C -> a -> a) -> Body' block n -> a -> a
186 foldBodyBlocks f BodyEmpty = id
187 foldBodyBlocks f (BodyUnit b) = f b
188 foldBodyBlocks f (BodyCat b b') = foldBodyBlocks f b . foldBodyBlocks f b'
189
190 externalEntryLabels :: Edges (block n) => Body' block n -> LabelSet
191 externalEntryLabels body = defined `minusLabelSet` used
192 where defined = labelsDefined g
193 used = labelsUsed g
194 g = GMany NothingO body NothingO