Hoopl/Dataflow: use block-oriented interface
[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, Block
22 , lastNode, entryLabel
23 , foldNodesBwdOO
24 , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..), TransferFun
25 , Fact, FactBase
26 , getFact, mkFactBase
27 , analyzeCmmFwd, analyzeCmmBwd
28 , changedIf
29 , joinOutFacts
30 )
31 where
32
33 import BlockId
34 import Cmm
35
36 import Data.Array
37 import Data.List
38 import Data.Maybe
39
40 -- Hide definitions from Hoopl's Dataflow module.
41 import Compiler.Hoopl hiding ( DataflowLattice, OldFact, NewFact, JoinFun
42 , fact_bot, fact_join, joinOutFacts, mkFactBase
43 )
44
45 newtype OldFact a = OldFact a
46
47 newtype NewFact a = NewFact a
48
49 -- | The result of joining OldFact and NewFact.
50 data JoinedFact a
51 = Changed !a -- ^ Result is different than OldFact.
52 | NotChanged !a -- ^ Result is the same as OldFact.
53
54 getJoined :: JoinedFact a -> a
55 getJoined (Changed a) = a
56 getJoined (NotChanged a) = a
57
58 changedIf :: Bool -> a -> JoinedFact a
59 changedIf True = Changed
60 changedIf False = NotChanged
61
62 type JoinFun a = OldFact a -> NewFact a -> JoinedFact a
63
64 data DataflowLattice a = DataflowLattice
65 { fact_bot :: a
66 , fact_join :: JoinFun a
67 }
68
69 data Direction = Fwd | Bwd
70
71 type TransferFun f = CmmBlock -> FactBase f -> FactBase f
72
73 analyzeCmmBwd, analyzeCmmFwd
74 :: DataflowLattice f
75 -> TransferFun f
76 -> CmmGraph
77 -> FactBase f
78 -> FactBase f
79 analyzeCmmBwd = analyzeCmm Bwd
80 analyzeCmmFwd = analyzeCmm Fwd
81
82 analyzeCmm
83 :: Direction
84 -> DataflowLattice f
85 -> TransferFun f
86 -> CmmGraph
87 -> FactBase f
88 -> FactBase f
89 analyzeCmm dir lattice transfer cmmGraph initFact =
90 let entry = g_entry cmmGraph
91 hooplGraph = g_graph cmmGraph
92 blockMap =
93 case hooplGraph of
94 GMany NothingO bm NothingO -> bm
95 entries = if mapNull initFact then [entry] else mapKeys initFact
96 in fixpointAnalysis dir lattice transfer entries blockMap initFact
97
98 -- Fixpoint algorithm.
99 fixpointAnalysis
100 :: forall f.
101 Direction
102 -> DataflowLattice f
103 -> TransferFun f
104 -> [Label]
105 -> LabelMap CmmBlock
106 -> FactBase f
107 -> FactBase f
108 fixpointAnalysis direction lattice do_block entries blockmap = loop start
109 where
110 -- Sorting the blocks helps to minimize the number of times we need to
111 -- process blocks. For instance, for forward analysis we want to look at
112 -- blocks in reverse postorder. Also, see comments for sortBlocks.
113 blocks = sortBlocks direction entries blockmap
114 num_blocks = length blocks
115 block_arr = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
116 start = {-# SCC "start" #-} [0 .. num_blocks - 1]
117 dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
118 join = fact_join lattice
119
120 loop
121 :: IntHeap -- ^ Worklist, i.e., blocks to process
122 -> FactBase f -- ^ Current result (increases monotonically)
123 -> FactBase f
124 loop [] !fbase1 = fbase1
125 loop (index : todo1) !fbase1 =
126 let block = block_arr ! index
127 out_facts = {-# SCC "do_block" #-} do_block block fbase1
128 -- For each of the outgoing edges, we join it with the current
129 -- information in fbase1 and (if something changed) we update it
130 -- and add the affected blocks to the worklist.
131 (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}
132 mapFoldWithKey
133 (updateFact join dep_blocks) (todo1, fbase1) out_facts
134 in loop todo2 fbase2
135
136
137
138 {-
139 Note [Unreachable blocks]
140 ~~~~~~~~~~~~~~~~~~~~~~~~~
141 A block that is not in the domain of tfb_fbase is "currently unreachable".
142 A currently-unreachable block is not even analyzed. Reason: consider
143 constant prop and this graph, with entry point L1:
144 L1: x:=3; goto L4
145 L2: x:=4; goto L4
146 L4: if x>3 goto L2 else goto L5
147 Here L2 is actually unreachable, but if we process it with bottom input fact,
148 we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
149
150 * If a currently-unreachable block is not analyzed, then its rewritten
151 graph will not be accumulated in tfb_rg. And that is good:
152 unreachable blocks simply do not appear in the output.
153
154 * Note that clients must be careful to provide a fact (even if bottom)
155 for each entry point. Otherwise useful blocks may be garbage collected.
156
157 * Note that updateFact must set the change-flag if a label goes from
158 not-in-fbase to in-fbase, even if its fact is bottom. In effect the
159 real fact lattice is
160 UNR
161 bottom
162 the points above bottom
163
164 * Even if the fact is going from UNR to bottom, we still call the
165 client's fact_join function because it might give the client
166 some useful debugging information.
167
168 * All of this only applies for *forward* ixpoints. For the backward
169 case we must treat every block as reachable; it might finish with a
170 'return', and therefore have no successors, for example.
171 -}
172
173
174 -----------------------------------------------------------------------------
175 -- Pieces that are shared by fixpoint and fixpoint_anal
176 -----------------------------------------------------------------------------
177
178 -- | Sort the blocks into the right order for analysis. This means reverse
179 -- postorder for a forward analysis. For the backward one, we simply reverse
180 -- that (see Note [Backward vs forward analysis]).
181 --
182 -- Note: We're using Hoopl's confusingly named `postorder_dfs_from` but AFAICS
183 -- it returns the *reverse* postorder of the blocks (it visits blocks in the
184 -- postorder and uses (:) to collect them, which gives the reverse of the
185 -- visitation order).
186 sortBlocks
187 :: NonLocal n
188 => Direction -> [Label] -> LabelMap (Block n C C) -> [Block n C C]
189 sortBlocks direction entries blockmap =
190 case direction of
191 Fwd -> fwd
192 Bwd -> reverse fwd
193 where
194 fwd = postorder_dfs_from blockmap entries
195
196 -- Note [Backward vs forward analysis]
197 --
198 -- The forward and backward cases are not dual. In the forward case, the entry
199 -- points are known, and one simply traverses the body blocks from those points.
200 -- In the backward case, something is known about the exit points, but a
201 -- backward analysis must also include reachable blocks that don't reach the
202 -- exit, as in a procedure that loops forever and has side effects.)
203 -- For instance, let E be the entry and X the exit blocks (arrows indicate
204 -- control flow)
205 -- E -> X
206 -- E -> B
207 -- B -> C
208 -- C -> B
209 -- We do need to include B and C even though they're unreachable in the
210 -- *reverse* graph (that we could use for backward analysis):
211 -- E <- X
212 -- E <- B
213 -- B <- C
214 -- C <- B
215 -- So when sorting the blocks for the backward analysis, we simply take the
216 -- reverse of what is used for the forward one.
217
218
219 -- | construct a mapping from L -> block indices. If the fact for L
220 -- changes, re-analyse the given blocks.
221 mkDepBlocks :: NonLocal n => Direction -> [Block n C C] -> LabelMap [Int]
222 mkDepBlocks Fwd blocks = go blocks 0 mapEmpty
223 where go [] !_ m = m
224 go (b:bs) !n m = go bs (n+1) $! mapInsert (entryLabel b) [n] m
225 mkDepBlocks Bwd blocks = go blocks 0 mapEmpty
226 where go [] !_ m = m
227 go (b:bs) !n m = go bs (n+1) $! go' (successors b) m
228 where go' [] m = m
229 go' (l:ls) m = go' ls (mapInsertWith (++) l [n] m)
230
231
232 -- | After some new facts have been generated by analysing a block, we
233 -- fold this function over them to generate (a) a list of block
234 -- indices to (re-)analyse, and (b) the new FactBase.
235 --
236 updateFact :: JoinFun f -> LabelMap [Int]
237 -> Label -> f -- out fact
238 -> (IntHeap, FactBase f)
239 -> (IntHeap, FactBase f)
240
241 updateFact fact_join dep_blocks lbl new_fact (todo, fbase)
242 = case lookupFact lbl fbase of
243 Nothing -> let !z = mapInsert lbl new_fact fbase in (changed, z)
244 -- Note [no old fact]
245 Just old_fact ->
246 case fact_join (OldFact old_fact) (NewFact new_fact) of
247 (NotChanged _) -> (todo, fbase)
248 (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)
249 where
250 changed = foldr insertIntHeap todo $
251 mapFindWithDefault [] lbl dep_blocks
252
253 {-
254 Note [no old fact]
255
256 We know that the new_fact is >= _|_, so we don't need to join. However,
257 if the new fact is also _|_, and we have already analysed its block,
258 we don't need to record a change. So there's a tradeoff here. It turns
259 out that always recording a change is faster.
260 -}
261
262 ----------------------------------------------------------------
263 -- Utilities
264 ----------------------------------------------------------------
265
266 -- Fact lookup: the fact `orelse` bottom
267 getFact :: DataflowLattice f -> Label -> FactBase f -> f
268 getFact lat l fb = case lookupFact l fb of Just f -> f
269 Nothing -> fact_bot lat
270
271 -- | Returns the result of joining the facts from all the successors of the
272 -- provided node or block.
273 joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f
274 joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
275 where
276 join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
277 facts =
278 [ fromJust fact
279 | s <- successors nonLocal
280 , let fact = lookupFact s fact_base
281 , isJust fact
282 ]
283
284 -- | Returns the joined facts for each label.
285 mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
286 mkFactBase lattice = foldl' add mapEmpty
287 where
288 join = fact_join lattice
289
290 add result (l, f1) =
291 let !newFact =
292 case mapLookup l result of
293 Nothing -> f1
294 Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)
295 in mapInsert l newFact result
296
297 -- | Folds backward over all nodes of an open-open block.
298 -- Strict in the accumulator.
299 foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
300 foldNodesBwdOO funOO = go
301 where
302 go (BCat b1 b2) f = go b1 $! go b2 f
303 go (BSnoc h n) f = go h $! funOO n f
304 go (BCons n t) f = funOO n $! go t f
305 go (BMiddle n) f = funOO n f
306 go BNil f = f
307 {-# INLINABLE foldNodesBwdOO #-}
308
309 -- -----------------------------------------------------------------------------
310 -- a Heap of Int
311
312 -- We should really use a proper Heap here, but my attempts to make
313 -- one have not succeeded in beating the simple ordered list. Another
314 -- alternative is IntSet (using deleteFindMin), but that was also
315 -- slower than the ordered list in my experiments --SDM 25/1/2012
316
317 type IntHeap = [Int] -- ordered
318
319 insertIntHeap :: Int -> [Int] -> [Int]
320 insertIntHeap x [] = [x]
321 insertIntHeap x (y:ys)
322 | x < y = x : y : ys
323 | x == y = x : ys
324 | otherwise = y : insertIntHeap x ys