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 <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

4 files changed, 23 insertions, 16 deletions

diff --git a/compiler/cmm/Hoopl/Collections.hs b/compiler/cmm/Hoopl/Collections.hs
index 9bccc665fa..b8072b37a7 100644
--- a/compiler/cmm/Hoopl/Collections.hs
+++ b/compiler/cmm/Hoopl/Collections.hs
@@ -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
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
index 2310db2619..0b0434bb36 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -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]
diff --git a/compiler/cmm/Hoopl/Graph.hs b/compiler/cmm/Hoopl/Graph.hs
index 9a492d6279..ca482ab4a8 100644
--- a/compiler/cmm/Hoopl/Graph.hs
+++ b/compiler/cmm/Hoopl/Graph.hs
@@ -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)
diff --git a/compiler/cmm/Hoopl/Label.hs b/compiler/cmm/Hoopl/Label.hs
index ddf200aa73..8096fab073 100644
--- a/compiler/cmm/Hoopl/Label.hs
+++ b/compiler/cmm/Hoopl/Label.hs
@@ -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