c28edb0d9583943ca0e3f8cc42ab6632dbfb4860
[ghc.git] / compiler / cmm / Hoopl / Dataflow.hs
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE RankNTypes #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# OPTIONS_GHC -fprof-auto-top #-}
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 Hoopl.Dataflow
21 ( C, O, DataflowLattice(..), OldFact(..), NewFact(..), Fact, FactBase
22 , mkFactBase
23 , JoinedFact(..)
24 , FwdPass(..), FwdTransfer, mkFTransfer3
25
26 , BwdPass(..), BwdTransfer, mkBTransfer3
27
28 , dataflowAnalFwdBlocks, dataflowAnalBwd
29 , analyzeFwd, analyzeFwdBlocks, analyzeBwd
30
31 , changedIf
32 , joinOutFacts
33 )
34 where
35
36 import BlockId
37 import Cmm
38
39 import Data.Array
40 import Data.List
41 import Data.Maybe
42
43 -- Hide definitions from Hoopl's Dataflow module.
44 import Compiler.Hoopl hiding ( DataflowLattice, OldFact, NewFact, JoinFun
45 , fact_bot, fact_join, joinOutFacts, mkFactBase
46 )
47
48 newtype OldFact a = OldFact a
49
50 newtype NewFact a = NewFact a
51
52 -- | The result of joining OldFact and NewFact.
53 data JoinedFact a
54 = Changed !a -- ^ Result is different than OldFact.
55 | NotChanged !a -- ^ Result is the same as OldFact.
56
57 getJoined :: JoinedFact a -> a
58 getJoined (Changed a) = a
59 getJoined (NotChanged a) = a
60
61 changedIf :: Bool -> a -> JoinedFact a
62 changedIf True = Changed
63 changedIf False = NotChanged
64
65 type JoinFun a = OldFact a -> NewFact a -> JoinedFact a
66
67 data DataflowLattice a = DataflowLattice
68 { fact_bot :: a
69 , fact_join :: JoinFun a
70 }
71
72 -- TODO(michalt): This wrapper will go away once we refactor the analyze*
73 -- methods.
74 dataflowAnalFwdBlocks
75 :: NonLocal n
76 => GenCmmGraph n
77 -> [(BlockId, f)]
78 -> DataflowLattice f
79 -> FwdTransfer n f
80 -> BlockEnv f
81 dataflowAnalFwdBlocks
82 (CmmGraph {g_entry = entry, g_graph = graph}) facts lattice xfer =
83 analyzeFwdBlocks
84 lattice xfer (JustC [entry]) graph (mkFactBase lattice facts)
85
86 -- TODO(michalt): This wrapper will go away once we refactor the analyze*
87 -- methods.
88 dataflowAnalBwd
89 :: NonLocal n
90 => GenCmmGraph n
91 -> [(BlockId, f)]
92 -> DataflowLattice f
93 -> BwdTransfer n f
94 -> BlockEnv f
95 dataflowAnalBwd
96 (CmmGraph {g_entry = entry, g_graph = graph}) facts lattice xfer =
97 analyzeBwd lattice xfer (JustC [entry]) graph (mkFactBase lattice facts)
98
99
100 ----------------------------------------------------------------
101 -- Forward Analysis only
102 ----------------------------------------------------------------
103
104 -- | if the graph being analyzed is open at the entry, there must
105 -- be no other entry point, or all goes horribly wrong...
106 analyzeFwd
107 :: forall n f e . NonLocal n
108 => DataflowLattice f
109 -> FwdTransfer n f
110 -> MaybeC e [Label]
111 -> Graph n e C -> Fact e f
112 -> FactBase f
113 analyzeFwd lattice (FwdTransfer3 (ftr, mtr, ltr)) entries g in_fact =
114 graph g in_fact
115 where
116 graph :: Graph n e C -> Fact e f -> FactBase f
117 graph (GMany entry blockmap NothingO)
118 = case (entries, entry) of
119 (NothingC, JustO entry) -> block entry `cat` body (successors entry)
120 (JustC entries, NothingO) -> body entries
121 where
122 body :: [Label] -> Fact C f -> Fact C f
123 body entries f
124 = fixpointAnal Fwd lattice do_block entries blockmap f
125 where
126 do_block :: forall x . Block n C x -> FactBase f -> Fact x f
127 do_block b fb = block b entryFact
128 where entryFact = getFact lattice (entryLabel b) fb
129
130 -- NB. eta-expand block, GHC can't do this by itself. See #5809.
131 block :: forall e x . Block n e x -> f -> Fact x f
132 block BNil f = f
133 block (BlockCO n b) f = (ftr n `cat` block b) f
134 block (BlockCC l b n) f = (ftr l `cat` (block b `cat` ltr n)) f
135 block (BlockOC b n) f = (block b `cat` ltr n) f
136
137 block (BMiddle n) f = mtr n f
138 block (BCat b1 b2) f = (block b1 `cat` block b2) f
139 block (BSnoc h n) f = (block h `cat` mtr n) f
140 block (BCons n t) f = (mtr n `cat` block t) f
141
142 {-# INLINE cat #-}
143 cat :: forall f1 f2 f3 . (f1 -> f2) -> (f2 -> f3) -> (f1 -> f3)
144 cat ft1 ft2 = \f -> ft2 $! ft1 f
145
146 -- | if the graph being analyzed is open at the entry, there must
147 -- be no other entry point, or all goes horribly wrong...
148 analyzeFwdBlocks
149 :: forall n f e . NonLocal n
150 => DataflowLattice f
151 -> FwdTransfer n f
152 -> MaybeC e [Label]
153 -> Graph n e C -> Fact e f
154 -> FactBase f
155 analyzeFwdBlocks lattice (FwdTransfer3 (ftr, _, ltr)) entries g in_fact =
156 graph g in_fact
157 where
158 graph :: Graph n e C -> Fact e f -> FactBase f
159 graph (GMany entry blockmap NothingO)
160 = case (entries, entry) of
161 (NothingC, JustO entry) -> block entry `cat` body (successors entry)
162 (JustC entries, NothingO) -> body entries
163 where
164 body :: [Label] -> Fact C f -> Fact C f
165 body entries f
166 = fixpointAnal Fwd lattice do_block entries blockmap f
167 where
168 do_block :: forall x . Block n C x -> FactBase f -> Fact x f
169 do_block b fb = block b entryFact
170 where entryFact = getFact lattice (entryLabel b) fb
171
172 -- NB. eta-expand block, GHC can't do this by itself. See #5809.
173 block :: forall e x . Block n e x -> f -> Fact x f
174 block BNil f = f
175 block (BlockCO n _) f = ftr n f
176 block (BlockCC l _ n) f = (ftr l `cat` ltr n) f
177 block (BlockOC _ n) f = ltr n f
178 block _ _ = error "analyzeFwdBlocks"
179
180 {-# INLINE cat #-}
181 cat :: forall f1 f2 f3 . (f1 -> f2) -> (f2 -> f3) -> (f1 -> f3)
182 cat ft1 ft2 = \f -> ft2 $! ft1 f
183
184 ----------------------------------------------------------------
185 -- Backward Analysis only
186 ----------------------------------------------------------------
187
188 -- | if the graph being analyzed is open at the entry, there must
189 -- be no other entry point, or all goes horribly wrong...
190 analyzeBwd
191 :: forall n f e . NonLocal n
192 => DataflowLattice f
193 -> BwdTransfer n f
194 -> MaybeC e [Label]
195 -> Graph n e C -> Fact C f
196 -> FactBase f
197 analyzeBwd lattice (BwdTransfer3 (ftr, mtr, ltr)) entries g in_fact =
198 graph g in_fact
199 where
200 graph :: Graph n e C -> Fact C f -> FactBase f
201 graph (GMany entry blockmap NothingO)
202 = case (entries, entry) of
203 (NothingC, JustO entry) -> body (successors entry)
204 (JustC entries, NothingO) -> body entries
205 where
206 body :: [Label] -> Fact C f -> Fact C f
207 body entries f
208 = fixpointAnal Bwd lattice do_block entries blockmap f
209 where
210 do_block :: forall x . Block n C x -> Fact x f -> FactBase f
211 do_block b fb = mapSingleton (entryLabel b) (block b fb)
212
213 -- NB. eta-expand block, GHC can't do this by itself. See #5809.
214 block :: forall e x . Block n e x -> Fact x f -> f
215 block BNil f = f
216 block (BlockCO n b) f = (ftr n `cat` block b) f
217 block (BlockCC l b n) f = ((ftr l `cat` block b) `cat` ltr n) f
218 block (BlockOC b n) f = (block b `cat` ltr n) f
219
220 block (BMiddle n) f = mtr n f
221 block (BCat b1 b2) f = (block b1 `cat` block b2) f
222 block (BSnoc h n) f = (block h `cat` mtr n) f
223 block (BCons n t) f = (mtr n `cat` block t) f
224
225 {-# INLINE cat #-}
226 cat :: forall f1 f2 f3 . (f2 -> f3) -> (f1 -> f2) -> (f1 -> f3)
227 cat ft1 ft2 = \f -> ft1 $! ft2 f
228
229
230 -----------------------------------------------------------------------------
231 -- fixpoint
232 -----------------------------------------------------------------------------
233
234 data Direction = Fwd | Bwd
235
236 -- | fixpointing for analysis-only
237 --
238 fixpointAnal :: forall n f. NonLocal n
239 => Direction
240 -> DataflowLattice f
241 -> (Block n C C -> Fact C f -> Fact C f)
242 -> [Label]
243 -> LabelMap (Block n C C)
244 -> Fact C f -> FactBase f
245
246 fixpointAnal direction DataflowLattice{ fact_bot = _, fact_join = join }
247 do_block entries blockmap init_fbase
248 = loop start init_fbase
249 where
250 blocks = sortBlocks direction entries blockmap
251 n = length blocks
252 block_arr = {-# SCC "block_arr" #-} listArray (0,n-1) blocks
253 start = {-# SCC "start" #-} [0..n-1]
254 dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
255
256 loop
257 :: IntHeap -- blocks still to analyse
258 -> FactBase f -- current factbase (increases monotonically)
259 -> FactBase f
260
261 loop [] fbase = fbase
262 loop (ix:todo) fbase =
263 let
264 blk = block_arr ! ix
265
266 out_facts = {-# SCC "do_block" #-} do_block blk fbase
267
268 !(todo', fbase') = {-# SCC "mapFoldWithKey" #-}
269 mapFoldWithKey (updateFact join dep_blocks)
270 (todo,fbase) out_facts
271 in
272 -- trace ("analysing: " ++ show (entryLabel blk)) $
273 -- trace ("fbase': " ++ show (mapKeys fbase')) $ return ()
274 -- trace ("changed: " ++ show changed) $ return ()
275 -- trace ("to analyse: " ++ show to_analyse) $ return ()
276
277 loop todo' fbase'
278
279
280 {-
281 Note [Unreachable blocks]
282 ~~~~~~~~~~~~~~~~~~~~~~~~~
283 A block that is not in the domain of tfb_fbase is "currently unreachable".
284 A currently-unreachable block is not even analyzed. Reason: consider
285 constant prop and this graph, with entry point L1:
286 L1: x:=3; goto L4
287 L2: x:=4; goto L4
288 L4: if x>3 goto L2 else goto L5
289 Here L2 is actually unreachable, but if we process it with bottom input fact,
290 we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
291
292 * If a currently-unreachable block is not analyzed, then its rewritten
293 graph will not be accumulated in tfb_rg. And that is good:
294 unreachable blocks simply do not appear in the output.
295
296 * Note that clients must be careful to provide a fact (even if bottom)
297 for each entry point. Otherwise useful blocks may be garbage collected.
298
299 * Note that updateFact must set the change-flag if a label goes from
300 not-in-fbase to in-fbase, even if its fact is bottom. In effect the
301 real fact lattice is
302 UNR
303 bottom
304 the points above bottom
305
306 * Even if the fact is going from UNR to bottom, we still call the
307 client's fact_join function because it might give the client
308 some useful debugging information.
309
310 * All of this only applies for *forward* ixpoints. For the backward
311 case we must treat every block as reachable; it might finish with a
312 'return', and therefore have no successors, for example.
313 -}
314
315
316 -----------------------------------------------------------------------------
317 -- Pieces that are shared by fixpoint and fixpoint_anal
318 -----------------------------------------------------------------------------
319
320 -- | Sort the blocks into the right order for analysis. This means reverse
321 -- postorder for a forward analysis. For the backward one, we simply reverse
322 -- that (see Note [Backward vs forward analysis]).
323 --
324 -- Note: We're using Hoopl's confusingly named `postorder_dfs_from` but AFAICS
325 -- it returns the *reverse* postorder of the blocks (it visits blocks in the
326 -- postorder and uses (:) to collect them, which gives the reverse of the
327 -- visitation order).
328 sortBlocks
329 :: NonLocal n
330 => Direction -> [Label] -> LabelMap (Block n C C) -> [Block n C C]
331 sortBlocks direction entries blockmap =
332 case direction of
333 Fwd -> fwd
334 Bwd -> reverse fwd
335 where
336 fwd = postorder_dfs_from blockmap entries
337
338 -- Note [Backward vs forward analysis]
339 --
340 -- The forward and backward cases are not dual. In the forward case, the entry
341 -- points are known, and one simply traverses the body blocks from those points.
342 -- In the backward case, something is known about the exit points, but a
343 -- backward analysis must also include reachable blocks that don't reach the
344 -- exit, as in a procedure that loops forever and has side effects.)
345 -- For instance, let E be the entry and X the exit blocks (arrows indicate
346 -- control flow)
347 -- E -> X
348 -- E -> B
349 -- B -> C
350 -- C -> B
351 -- We do need to include B and C even though they're unreachable in the
352 -- *reverse* graph (that we could use for backward analysis):
353 -- E <- X
354 -- E <- B
355 -- B <- C
356 -- C <- B
357 -- So when sorting the blocks for the backward analysis, we simply take the
358 -- reverse of what is used for the forward one.
359
360
361 -- | construct a mapping from L -> block indices. If the fact for L
362 -- changes, re-analyse the given blocks.
363 mkDepBlocks :: NonLocal n => Direction -> [Block n C C] -> LabelMap [Int]
364 mkDepBlocks Fwd blocks = go blocks 0 mapEmpty
365 where go [] !_ m = m
366 go (b:bs) !n m = go bs (n+1) $! mapInsert (entryLabel b) [n] m
367 mkDepBlocks Bwd blocks = go blocks 0 mapEmpty
368 where go [] !_ m = m
369 go (b:bs) !n m = go bs (n+1) $! go' (successors b) m
370 where go' [] m = m
371 go' (l:ls) m = go' ls (mapInsertWith (++) l [n] m)
372
373
374 -- | After some new facts have been generated by analysing a block, we
375 -- fold this function over them to generate (a) a list of block
376 -- indices to (re-)analyse, and (b) the new FactBase.
377 --
378 updateFact :: JoinFun f -> LabelMap [Int]
379 -> Label -> f -- out fact
380 -> (IntHeap, FactBase f)
381 -> (IntHeap, FactBase f)
382
383 updateFact fact_join dep_blocks lbl new_fact (todo, fbase)
384 = case lookupFact lbl fbase of
385 Nothing -> let !z = mapInsert lbl new_fact fbase in (changed, z)
386 -- Note [no old fact]
387 Just old_fact ->
388 case fact_join (OldFact old_fact) (NewFact new_fact) of
389 (NotChanged _) -> (todo, fbase)
390 (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)
391 where
392 changed = foldr insertIntHeap todo $
393 mapFindWithDefault [] lbl dep_blocks
394
395 {-
396 Note [no old fact]
397
398 We know that the new_fact is >= _|_, so we don't need to join. However,
399 if the new fact is also _|_, and we have already analysed its block,
400 we don't need to record a change. So there's a tradeoff here. It turns
401 out that always recording a change is faster.
402 -}
403
404 ----------------------------------------------------------------
405 -- Utilities
406 ----------------------------------------------------------------
407
408 -- Fact lookup: the fact `orelse` bottom
409 getFact :: DataflowLattice f -> Label -> FactBase f -> f
410 getFact lat l fb = case lookupFact l fb of Just f -> f
411 Nothing -> fact_bot lat
412
413 -- | Returns the result of joining the facts from all the successors of the
414 -- provided node or block.
415 joinOutFacts :: (NonLocal n) => DataflowLattice f -> n O C -> FactBase f -> f
416 joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
417 where
418 join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
419 facts =
420 [ fromJust fact
421 | s <- successors nonLocal
422 , let fact = lookupFact s fact_base
423 , isJust fact
424 ]
425
426 -- | Returns the joined facts for each label.
427 mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
428 mkFactBase lattice = foldl' add mapEmpty
429 where
430 join = fact_join lattice
431
432 add result (l, f1) =
433 let !newFact =
434 case mapLookup l result of
435 Nothing -> f1
436 Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)
437 in mapInsert l newFact result
438
439
440 -- -----------------------------------------------------------------------------
441 -- a Heap of Int
442
443 -- We should really use a proper Heap here, but my attempts to make
444 -- one have not succeeded in beating the simple ordered list. Another
445 -- alternative is IntSet (using deleteFindMin), but that was also
446 -- slower than the ordered list in my experiments --SDM 25/1/2012
447
448 type IntHeap = [Int] -- ordered
449
450 insertIntHeap :: Int -> [Int] -> [Int]
451 insertIntHeap x [] = [x]
452 insertIntHeap x (y:ys)
453 | x < y = x : y : ys
454 | x == y = x : ys
455 | otherwise = y : insertIntHeap x ys