Hoopl.Collections: change right folds to strict left folds
authorMichal Terepeta <michal.terepeta@gmail.com>
Thu, 1 Feb 2018 05:30:22 +0000 (00:30 -0500)
committerBen Gamari <ben@smart-cactus.org>
Fri, 2 Feb 2018 15:18:36 +0000 (10:18 -0500)
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 <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

compiler/cmm/CmmCommonBlockElim.hs
compiler/cmm/CmmContFlowOpt.hs
compiler/cmm/CmmProcPoint.hs
compiler/cmm/CmmUtils.hs
compiler/cmm/Hoopl/Collections.hs
compiler/cmm/Hoopl/Dataflow.hs
compiler/cmm/Hoopl/Graph.hs
compiler/cmm/Hoopl/Label.hs
compiler/nativeGen/RegAlloc/Graph/Spill.hs

index c822078..26004fb 100644 (file)
@@ -426,8 +426,8 @@ copyTicks env g
   | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
   where -- Reverse block merge map
         blockMap = toBlockMap g
-        revEnv = mapFoldWithKey insertRev M.empty env
-        insertRev k x = M.insertWith (const (k:)) x [k]
+        revEnv = mapFoldlWithKey insertRev M.empty env
+        insertRev m k x = M.insertWith (const (k:)) x [k] m
         -- Copy ticks and scopes into the given block
         copyTo block = case M.lookup (entryLabel block) revEnv of
           Nothing -> block
index 1efc3e6..8863012 100644 (file)
@@ -427,10 +427,10 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
              -- Remove any info_tbls for unreachable
 
      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 l i env | l `setMember` used_lbls = mapInsert l i env
+     keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
+     keep env l i | l `setMember` used_lbls = mapInsert l i env
                   | otherwise               = env
 
      used_blocks :: [CmmBlock]
index 153872f..3459284 100644 (file)
@@ -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
@@ -196,11 +196,11 @@ 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 =
@@ -243,10 +243,10 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
                            top_l _ g@(CmmGraph {g_entry=entry})) =
   do -- Build a map from procpoints to the blocks they reach
      let addBlock
-             :: CmmBlock
+             :: LabelMap (LabelMap CmmBlock)
+             -> CmmBlock
              -> LabelMap (LabelMap CmmBlock)
-             -> LabelMap (LabelMap CmmBlock)
-         addBlock b graphEnv =
+         addBlock 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 addBlock mapEmpty g
 
      -- Build a map from proc point BlockId to pairs of:
      --  * Labels for their new procedures
@@ -302,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
index d42ca92..8e8c1ed 100644 (file)
@@ -56,7 +56,7 @@ module CmmUtils(
         ofBlockMap, toBlockMap, insertBlock,
         ofBlockList, toBlockList, bodyToBlockList,
         toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
-        foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
+        foldlGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
 
         -- * Ticks
         blockTicks
@@ -552,8 +552,8 @@ mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGra
 mapGraphNodes1 f = modifyGraph (mapGraph f)
 
 
-foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a
-foldGraphBlocks k z g = mapFold k z $ toBlockMap g
+foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
+foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
 
 postorderDfs :: CmmGraph -> [CmmBlock]
 postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)
index 9bccc66..b8072b3 100644 (file)
@@ -34,7 +34,8 @@ class IsSet set where
   setIntersection :: set -> set -> set
   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]
   setFromList :: [ElemOf set] -> set
@@ -74,8 +75,9 @@ class IsMap map where
 
   mapMap :: (a -> b) -> map a -> map b
   mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b
-  mapFold :: (a -> b -> b) -> b -> map a -> b
-  mapFoldWithKey :: (KeyOf map -> a -> b -> b) -> b -> map a -> b
+  mapFoldl :: (b -> a -> 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
 
   mapElems :: map a -> [a]
@@ -118,7 +120,8 @@ instance IsSet UniqueSet where
   setIntersection (US x) (US y) = US (S.intersection 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
   setFromList ks = US (S.fromList ks)
@@ -149,8 +152,9 @@ instance IsMap UniqueMap where
 
   mapMap f (UM m) = UM (M.map f m)
   mapMapWithKey f (UM m) = UM (M.mapWithKey f m)
-  mapFold k z (UM m) = M.foldr k z m
-  mapFoldWithKey k z (UM m) = M.foldrWithKey k z m
+  mapFoldl k z (UM m) = M.foldl' 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)
 
   mapElems (UM m) = M.elems m
index 2310db2..0b0434b 100644 (file)
@@ -148,7 +148,7 @@ fixpointAnalysis direction lattice do_block entries blockmap = loop start
             -- 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
@@ -219,7 +219,7 @@ 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)
@@ -333,11 +333,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]
index 9a492d6..ca482ab 100644 (file)
@@ -109,9 +109,9 @@ labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
               -> LabelSet
 labelsDefined GNil      = setEmpty
 labelsDefined (GUnit{}) = setEmpty
-labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body
-  where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet
-        addEntry label _ labels = setInsert label labels
+labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body
+  where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet
+        addEntry labels label _ = setInsert label labels
         exitLabel :: MaybeO x (block n C O) -> LabelSet
         exitLabel NothingO  = setEmpty
         exitLabel (JustO b) = setSingleton (entryLabel b)
index ddf200a..8096fab 100644 (file)
@@ -61,7 +61,8 @@ instance IsSet LabelSet where
   setIntersection (LS x) (LS y) = LS (setIntersection 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)
   setFromList ks = LS (setFromList (map lblToUnique ks))
@@ -95,8 +96,10 @@ instance IsMap LabelMap where
 
   mapMap f (LM m) = LM (mapMap f m)
   mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)
-  mapFold k z (LM m) = mapFold k z m
-  mapFoldWithKey k z (LM m) = mapFoldWithKey (k . mkHooplLabel) z m
+  mapFoldl k z (LM m) = mapFoldl k 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)
 
   mapElems (LM m) = mapElems m
index 02da824..bce24bd 100644 (file)
@@ -113,8 +113,8 @@ regSpill_top platform regSlotMap cmm
                 -- after we've done a successful allocation.
                 let liveSlotsOnEntry' :: BlockMap IntSet
                     liveSlotsOnEntry'
-                        = mapFoldWithKey patchLiveSlot
-                                         liveSlotsOnEntry liveVRegsOnEntry
+                        = mapFoldlWithKey patchLiveSlot
+                                          liveSlotsOnEntry liveVRegsOnEntry
 
                 let info'
                         = LiveInfo static firstId
@@ -131,10 +131,9 @@ regSpill_top platform regSlotMap cmm
         -- then record the fact that these slots are now live in those blocks
         -- in the given slotmap.
         patchLiveSlot
-                :: BlockId -> RegSet
-                -> BlockMap IntSet -> BlockMap IntSet
+                :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet
 
-        patchLiveSlot blockId regsLive slotMap
+        patchLiveSlot slotMap blockId regsLive
          = let
                 -- Slots that are already recorded as being live.
                 curSlotsLive    = fromMaybe IntSet.empty