diff options
Diffstat (limited to 'compiler/cmm/Hoopl/Dataflow.hs')
| -rw-r--r-- | compiler/cmm/Hoopl/Dataflow.hs | 80 |
1 files changed, 34 insertions, 46 deletions
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs index c2ace502b3..bf12b3f6a1 100644 --- a/compiler/cmm/Hoopl/Dataflow.hs +++ b/compiler/cmm/Hoopl/Dataflow.hs @@ -30,14 +30,16 @@ module Hoopl.Dataflow , rewriteCmmBwd , changedIf , joinOutFacts + , joinFacts ) where +import GhcPrelude + import Cmm import UniqSupply import Data.Array -import Data.List import Data.Maybe import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -109,8 +111,7 @@ analyzeCmm dir lattice transfer cmmGraph initFact = blockMap = case hooplGraph of GMany NothingO bm NothingO -> bm - entries = if mapNull initFact then [entry] else mapKeys initFact - in fixpointAnalysis dir lattice transfer entries blockMap initFact + in fixpointAnalysis dir lattice transfer entry blockMap initFact -- Fixpoint algorithm. fixpointAnalysis @@ -118,19 +119,20 @@ fixpointAnalysis Direction -> DataflowLattice f -> TransferFun f - -> [Label] + -> Label -> LabelMap CmmBlock -> FactBase f -> FactBase f -fixpointAnalysis direction lattice do_block entries blockmap = loop start +fixpointAnalysis direction lattice do_block entry blockmap = loop start where -- Sorting the blocks helps to minimize the number of times we need to -- process blocks. For instance, for forward analysis we want to look at -- blocks in reverse postorder. Also, see comments for sortBlocks. - blocks = sortBlocks direction entries blockmap + blocks = sortBlocks direction entry blockmap num_blocks = length blocks block_arr = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks - start = {-# SCC "start" #-} [0 .. num_blocks - 1] + start = {-# SCC "start" #-} IntSet.fromDistinctAscList + [0 .. num_blocks - 1] dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks join = fact_join lattice @@ -138,17 +140,17 @@ fixpointAnalysis direction lattice do_block entries blockmap = loop start :: IntHeap -- ^ Worklist, i.e., blocks to process -> FactBase f -- ^ Current result (increases monotonically) -> FactBase f - loop [] !fbase1 = fbase1 - loop (index : todo1) !fbase1 = + loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo = let block = block_arr ! index out_facts = {-# SCC "do_block" #-} do_block block fbase1 -- For each of the outgoing edges, we join it with the current -- information in fbase1 and (if something changed) we update it -- and add the affected blocks to the worklist. (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-} - mapFoldWithKey + mapFoldlWithKey (updateFact join dep_blocks) (todo1, fbase1) out_facts in loop todo2 fbase2 + loop _ !fbase1 = fbase1 rewriteCmmBwd :: DataflowLattice f @@ -171,9 +173,8 @@ rewriteCmm dir lattice rwFun cmmGraph initFact = do blockMap1 = case hooplGraph of GMany NothingO bm NothingO -> bm - entries = if mapNull initFact then [entry] else mapKeys initFact (blockMap2, facts) <- - fixpointRewrite dir lattice rwFun entries blockMap1 initFact + fixpointRewrite dir lattice rwFun entry blockMap1 initFact return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts) fixpointRewrite @@ -181,20 +182,21 @@ fixpointRewrite Direction -> DataflowLattice f -> RewriteFun f - -> [Label] + -> Label -> LabelMap CmmBlock -> FactBase f -> UniqSM (LabelMap CmmBlock, FactBase f) -fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap +fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap where -- Sorting the blocks helps to minimize the number of times we need to -- process blocks. For instance, for forward analysis we want to look at -- blocks in reverse postorder. Also, see comments for sortBlocks. - blocks = sortBlocks dir entries blockmap + blocks = sortBlocks dir entry blockmap num_blocks = length blocks block_arr = {-# SCC "block_arr_rewrite" #-} listArray (0, num_blocks - 1) blocks - start = {-# SCC "start_rewrite" #-} [0 .. num_blocks - 1] + start = {-# SCC "start_rewrite" #-} + IntSet.fromDistinctAscList [0 .. num_blocks - 1] dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks join = fact_join lattice @@ -203,8 +205,8 @@ fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap -> LabelMap CmmBlock -- ^ Rewritten blocks. -> FactBase f -- ^ Current facts. -> UniqSM (LabelMap CmmBlock, FactBase f) - loop [] !blocks1 !fbase1 = return (blocks1, fbase1) - loop (index : todo1) !blocks1 !fbase1 = do + loop todo !blocks1 !fbase1 + | Just (index, todo1) <- IntSet.minView todo = do -- Note that we use the *original* block here. This is important. -- We're optimistically rewriting blocks even before reaching the fixed -- point, which means that the rewrite might be incorrect. So if the @@ -215,9 +217,10 @@ fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap do_block block fbase1 let blocks2 = mapInsert (entryLabel new_block) new_block blocks1 (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-} - mapFoldWithKey + mapFoldlWithKey (updateFact join dep_blocks) (todo1, fbase1) out_facts loop todo2 blocks2 fbase2 + loop _ !blocks1 !fbase1 = return (blocks1, fbase1) {- @@ -263,20 +266,15 @@ we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4. -- | Sort the blocks into the right order for analysis. This means reverse -- postorder for a forward analysis. For the backward one, we simply reverse -- that (see Note [Backward vs forward analysis]). --- --- Note: We're using Hoopl's confusingly named `postorder_dfs_from` but AFAICS --- it returns the *reverse* postorder of the blocks (it visits blocks in the --- postorder and uses (:) to collect them, which gives the reverse of the --- visitation order). sortBlocks :: NonLocal n - => Direction -> [Label] -> LabelMap (Block n C C) -> [Block n C C] -sortBlocks direction entries blockmap = + => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C] +sortBlocks direction entry blockmap = case direction of Fwd -> fwd Bwd -> reverse fwd where - fwd = postorder_dfs_from blockmap entries + fwd = revPostorderFrom blockmap entry -- Note [Backward vs forward analysis] -- @@ -328,11 +326,11 @@ mkDepBlocks Bwd blocks = go blocks 0 mapEmpty updateFact :: JoinFun f -> LabelMap IntSet + -> (IntHeap, FactBase f) -> Label -> f -- out fact -> (IntHeap, FactBase f) - -> (IntHeap, FactBase f) -updateFact fact_join dep_blocks lbl new_fact (todo, fbase) +updateFact fact_join dep_blocks (todo, fbase) lbl new_fact = case lookupFact lbl fbase of Nothing -> -- Note [No old fact] @@ -342,7 +340,7 @@ updateFact fact_join dep_blocks lbl new_fact (todo, fbase) (NotChanged _) -> (todo, fbase) (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z) where - changed = IntSet.foldr insertIntHeap todo $ + changed = todo `IntSet.union` mapFindWithDefault IntSet.empty lbl dep_blocks {- @@ -376,6 +374,11 @@ joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts , isJust fact ] +joinFacts :: DataflowLattice f -> [f] -> f +joinFacts lattice facts = foldl' join (fact_bot lattice) facts + where + join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new) + -- | Returns the joined facts for each label. mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f mkFactBase lattice = foldl' add mapEmpty @@ -434,19 +437,4 @@ joinBlocksOO (BMiddle n) b = blockCons n b joinBlocksOO b (BMiddle n) = blockSnoc b n joinBlocksOO b1 b2 = BCat b1 b2 --- ----------------------------------------------------------------------------- --- a Heap of Int - --- We should really use a proper Heap here, but my attempts to make --- one have not succeeded in beating the simple ordered list. Another --- alternative is IntSet (using deleteFindMin), but that was also --- slower than the ordered list in my experiments --SDM 25/1/2012 - -type IntHeap = [Int] -- ordered - -insertIntHeap :: Int -> [Int] -> [Int] -insertIntHeap x [] = [x] -insertIntHeap x (y:ys) - | x < y = x : y : ys - | x == y = x : ys - | otherwise = y : insertIntHeap x ys +type IntHeap = IntSet |