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