Change the block representation (version bumped to 3.9.0.0)
[packages/hoopl.git] / src / Compiler / Hoopl / Graph.hs
1 {-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies, ScopedTypeVariables,
2 RankNTypes, FlexibleInstances #-}
3 #if __GLASGOW_HASKELL__ >= 701
4 {-# LANGUAGE Safe #-}
5 #endif
6
7 module Compiler.Hoopl.Graph
8 (
9 -- * Body
10 Body, Body', emptyBody, bodyList, addBlock, bodyUnion
11
12 -- * Graph
13 , Graph, Graph'(..)
14 , NonLocal(entryLabel, successors)
15
16 -- ** Constructing graphs
17 , bodyGraph
18 , blockGraph
19 , gUnitOO, gUnitOC, gUnitCO, gUnitCC
20 , catGraphNodeOC, catGraphNodeOO
21 , catNodeCOGraph, catNodeOOGraph
22
23 -- ** Splicing graphs
24 , splice, gSplice
25
26 -- ** Maps
27 , mapGraph, mapGraphBlocks
28
29 -- ** Folds
30 , foldGraphNodes
31
32 -- ** Extracting Labels
33 , labelsDefined, labelsUsed, externalEntryLabels
34
35 -- ** Depth-first traversals
36 , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
37 , preorder_dfs, preorder_dfs_from_except
38 , LabelsPtr(..)
39 )
40 where
41
42 import Compiler.Hoopl.Collections
43 import Compiler.Hoopl.Block
44 import Compiler.Hoopl.Label
45
46 import Control.Monad
47
48
49 -- -----------------------------------------------------------------------------
50 -- Body
51
52 -- | A (possibly empty) collection of closed/closed blocks
53 type Body n = LabelMap (Block n C C)
54
55 -- | @Body@ abstracted over @block@
56 type Body' block (n :: * -> * -> *) = LabelMap (block n C C)
57
58 emptyBody :: Body' block n
59 emptyBody = mapEmpty
60
61 bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a
62 bodyUnion = mapUnionWithKey nodups
63 where nodups l _ _ = error $ "duplicate blocks with label " ++ show l
64
65 bodyList :: NonLocal (block n) => Body' block n -> [(Label,block n C C)]
66 bodyList body = mapToList body
67
68 addBlock :: NonLocal thing
69 => thing C C -> LabelMap (thing C C)
70 -> LabelMap (thing C C)
71 addBlock b body
72 | mapMember lbl body = error $ "duplicate label " ++ show lbl ++ " in graph"
73 | otherwise = mapInsert lbl b body
74 where lbl = entryLabel b
75
76
77 -- ---------------------------------------------------------------------------
78 -- Graph
79
80 -- | A control-flow graph, which may take any of four shapes (O/O,
81 -- O/C, C/O, C/C). A graph open at the entry has a single,
82 -- distinguished, anonymous entry point; if a graph is closed at the
83 -- entry, its entry point(s) are supplied by a context.
84 type Graph = Graph' Block
85
86 -- | @Graph'@ is abstracted over the block type, so that we can build
87 -- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow
88 -- needs this).
89 data Graph' block (n :: * -> * -> *) e x where
90 GNil :: Graph' block n O O
91 GUnit :: block n O O -> Graph' block n O O
92 GMany :: MaybeO e (block n O C)
93 -> Body' block n
94 -> MaybeO x (block n C O)
95 -> Graph' block n e x
96
97 -------------------------------
98 -- | Gives access to the anchor points for
99 -- nonlocal edges as well as the edges themselves
100 class NonLocal thing where
101 entryLabel :: thing C x -> Label -- ^ The label of a first node or block
102 successors :: thing e C -> [Label] -- ^ Gives control-flow successors
103
104 instance NonLocal n => NonLocal (Block n) where
105 entryLabel (BlockCO f _) = entryLabel f
106 entryLabel (BlockCC f _ _) = entryLabel f
107
108 successors (BlockOC _ n) = successors n
109 successors (BlockCC _ _ n) = successors n
110
111
112 -- -----------------------------------------------------------------------------
113 -- Constructing graphs
114
115 bodyGraph :: Body n -> Graph n C C
116 bodyGraph b = GMany NothingO b NothingO
117
118 gUnitOO :: block n O O -> Graph' block n O O
119 gUnitOC :: block n O C -> Graph' block n O C
120 gUnitCO :: block n C O -> Graph' block n C O
121 gUnitCC :: NonLocal (block n) => block n C C -> Graph' block n C C
122 gUnitOO b = GUnit b
123 gUnitOC b = GMany (JustO b) emptyBody NothingO
124 gUnitCO b = GMany NothingO emptyBody (JustO b)
125 gUnitCC b = GMany NothingO (addBlock b emptyBody) NothingO
126
127
128 catGraphNodeOO :: Graph n e O -> n O O -> Graph n e O
129 catGraphNodeOC :: NonLocal n => Graph n e O -> n O C -> Graph n e C
130 catNodeOOGraph :: n O O -> Graph n O x -> Graph n O x
131 catNodeCOGraph :: NonLocal n => n C O -> Graph n O x -> Graph n C x
132
133 catGraphNodeOO GNil n = gUnitOO $ BMiddle n
134 catGraphNodeOO (GUnit b) n = gUnitOO $ BHead b n
135 catGraphNodeOO (GMany e body (JustO (BlockCO f b))) n
136 = GMany e body (JustO (BlockCO f (BHead b n)))
137
138 catGraphNodeOC GNil n = gUnitOC $ BlockOC BNil n
139 catGraphNodeOC (GUnit b) n = gUnitOC $ BlockOC b n
140 catGraphNodeOC (GMany e body (JustO (BlockCO f x))) n
141 = GMany e (addBlock (BlockCC f x n) body) NothingO
142
143 catNodeOOGraph n GNil = gUnitOO $ BMiddle n
144 catNodeOOGraph n (GUnit b) = gUnitOO $ BTail n b
145 catNodeOOGraph n (GMany (JustO (BlockOC b l)) body x)
146 = GMany (JustO (BlockOC (n `BTail` b) l)) body x
147
148 catNodeCOGraph f GNil = gUnitCO (BlockCO f BNil)
149 catNodeCOGraph f (GUnit b) = gUnitCO (BlockCO f b)
150 catNodeCOGraph f (GMany (JustO (BlockOC b n)) body x)
151 = GMany NothingO (addBlock (BlockCC f b n) body) x
152
153
154 blockGraph :: NonLocal n => Block n e x -> Graph n e x
155 blockGraph b@(BlockCO {}) = gUnitCO b
156 blockGraph b@(BlockOC {}) = gUnitOC b
157 blockGraph b@(BlockCC {}) = gUnitCC b
158 blockGraph (BNil {}) = GNil
159 blockGraph b@(BMiddle {}) = gUnitOO b
160 blockGraph b@(BCat {}) = gUnitOO b
161 blockGraph b@(BHead {}) = gUnitOO b
162 blockGraph b@(BTail {}) = gUnitOO b
163
164
165 -- -----------------------------------------------------------------------------
166 -- Splicing graphs
167
168 splice :: forall block n e a x . NonLocal (block n) =>
169 (forall e x . block n e O -> block n O x -> block n e x)
170 -> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x)
171
172 splice bcat = sp
173 where sp :: forall e a x .
174 Graph' block n e a -> Graph' block n a x -> Graph' block n e x
175
176 sp GNil g2 = g2
177 sp g1 GNil = g1
178
179 sp (GUnit b1) (GUnit b2) = {-# SCC "sp1" #-} GUnit $! b1 `bcat` b2
180
181 sp (GUnit b) (GMany (JustO e) bs x) = {-# SCC "sp2" #-} GMany (JustO (b `bcat` e)) bs x
182
183 sp (GMany e bs (JustO x)) (GUnit b2) = {-# SCC "sp3" #-} x `seq` GMany e bs (JustO x')
184 where x' = x `bcat` b2
185
186 sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2)
187 = {-# SCC "sp4" #-} (GMany e1 $! b1 `bodyUnion` b2) x2
188 where b1 = (addBlock $! x1 `bcat` e2) bs1
189
190 sp (GMany e1 b1 NothingO) (GMany NothingO b2 x2)
191 = {-# SCC "sp5" #-} (GMany e1 $! b1 `bodyUnion` b2) x2
192
193 sp _ _ = error "bogus GADT match failure"
194
195 gSplice :: NonLocal n => Graph n e a -> Graph n a x -> Graph n e x
196 gSplice = splice blockAppend
197
198
199 -- -----------------------------------------------------------------------------
200 -- Mapping over graphs
201
202 -- | Maps over all nodes in a graph.
203 mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
204 mapGraph f = mapGraphBlocks (mapBlock f)
205
206 -- | Function 'mapGraphBlocks' enables a change of representation of blocks,
207 -- nodes, or both. It lifts a polymorphic block transform into a polymorphic
208 -- graph transform. When the block representation stabilizes, a similar
209 -- function should be provided for blocks.
210 mapGraphBlocks :: forall block n block' n' e x .
211 (forall e x . block n e x -> block' n' e x)
212 -> (Graph' block n e x -> Graph' block' n' e x)
213
214 mapGraphBlocks f = map
215 where map :: Graph' block n e x -> Graph' block' n' e x
216 map GNil = GNil
217 map (GUnit b) = GUnit (f b)
218 map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)
219
220
221 -- -----------------------------------------------------------------------------
222 -- Folds
223
224 -- | Fold a function over every node in a graph.
225 -- The fold function must be polymorphic in the shape of the nodes.
226
227 foldGraphNodes :: forall n a .
228 (forall e x . n e x -> a -> a)
229 -> (forall e x . Graph n e x -> a -> a)
230
231 foldGraphNodes f = graph
232 where graph :: forall e x . Graph n e x -> a -> a
233 lift :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a)
234
235 graph GNil = id
236 graph (GUnit b) = block b
237 graph (GMany e b x) = lift block e . body b . lift block x
238 body :: Body n -> a -> a
239 body bdy = \a -> mapFold block a bdy
240 lift _ NothingO = id
241 lift f (JustO thing) = f thing
242
243 block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a
244 block = foldBlockNodesF f
245
246
247 ----------------------------------------------------------------
248
249 class LabelsPtr l where
250 targetLabels :: l -> [Label]
251
252 instance NonLocal n => LabelsPtr (n e C) where
253 targetLabels n = successors n
254
255 instance LabelsPtr Label where
256 targetLabels l = [l]
257
258 instance LabelsPtr LabelSet where
259 targetLabels = setElems
260
261 instance LabelsPtr l => LabelsPtr [l] where
262 targetLabels = concatMap targetLabels
263
264
265 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
266 -- from the entry of enterable graph. The entry and exit are *not* included.
267 -- The list has the following property:
268 --
269 -- Say a "back reference" exists if one of a block's
270 -- control-flow successors precedes it in the output list
271 --
272 -- Then there are as few back references as possible
273 --
274 -- The output is suitable for use in
275 -- a forward dataflow problem. For a backward problem, simply reverse
276 -- the list. ('postorder_dfs' is sufficiently tricky to implement that
277 -- one doesn't want to try and maintain both forward and backward
278 -- versions.)
279
280 postorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C]
281 preorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C]
282
283 -- | This is the most important traversal over this data structure. It drops
284 -- unreachable code and puts blocks in an order that is good for solving forward
285 -- dataflow problems quickly. The reverse order is good for solving backward
286 -- dataflow problems quickly. The forward order is also reasonably good for
287 -- emitting instructions, except that it will not usually exploit Forrest
288 -- Baskett's trick of eliminating the unconditional branch from a loop. For
289 -- that you would need a more serious analysis, probably based on dominators, to
290 -- identify loop headers.
291 --
292 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
293 -- representation, when for most purposes the plain 'Graph' representation is
294 -- more mathematically elegant (but results in more complicated code).
295 --
296 -- Here's an easy way to go wrong! Consider
297 -- @
298 -- A -> [B,C]
299 -- B -> D
300 -- C -> D
301 -- @
302 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
303 -- Better to get [A,B,C,D]
304
305
306 graphDfs :: (NonLocal (block n))
307 => (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C])
308 -> (Graph' block n O x -> [block n C C])
309 graphDfs _ (GNil) = []
310 graphDfs _ (GUnit{}) = []
311 graphDfs order (GMany (JustO entry) body _) = order body entry setEmpty
312
313 postorder_dfs = graphDfs postorder_dfs_from_except
314 preorder_dfs = graphDfs preorder_dfs_from_except
315
316 postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)
317 => LabelMap (block C C) -> e -> LabelSet -> [block C C]
318 postorder_dfs_from_except blocks b visited =
319 vchildren (get_children b) (\acc _visited -> acc) [] visited
320 where
321 vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
322 vnode block cont acc visited =
323 if setMember id visited then
324 cont acc visited
325 else
326 let cont' acc visited = cont (block:acc) visited in
327 vchildren (get_children block) cont' acc (setInsert id visited)
328 where id = entryLabel block
329 vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
330 vchildren bs cont acc visited = next bs acc visited
331 where next children acc visited =
332 case children of [] -> cont acc visited
333 (b:bs) -> vnode b (next bs) acc visited
334 get_children :: forall l. LabelsPtr l => l -> [block C C]
335 get_children block = foldr add_id [] $ targetLabels block
336 add_id id rst = case lookupFact id blocks of
337 Just b -> b : rst
338 Nothing -> rst
339
340 postorder_dfs_from
341 :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]
342 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty
343
344
345 ----------------------------------------------------------------
346
347 data VM a = VM { unVM :: LabelSet -> (a, LabelSet) }
348 marked :: Label -> VM Bool
349 mark :: Label -> VM ()
350 instance Monad VM where
351 return a = VM $ \visited -> (a, visited)
352 m >>= k = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v'
353 marked l = VM $ \v -> (setMember l v, v)
354 mark l = VM $ \v -> ((), setInsert l v)
355
356 preorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)
357 => LabelMap (block C C) -> e -> LabelSet -> [block C C]
358 preorder_dfs_from_except blocks b visited =
359 (fst $ unVM (children (get_children b)) visited) []
360 where children [] = return id
361 children (b:bs) = liftM2 (.) (visit b) (children bs)
362 visit :: block C C -> VM (HL (block C C))
363 visit b = do already <- marked (entryLabel b)
364 if already then return id
365 else do mark (entryLabel b)
366 bs <- children $ get_children b
367 return $ b `cons` bs
368 get_children :: forall l. LabelsPtr l => l -> [block C C]
369 get_children block = foldr add_id [] $ targetLabels block
370
371 add_id id rst = case lookupFact id blocks of
372 Just b -> b : rst
373 Nothing -> rst
374
375 type HL a = [a] -> [a] -- Hughes list (constant-time concatenation)
376 cons :: a -> HL a -> HL a
377 cons a as tail = a : as tail
378
379
380 -- -----------------------------------------------------------------------------
381 -- Extracting Labels from graphs
382
383 labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
384 -> LabelSet
385 labelsDefined GNil = setEmpty
386 labelsDefined (GUnit{}) = setEmpty
387 labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body
388 where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet
389 addEntry label _ labels = setInsert label labels
390 exitLabel :: MaybeO x (block n C O) -> LabelSet
391 exitLabel NothingO = setEmpty
392 exitLabel (JustO b) = setSingleton (entryLabel b)
393
394 labelsUsed :: forall block n e x. NonLocal (block n) => Graph' block n e x
395 -> LabelSet
396 labelsUsed GNil = setEmpty
397 labelsUsed (GUnit{}) = setEmpty
398 labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body
399 where addTargets :: forall e. block n e C -> LabelSet -> LabelSet
400 addTargets block labels = setInsertList (successors block) labels
401 entryTargets :: MaybeO e (block n O C) -> LabelSet
402 entryTargets NothingO = setEmpty
403 entryTargets (JustO b) = addTargets b setEmpty
404
405 externalEntryLabels :: forall n .
406 NonLocal n => LabelMap (Block n C C) -> LabelSet
407 externalEntryLabels body = defined `setDifference` used
408 where defined = labelsDefined g
409 used = labelsUsed g
410 g = GMany NothingO body NothingO
411