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