diff options
Diffstat (limited to 'compiler/cmm/CmmProcPoint.hs')
| -rw-r--r-- | compiler/cmm/CmmProcPoint.hs | 46 |
1 files changed, 24 insertions, 22 deletions
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 2e2c22c10d..bef8f384b8 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -8,7 +8,7 @@ module CmmProcPoint ) where -import Prelude hiding (last, unzip, succ, zip) +import GhcPrelude hiding (last, unzip, succ, zip) import DynFlags import BlockId @@ -19,7 +19,7 @@ import CmmUtils import CmmInfo import CmmLive import CmmSwitch -import Data.List (sortBy) +import Data.List (sortBy, foldl') import Maybes import Control.Monad import Outputable @@ -178,9 +178,9 @@ procPointLattice = DataflowLattice unreached add_to -- -- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds]. callProcPoints :: CmmGraph -> ProcPointSet -callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g - where add :: CmmBlock -> LabelSet -> LabelSet - add b set = case lastNode b of +callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g + where add :: LabelSet -> CmmBlock -> LabelSet + add set b = case lastNode b of CmmCall {cml_cont = Just k} -> setInsert k set CmmForeignCall {succ=k} -> setInsert k set _ -> set @@ -190,17 +190,17 @@ minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -- Given the set of successors of calls (which must be proc-points) -- figure out the minimal set of necessary proc-points minimalProcPointSet platform callProcPoints g - = extendPPSet platform g (postorderDfs g) callProcPoints + = extendPPSet platform g (revPostorder g) callProcPoints extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet extendPPSet platform g blocks procPoints = let env = procPointAnalysis procPoints g - add block pps = let id = entryLabel block + add pps block = let id = entryLabel block in case mapLookup id env of Just ProcPoint -> setInsert id pps _ -> pps - procPoints' = foldGraphBlocks add setEmpty g + procPoints' = foldlGraphBlocks add setEmpty g newPoints = mapMaybe ppSuccessor blocks newPoint = listToMaybe newPoints ppSuccessor b = @@ -242,11 +242,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap (CmmProc (TopInfo {info_tbls = info_tbls}) top_l _ g@(CmmGraph {g_entry=entry})) = do -- Build a map from procpoints to the blocks they reach - let addBlock - :: CmmBlock + let add_block + :: LabelMap (LabelMap CmmBlock) + -> CmmBlock -> LabelMap (LabelMap CmmBlock) - -> LabelMap (LabelMap CmmBlock) - addBlock b graphEnv = + add_block graphEnv b = case mapLookup bid procMap of Just ProcPoint -> add graphEnv bid bid b Just (ReachedBy set) -> @@ -265,7 +265,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap regSetToList $ expectJust "ppLiveness" $ mapLookup pp liveness - graphEnv <- return $ foldGraphBlocks addBlock mapEmpty g + graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g -- Build a map from proc point BlockId to pairs of: -- * Labels for their new procedures @@ -275,12 +275,13 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap let add_label map pp = mapInsert pp lbls map where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls)) | otherwise = (block_lbl, guard (setMember pp callPPs) >> - Just (toInfoLbl block_lbl)) - where block_lbl = blockLbl pp + Just info_table_lbl) + where block_lbl = blockLbl pp + info_table_lbl = infoTblLbl pp procLabels :: LabelMap (CLabel, Maybe CLabel) - procLabels = foldl add_label mapEmpty - (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) + procLabels = foldl' add_label mapEmpty + (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) -- In each new graph, add blocks jumping off to the new procedures, -- and replace branches to procpoints with branches to the jump-off blocks @@ -301,7 +302,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap -> UniqSM (LabelMap CmmGraph) add_jumps newGraphEnv (ppId, blockEnv) = do let needed_jumps = -- find which procpoints we currently branch to - mapFold add_if_branch_to_pp [] blockEnv + mapFoldr add_if_branch_to_pp [] blockEnv add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)] add_if_branch_to_pp block rst = case lastNode block of @@ -329,7 +330,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap -- replace branches to procpoints with branches to jumps blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv' -- add the jump blocks to the graph - blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks + blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks let g' = ofBlockMap ppId blockEnv''' -- pprTrace "g' pre jumps" (ppr g') $ do return (mapInsert ppId g' newGraphEnv) @@ -372,9 +373,10 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap -- call sites. Here, we sort them in reverse order -- it gets -- reversed later. let (_, block_order) = - foldl add_block_num (0::Int, mapEmpty :: LabelMap Int) - (postorderDfs g) - add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map) + foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int) + (revPostorder g) + add_block_num (i, map) block = + (i + 1, mapInsert (entryLabel block) i map) sort_fn (bid, _) (bid', _) = compare (expectJust "block_order" $ mapLookup bid block_order) (expectJust "block_order" $ mapLookup bid' block_order) |