Commit 2974b2b8 authored by Michal Terepeta's avatar Michal Terepeta Committed by Ben Gamari

Hoopl.Collections: change right folds to strict left folds

It seems that most uses of these folds should be strict left folds
(I could only find a single place that benefits from a right fold).
So this removes the existing `setFold`/`mapFold`/`mapFoldWihKey`
replaces them with:
- `setFoldl`/`mapFoldl`/`mapFoldlWithKey` (strict left folds)
- `setFoldr`/`mapFoldr` (for the less common case where a right fold
  actually makes sense, e.g., `CmmProcPoint`)
Signed-off-by: Michal Terepeta's avatarMichal Terepeta <michal.terepeta@gmail.com>

Test Plan: ./validate

Reviewers: bgamari, simonmar

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter, kavon

Differential Revision: https://phabricator.haskell.org/D4356
parent e31b41bd
...@@ -426,8 +426,8 @@ copyTicks env g ...@@ -426,8 +426,8 @@ copyTicks env g
| otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap | otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
where -- Reverse block merge map where -- Reverse block merge map
blockMap = toBlockMap g blockMap = toBlockMap g
revEnv = mapFoldWithKey insertRev M.empty env revEnv = mapFoldlWithKey insertRev M.empty env
insertRev k x = M.insertWith (const (k:)) x [k] insertRev m k x = M.insertWith (const (k:)) x [k] m
-- Copy ticks and scopes into the given block -- Copy ticks and scopes into the given block
copyTo block = case M.lookup (entryLabel block) revEnv of copyTo block = case M.lookup (entryLabel block) revEnv of
Nothing -> block Nothing -> block
......
...@@ -427,10 +427,10 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g) ...@@ -427,10 +427,10 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
-- Remove any info_tbls for unreachable -- Remove any info_tbls for unreachable
keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable
keep_used bs = mapFoldWithKey keep mapEmpty bs keep_used bs = mapFoldlWithKey keep mapEmpty bs
keep :: Label -> CmmInfoTable -> LabelMap CmmInfoTable -> LabelMap CmmInfoTable keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
keep l i env | l `setMember` used_lbls = mapInsert l i env keep env l i | l `setMember` used_lbls = mapInsert l i env
| otherwise = env | otherwise = env
used_blocks :: [CmmBlock] used_blocks :: [CmmBlock]
......
...@@ -178,9 +178,9 @@ procPointLattice = DataflowLattice unreached add_to ...@@ -178,9 +178,9 @@ procPointLattice = DataflowLattice unreached add_to
-- --
-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds]. -- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
callProcPoints :: CmmGraph -> ProcPointSet callProcPoints :: CmmGraph -> ProcPointSet
callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g
where add :: CmmBlock -> LabelSet -> LabelSet where add :: LabelSet -> CmmBlock -> LabelSet
add b set = case lastNode b of add set b = case lastNode b of
CmmCall {cml_cont = Just k} -> setInsert k set CmmCall {cml_cont = Just k} -> setInsert k set
CmmForeignCall {succ=k} -> setInsert k set CmmForeignCall {succ=k} -> setInsert k set
_ -> set _ -> set
...@@ -196,11 +196,11 @@ extendPPSet ...@@ -196,11 +196,11 @@ extendPPSet
:: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
extendPPSet platform g blocks procPoints = extendPPSet platform g blocks procPoints =
let env = procPointAnalysis procPoints g 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 in case mapLookup id env of
Just ProcPoint -> setInsert id pps Just ProcPoint -> setInsert id pps
_ -> pps _ -> pps
procPoints' = foldGraphBlocks add setEmpty g procPoints' = foldlGraphBlocks add setEmpty g
newPoints = mapMaybe ppSuccessor blocks newPoints = mapMaybe ppSuccessor blocks
newPoint = listToMaybe newPoints newPoint = listToMaybe newPoints
ppSuccessor b = ppSuccessor b =
...@@ -243,10 +243,10 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -243,10 +243,10 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
top_l _ g@(CmmGraph {g_entry=entry})) = top_l _ g@(CmmGraph {g_entry=entry})) =
do -- Build a map from procpoints to the blocks they reach do -- Build a map from procpoints to the blocks they reach
let addBlock let addBlock
:: CmmBlock :: LabelMap (LabelMap CmmBlock)
-> CmmBlock
-> LabelMap (LabelMap CmmBlock) -> LabelMap (LabelMap CmmBlock)
-> LabelMap (LabelMap CmmBlock) addBlock graphEnv b =
addBlock b graphEnv =
case mapLookup bid procMap of case mapLookup bid procMap of
Just ProcPoint -> add graphEnv bid bid b Just ProcPoint -> add graphEnv bid bid b
Just (ReachedBy set) -> Just (ReachedBy set) ->
...@@ -265,7 +265,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -265,7 +265,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
regSetToList $ regSetToList $
expectJust "ppLiveness" $ mapLookup pp liveness expectJust "ppLiveness" $ mapLookup pp liveness
graphEnv <- return $ foldGraphBlocks addBlock mapEmpty g graphEnv <- return $ foldlGraphBlocks addBlock mapEmpty g
-- Build a map from proc point BlockId to pairs of: -- Build a map from proc point BlockId to pairs of:
-- * Labels for their new procedures -- * Labels for their new procedures
...@@ -302,7 +302,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -302,7 +302,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
-> UniqSM (LabelMap CmmGraph) -> UniqSM (LabelMap CmmGraph)
add_jumps newGraphEnv (ppId, blockEnv) = add_jumps newGraphEnv (ppId, blockEnv) =
do let needed_jumps = -- find which procpoints we currently branch to 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 :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
add_if_branch_to_pp block rst = add_if_branch_to_pp block rst =
case lastNode block of case lastNode block of
......
...@@ -56,7 +56,7 @@ module CmmUtils( ...@@ -56,7 +56,7 @@ module CmmUtils(
ofBlockMap, toBlockMap, insertBlock, ofBlockMap, toBlockMap, insertBlock,
ofBlockList, toBlockList, bodyToBlockList, ofBlockList, toBlockList, bodyToBlockList,
toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough, toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1, foldlGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
-- * Ticks -- * Ticks
blockTicks blockTicks
...@@ -552,8 +552,8 @@ mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGra ...@@ -552,8 +552,8 @@ mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGra
mapGraphNodes1 f = modifyGraph (mapGraph f) mapGraphNodes1 f = modifyGraph (mapGraph f)
foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldGraphBlocks k z g = mapFold k z $ toBlockMap g foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
postorderDfs :: CmmGraph -> [CmmBlock] postorderDfs :: CmmGraph -> [CmmBlock]
postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g) postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)
......
...@@ -34,7 +34,8 @@ class IsSet set where ...@@ -34,7 +34,8 @@ class IsSet set where
setIntersection :: set -> set -> set setIntersection :: set -> set -> set
setIsSubsetOf :: set -> set -> Bool setIsSubsetOf :: set -> set -> Bool
setFold :: (ElemOf set -> b -> b) -> b -> set -> b setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b
setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b
setElems :: set -> [ElemOf set] setElems :: set -> [ElemOf set]
setFromList :: [ElemOf set] -> set setFromList :: [ElemOf set] -> set
...@@ -74,8 +75,9 @@ class IsMap map where ...@@ -74,8 +75,9 @@ class IsMap map where
mapMap :: (a -> b) -> map a -> map b mapMap :: (a -> b) -> map a -> map b
mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b
mapFold :: (a -> b -> b) -> b -> map a -> b mapFoldl :: (b -> a -> b) -> b -> map a -> b
mapFoldWithKey :: (KeyOf map -> a -> b -> b) -> b -> map a -> b mapFoldr :: (a -> b -> b) -> b -> map a -> b
mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFilter :: (a -> Bool) -> map a -> map a mapFilter :: (a -> Bool) -> map a -> map a
mapElems :: map a -> [a] mapElems :: map a -> [a]
...@@ -118,7 +120,8 @@ instance IsSet UniqueSet where ...@@ -118,7 +120,8 @@ instance IsSet UniqueSet where
setIntersection (US x) (US y) = US (S.intersection x y) setIntersection (US x) (US y) = US (S.intersection x y)
setIsSubsetOf (US x) (US y) = S.isSubsetOf x y setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
setFold k z (US s) = S.foldr k z s setFoldl k z (US s) = S.foldl' k z s
setFoldr k z (US s) = S.foldr k z s
setElems (US s) = S.elems s setElems (US s) = S.elems s
setFromList ks = US (S.fromList ks) setFromList ks = US (S.fromList ks)
...@@ -149,8 +152,9 @@ instance IsMap UniqueMap where ...@@ -149,8 +152,9 @@ instance IsMap UniqueMap where
mapMap f (UM m) = UM (M.map f m) mapMap f (UM m) = UM (M.map f m)
mapMapWithKey f (UM m) = UM (M.mapWithKey f m) mapMapWithKey f (UM m) = UM (M.mapWithKey f m)
mapFold k z (UM m) = M.foldr k z m mapFoldl k z (UM m) = M.foldl' k z m
mapFoldWithKey k z (UM m) = M.foldrWithKey k z m mapFoldr k z (UM m) = M.foldr k z m
mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m
mapFilter f (UM m) = UM (M.filter f m) mapFilter f (UM m) = UM (M.filter f m)
mapElems (UM m) = M.elems m mapElems (UM m) = M.elems m
......
...@@ -148,7 +148,7 @@ fixpointAnalysis direction lattice do_block entries blockmap = loop start ...@@ -148,7 +148,7 @@ fixpointAnalysis direction lattice do_block entries blockmap = loop start
-- information in fbase1 and (if something changed) we update it -- information in fbase1 and (if something changed) we update it
-- and add the affected blocks to the worklist. -- and add the affected blocks to the worklist.
(todo2, fbase2) = {-# SCC "mapFoldWithKey" #-} (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}
mapFoldWithKey mapFoldlWithKey
(updateFact join dep_blocks) (todo1, fbase1) out_facts (updateFact join dep_blocks) (todo1, fbase1) out_facts
in loop todo2 fbase2 in loop todo2 fbase2
loop _ !fbase1 = fbase1 loop _ !fbase1 = fbase1
...@@ -219,7 +219,7 @@ fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap ...@@ -219,7 +219,7 @@ fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap
do_block block fbase1 do_block block fbase1
let blocks2 = mapInsert (entryLabel new_block) new_block blocks1 let blocks2 = mapInsert (entryLabel new_block) new_block blocks1
(todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-} (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}
mapFoldWithKey mapFoldlWithKey
(updateFact join dep_blocks) (todo1, fbase1) out_facts (updateFact join dep_blocks) (todo1, fbase1) out_facts
loop todo2 blocks2 fbase2 loop todo2 blocks2 fbase2
loop _ !blocks1 !fbase1 = return (blocks1, fbase1) loop _ !blocks1 !fbase1 = return (blocks1, fbase1)
...@@ -333,11 +333,11 @@ mkDepBlocks Bwd blocks = go blocks 0 mapEmpty ...@@ -333,11 +333,11 @@ mkDepBlocks Bwd blocks = go blocks 0 mapEmpty
updateFact updateFact
:: JoinFun f :: JoinFun f
-> LabelMap IntSet -> LabelMap IntSet
-> (IntHeap, FactBase f)
-> Label -> Label
-> f -- out fact -> f -- out fact
-> (IntHeap, FactBase f) -> (IntHeap, FactBase f)
-> (IntHeap, FactBase f) updateFact fact_join dep_blocks (todo, fbase) lbl new_fact
updateFact fact_join dep_blocks lbl new_fact (todo, fbase)
= case lookupFact lbl fbase of = case lookupFact lbl fbase of
Nothing -> Nothing ->
-- Note [No old fact] -- Note [No old fact]
......
...@@ -109,9 +109,9 @@ labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x ...@@ -109,9 +109,9 @@ labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
-> LabelSet -> LabelSet
labelsDefined GNil = setEmpty labelsDefined GNil = setEmpty
labelsDefined (GUnit{}) = setEmpty labelsDefined (GUnit{}) = setEmpty
labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body
where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet
addEntry label _ labels = setInsert label labels addEntry labels label _ = setInsert label labels
exitLabel :: MaybeO x (block n C O) -> LabelSet exitLabel :: MaybeO x (block n C O) -> LabelSet
exitLabel NothingO = setEmpty exitLabel NothingO = setEmpty
exitLabel (JustO b) = setSingleton (entryLabel b) exitLabel (JustO b) = setSingleton (entryLabel b)
......
...@@ -61,7 +61,8 @@ instance IsSet LabelSet where ...@@ -61,7 +61,8 @@ instance IsSet LabelSet where
setIntersection (LS x) (LS y) = LS (setIntersection x y) setIntersection (LS x) (LS y) = LS (setIntersection x y)
setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
setFold k z (LS s) = setFold (k . mkHooplLabel) z s setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s
setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s
setElems (LS s) = map mkHooplLabel (setElems s) setElems (LS s) = map mkHooplLabel (setElems s)
setFromList ks = LS (setFromList (map lblToUnique ks)) setFromList ks = LS (setFromList (map lblToUnique ks))
...@@ -95,8 +96,10 @@ instance IsMap LabelMap where ...@@ -95,8 +96,10 @@ instance IsMap LabelMap where
mapMap f (LM m) = LM (mapMap f m) mapMap f (LM m) = LM (mapMap f m)
mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m) mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)
mapFold k z (LM m) = mapFold k z m mapFoldl k z (LM m) = mapFoldl k z m
mapFoldWithKey k z (LM m) = mapFoldWithKey (k . mkHooplLabel) z m mapFoldr k z (LM m) = mapFoldr k z m
mapFoldlWithKey k z (LM m) =
mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
mapFilter f (LM m) = LM (mapFilter f m) mapFilter f (LM m) = LM (mapFilter f m)
mapElems (LM m) = mapElems m mapElems (LM m) = mapElems m
......
...@@ -113,8 +113,8 @@ regSpill_top platform regSlotMap cmm ...@@ -113,8 +113,8 @@ regSpill_top platform regSlotMap cmm
-- after we've done a successful allocation. -- after we've done a successful allocation.
let liveSlotsOnEntry' :: BlockMap IntSet let liveSlotsOnEntry' :: BlockMap IntSet
liveSlotsOnEntry' liveSlotsOnEntry'
= mapFoldWithKey patchLiveSlot = mapFoldlWithKey patchLiveSlot
liveSlotsOnEntry liveVRegsOnEntry liveSlotsOnEntry liveVRegsOnEntry
let info' let info'
= LiveInfo static firstId = LiveInfo static firstId
...@@ -131,10 +131,9 @@ regSpill_top platform regSlotMap cmm ...@@ -131,10 +131,9 @@ regSpill_top platform regSlotMap cmm
-- then record the fact that these slots are now live in those blocks -- then record the fact that these slots are now live in those blocks
-- in the given slotmap. -- in the given slotmap.
patchLiveSlot patchLiveSlot
:: BlockId -> RegSet :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet
-> BlockMap IntSet -> BlockMap IntSet
patchLiveSlot blockId regsLive slotMap patchLiveSlot slotMap blockId regsLive
= let = let
-- Slots that are already recorded as being live. -- Slots that are already recorded as being live.
curSlotsLive = fromMaybe IntSet.empty curSlotsLive = fromMaybe IntSet.empty
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment