never executed always true always false
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE DataKinds #-}
3 {-# LANGUAGE GADTs #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE RankNTypes #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TypeFamilies #-}
8
9 --
10 -- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,
11 -- and Norman Ramsey
12 --
13 -- Modifications copyright (c) The University of Glasgow 2012
14 --
15 -- This module is a specialised and optimised version of
16 -- Compiler.Hoopl.Dataflow in the hoopl package. In particular it is
17 -- specialised to the UniqSM monad.
18 --
19
20 module GHC.Cmm.Dataflow
21 ( C, O, Block
22 , lastNode, entryLabel
23 , foldNodesBwdOO
24 , foldRewriteNodesBwdOO
25 , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..)
26 , TransferFun, RewriteFun
27 , Fact, FactBase
28 , getFact, mkFactBase
29 , analyzeCmmFwd, analyzeCmmBwd
30 , rewriteCmmBwd
31 , changedIf
32 , joinOutFacts
33 , joinFacts
34 )
35 where
36
37 import GHC.Prelude
38
39 import GHC.Cmm
40 import GHC.Types.Unique.Supply
41
42 import Data.Array
43 import Data.Maybe
44 import Data.IntSet (IntSet)
45 import qualified Data.IntSet as IntSet
46 import Data.Kind (Type)
47
48 import GHC.Cmm.Dataflow.Block
49 import GHC.Cmm.Dataflow.Graph
50 import GHC.Cmm.Dataflow.Collections
51 import GHC.Cmm.Dataflow.Label
52
53 type family Fact (x :: Extensibility) f :: Type
54 type instance Fact C f = FactBase f
55 type instance Fact O f = f
56
57 newtype OldFact a = OldFact a
58
59 newtype NewFact a = NewFact a
60
61 -- | The result of joining OldFact and NewFact.
62 data JoinedFact a
63 = Changed !a -- ^ Result is different than OldFact.
64 | NotChanged !a -- ^ Result is the same as OldFact.
65
66 getJoined :: JoinedFact a -> a
67 getJoined (Changed a) = a
68 getJoined (NotChanged a) = a
69
70 changedIf :: Bool -> a -> JoinedFact a
71 changedIf True = Changed
72 changedIf False = NotChanged
73
74 type JoinFun a = OldFact a -> NewFact a -> JoinedFact a
75
76 data DataflowLattice a = DataflowLattice
77 { fact_bot :: a
78 , fact_join :: JoinFun a
79 }
80
81 data Direction = Fwd | Bwd
82
83 type TransferFun f = CmmBlock -> FactBase f -> FactBase f
84
85 -- | Function for rewrtiting and analysis combined. To be used with
86 -- @rewriteCmm@.
87 --
88 -- Currently set to work with @UniqSM@ monad, but we could probably abstract
89 -- that away (if we do that, we might want to specialize the fixpoint algorithms
90 -- to the particular monads through SPECIALIZE).
91 type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)
92
93 analyzeCmmBwd, analyzeCmmFwd
94 :: DataflowLattice f
95 -> TransferFun f
96 -> CmmGraph
97 -> FactBase f
98 -> FactBase f
99 analyzeCmmBwd = analyzeCmm Bwd
100 analyzeCmmFwd = analyzeCmm Fwd
101
102 analyzeCmm
103 :: Direction
104 -> DataflowLattice f
105 -> TransferFun f
106 -> CmmGraph
107 -> FactBase f
108 -> FactBase f
109 analyzeCmm dir lattice transfer cmmGraph initFact =
110 {-# SCC analyzeCmm #-}
111 let entry = g_entry cmmGraph
112 hooplGraph = g_graph cmmGraph
113 blockMap =
114 case hooplGraph of
115 GMany NothingO bm NothingO -> bm
116 in fixpointAnalysis dir lattice transfer entry blockMap initFact
117
118 -- Fixpoint algorithm.
119 fixpointAnalysis
120 :: forall f.
121 Direction
122 -> DataflowLattice f
123 -> TransferFun f
124 -> Label
125 -> LabelMap CmmBlock
126 -> FactBase f
127 -> FactBase f
128 fixpointAnalysis direction lattice do_block entry blockmap = loop start
129 where
130 -- Sorting the blocks helps to minimize the number of times we need to
131 -- process blocks. For instance, for forward analysis we want to look at
132 -- blocks in reverse postorder. Also, see comments for sortBlocks.
133 blocks = sortBlocks direction entry blockmap
134 num_blocks = length blocks
135 block_arr = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
136 start = {-# SCC "start" #-} IntSet.fromDistinctAscList
137 [0 .. num_blocks - 1]
138 dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
139 join = fact_join lattice
140
141 loop
142 :: IntHeap -- ^ Worklist, i.e., blocks to process
143 -> FactBase f -- ^ Current result (increases monotonically)
144 -> FactBase f
145 loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =
146 let block = block_arr ! index
147 out_facts = {-# SCC "do_block" #-} do_block block fbase1
148 -- For each of the outgoing edges, we join it with the current
149 -- information in fbase1 and (if something changed) we update it
150 -- and add the affected blocks to the worklist.
151 (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}
152 mapFoldlWithKey
153 (updateFact join dep_blocks) (todo1, fbase1) out_facts
154 in loop todo2 fbase2
155 loop _ !fbase1 = fbase1
156
157 rewriteCmmBwd
158 :: DataflowLattice f
159 -> RewriteFun f
160 -> CmmGraph
161 -> FactBase f
162 -> UniqSM (CmmGraph, FactBase f)
163 rewriteCmmBwd = rewriteCmm Bwd
164
165 rewriteCmm
166 :: Direction
167 -> DataflowLattice f
168 -> RewriteFun f
169 -> CmmGraph
170 -> FactBase f
171 -> UniqSM (CmmGraph, FactBase f)
172 rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do
173 let entry = g_entry cmmGraph
174 hooplGraph = g_graph cmmGraph
175 blockMap1 =
176 case hooplGraph of
177 GMany NothingO bm NothingO -> bm
178 (blockMap2, facts) <-
179 fixpointRewrite dir lattice rwFun entry blockMap1 initFact
180 return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)
181
182 fixpointRewrite
183 :: forall f.
184 Direction
185 -> DataflowLattice f
186 -> RewriteFun f
187 -> Label
188 -> LabelMap CmmBlock
189 -> FactBase f
190 -> UniqSM (LabelMap CmmBlock, FactBase f)
191 fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap
192 where
193 -- Sorting the blocks helps to minimize the number of times we need to
194 -- process blocks. For instance, for forward analysis we want to look at
195 -- blocks in reverse postorder. Also, see comments for sortBlocks.
196 blocks = sortBlocks dir entry blockmap
197 num_blocks = length blocks
198 block_arr = {-# SCC "block_arr_rewrite" #-}
199 listArray (0, num_blocks - 1) blocks
200 start = {-# SCC "start_rewrite" #-}
201 IntSet.fromDistinctAscList [0 .. num_blocks - 1]
202 dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks
203 join = fact_join lattice
204
205 loop
206 :: IntHeap -- ^ Worklist, i.e., blocks to process
207 -> LabelMap CmmBlock -- ^ Rewritten blocks.
208 -> FactBase f -- ^ Current facts.
209 -> UniqSM (LabelMap CmmBlock, FactBase f)
210 loop todo !blocks1 !fbase1
211 | Just (index, todo1) <- IntSet.minView todo = do
212 -- Note that we use the *original* block here. This is important.
213 -- We're optimistically rewriting blocks even before reaching the fixed
214 -- point, which means that the rewrite might be incorrect. So if the
215 -- facts change, we need to rewrite the original block again (taking
216 -- into account the new facts).
217 let block = block_arr ! index
218 (new_block, out_facts) <- {-# SCC "do_block_rewrite" #-}
219 do_block block fbase1
220 let blocks2 = mapInsert (entryLabel new_block) new_block blocks1
221 (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}
222 mapFoldlWithKey
223 (updateFact join dep_blocks) (todo1, fbase1) out_facts
224 loop todo2 blocks2 fbase2
225 loop _ !blocks1 !fbase1 = return (blocks1, fbase1)
226
227
228 {-
229 Note [Unreachable blocks]
230 ~~~~~~~~~~~~~~~~~~~~~~~~~
231 A block that is not in the domain of tfb_fbase is "currently unreachable".
232 A currently-unreachable block is not even analyzed. Reason: consider
233 constant prop and this graph, with entry point L1:
234 L1: x:=3; goto L4
235 L2: x:=4; goto L4
236 L4: if x>3 goto L2 else goto L5
237 Here L2 is actually unreachable, but if we process it with bottom input fact,
238 we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
239
240 * If a currently-unreachable block is not analyzed, then its rewritten
241 graph will not be accumulated in tfb_rg. And that is good:
242 unreachable blocks simply do not appear in the output.
243
244 * Note that clients must be careful to provide a fact (even if bottom)
245 for each entry point. Otherwise useful blocks may be garbage collected.
246
247 * Note that updateFact must set the change-flag if a label goes from
248 not-in-fbase to in-fbase, even if its fact is bottom. In effect the
249 real fact lattice is
250 UNR
251 bottom
252 the points above bottom
253
254 * Even if the fact is going from UNR to bottom, we still call the
255 client's fact_join function because it might give the client
256 some useful debugging information.
257
258 * All of this only applies for *forward* ixpoints. For the backward
259 case we must treat every block as reachable; it might finish with a
260 'return', and therefore have no successors, for example.
261 -}
262
263
264 -----------------------------------------------------------------------------
265 -- Pieces that are shared by fixpoint and fixpoint_anal
266 -----------------------------------------------------------------------------
267
268 -- | Sort the blocks into the right order for analysis. This means reverse
269 -- postorder for a forward analysis. For the backward one, we simply reverse
270 -- that (see Note [Backward vs forward analysis]).
271 sortBlocks
272 :: NonLocal n
273 => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
274 sortBlocks direction entry blockmap =
275 case direction of
276 Fwd -> fwd
277 Bwd -> reverse fwd
278 where
279 fwd = revPostorderFrom blockmap entry
280
281 -- Note [Backward vs forward analysis]
282 --
283 -- The forward and backward cases are not dual. In the forward case, the entry
284 -- points are known, and one simply traverses the body blocks from those points.
285 -- In the backward case, something is known about the exit points, but a
286 -- backward analysis must also include reachable blocks that don't reach the
287 -- exit, as in a procedure that loops forever and has side effects.)
288 -- For instance, let E be the entry and X the exit blocks (arrows indicate
289 -- control flow)
290 -- E -> X
291 -- E -> B
292 -- B -> C
293 -- C -> B
294 -- We do need to include B and C even though they're unreachable in the
295 -- *reverse* graph (that we could use for backward analysis):
296 -- E <- X
297 -- E <- B
298 -- B <- C
299 -- C <- B
300 -- So when sorting the blocks for the backward analysis, we simply take the
301 -- reverse of what is used for the forward one.
302
303
304 -- | Construct a mapping from a @Label@ to the block indexes that should be
305 -- re-analyzed if the facts at that @Label@ change.
306 --
307 -- Note that we're considering here the entry point of the block, so if the
308 -- facts change at the entry:
309 -- * for a backward analysis we need to re-analyze all the predecessors, but
310 -- * for a forward analysis, we only need to re-analyze the current block
311 -- (and that will in turn propagate facts into its successors).
312 mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet
313 mkDepBlocks Fwd blocks = go blocks 0 mapEmpty
314 where
315 go [] !_ !dep_map = dep_map
316 go (b:bs) !n !dep_map =
317 go bs (n + 1) $ mapInsert (entryLabel b) (IntSet.singleton n) dep_map
318 mkDepBlocks Bwd blocks = go blocks 0 mapEmpty
319 where
320 go [] !_ !dep_map = dep_map
321 go (b:bs) !n !dep_map =
322 let insert m l = mapInsertWith IntSet.union l (IntSet.singleton n) m
323 in go bs (n + 1) $ foldl' insert dep_map (successors b)
324
325 -- | After some new facts have been generated by analysing a block, we
326 -- fold this function over them to generate (a) a list of block
327 -- indices to (re-)analyse, and (b) the new FactBase.
328 updateFact
329 :: JoinFun f
330 -> LabelMap IntSet
331 -> (IntHeap, FactBase f)
332 -> Label
333 -> f -- out fact
334 -> (IntHeap, FactBase f)
335 updateFact fact_join dep_blocks (todo, fbase) lbl new_fact
336 = case lookupFact lbl fbase of
337 Nothing ->
338 -- Note [No old fact]
339 let !z = mapInsert lbl new_fact fbase in (changed, z)
340 Just old_fact ->
341 case fact_join (OldFact old_fact) (NewFact new_fact) of
342 (NotChanged _) -> (todo, fbase)
343 (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)
344 where
345 changed = todo `IntSet.union`
346 mapFindWithDefault IntSet.empty lbl dep_blocks
347
348 {-
349 Note [No old fact]
350
351 We know that the new_fact is >= _|_, so we don't need to join. However,
352 if the new fact is also _|_, and we have already analysed its block,
353 we don't need to record a change. So there's a tradeoff here. It turns
354 out that always recording a change is faster.
355 -}
356
357 ----------------------------------------------------------------
358 -- Utilities
359 ----------------------------------------------------------------
360
361 -- Fact lookup: the fact `orelse` bottom
362 getFact :: DataflowLattice f -> Label -> FactBase f -> f
363 getFact lat l fb = case lookupFact l fb of Just f -> f
364 Nothing -> fact_bot lat
365
366 -- | Returns the result of joining the facts from all the successors of the
367 -- provided node or block.
368 joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f
369 joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
370 where
371 join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
372 facts =
373 [ fromJust fact
374 | s <- successors nonLocal
375 , let fact = lookupFact s fact_base
376 , isJust fact
377 ]
378
379 joinFacts :: DataflowLattice f -> [f] -> f
380 joinFacts lattice facts = foldl' join (fact_bot lattice) facts
381 where
382 join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
383
384 -- | Returns the joined facts for each label.
385 mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
386 mkFactBase lattice = foldl' add mapEmpty
387 where
388 join = fact_join lattice
389
390 add result (l, f1) =
391 let !newFact =
392 case mapLookup l result of
393 Nothing -> f1
394 Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)
395 in mapInsert l newFact result
396
397 -- | Folds backward over all nodes of an open-open block.
398 -- Strict in the accumulator.
399 foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
400 foldNodesBwdOO funOO = go
401 where
402 go (BCat b1 b2) f = go b1 $! go b2 f
403 go (BSnoc h n) f = go h $! funOO n f
404 go (BCons n t) f = funOO n $! go t f
405 go (BMiddle n) f = funOO n f
406 go BNil f = f
407 {-# INLINABLE foldNodesBwdOO #-}
408
409 -- | Folds backward over all the nodes of an open-open block and allows
410 -- rewriting them. The accumulator is both the block of nodes and @f@ (usually
411 -- dataflow facts).
412 -- Strict in both accumulated parts.
413 foldRewriteNodesBwdOO
414 :: forall f.
415 (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))
416 -> Block CmmNode O O
417 -> f
418 -> UniqSM (Block CmmNode O O, f)
419 foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts
420 where
421 go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1
422 go (BSnoc block1 node1) !fact1 = (go block1 `comp` rewriteOO node1) fact1
423 go (BCat blockA1 blockB1) !fact1 = (go blockA1 `comp` go blockB1) fact1
424 go (BMiddle node) !fact1 = rewriteOO node fact1
425 go BNil !fact = return (BNil, fact)
426
427 comp rew1 rew2 = \f1 -> do
428 (b, f2) <- rew2 f1
429 (a, !f3) <- rew1 f2
430 let !c = joinBlocksOO a b
431 return (c, f3)
432 {-# INLINE comp #-}
433 {-# INLINABLE foldRewriteNodesBwdOO #-}
434
435 joinBlocksOO :: Block n O O -> Block n O O -> Block n O O
436 joinBlocksOO BNil b = b
437 joinBlocksOO b BNil = b
438 joinBlocksOO (BMiddle n) b = blockCons n b
439 joinBlocksOO b (BMiddle n) = blockSnoc b n
440 joinBlocksOO b1 b2 = BCat b1 b2
441
442 type IntHeap = IntSet