cmm/: Avoid using lazy left folds

This basically replaces all uses of `foldl` with `foldl'`. I've looked
at all the call sites and there doesn't seem to be any reason to prefer
the lazy version.

Signed-off-by: Michal Terepeta <michal.terepeta@gmail.com>

Test Plan: ./validate

Reviewers: bgamari, simonmar

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4463

6 files changed, 27 insertions, 21 deletions

diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index dc5cfd6ee0..ae192e504c 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -119,11 +119,13 @@ cafAnal cmmGraph = analyzeCmmBwd cafLattice cafTransfers cmmGraph mapEmpty
 
 -- Description of the SRT for a given module.
 -- Note that this SRT may grow as we greedily add new CAFs to it.
-data TopSRT = TopSRT { lbl      :: CLabel
-                     , next_elt :: Int -- the next entry in the table
-                     , rev_elts :: [CLabel]
-                     , elt_map  :: Map CLabel Int }
-                        -- map: CLabel -> its last entry in the table
+data TopSRT = TopSRT
+  { lbl      :: CLabel
+  , next_elt :: {-# UNPACK #-} !Int -- the next entry in the table
+  , rev_elts :: [CLabel]
+  , elt_map  :: !(Map CLabel Int) -- CLabel -> its last entry in the table
+  }
+
 instance Outputable TopSRT where
   ppr (TopSRT lbl next elts eltmap) =
     text "TopSRT:" <+> ppr lbl
@@ -176,7 +178,7 @@ buildSRT dflags topSRT cafs =
                  do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs
                     return (topSRT, localSRTs)
            in if cafs `lengthExceeds` maxBmpSize dflags then
-                mkSRT (foldl add_if_missing topSRT cafs)
+                mkSRT (foldl' add_if_missing topSRT cafs)
               else -- make sure all the cafs are near the bottom of the srt
                 mkSRT (add_if_too_far topSRT cafs)
          add_if_missing srt caf =
@@ -269,14 +271,14 @@ localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) =
 -- To do this replacement efficiently, we gather strongly connected
 -- components, then we sort the components in topological order.
 mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet
-mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
+mkTopCAFInfo localCAFs = foldl' addToTop Map.empty g
   where
-        addToTop env (AcyclicSCC (l, cafset)) =
+        addToTop !env (AcyclicSCC (l, cafset)) =
           Map.insert l (flatten env cafset) env
-        addToTop env (CyclicSCC nodes) =
+        addToTop !env (CyclicSCC nodes) =
           let (lbls, cafsets) = unzip nodes
-              cafset  = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls
-          in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
+              cafset = Set.unions cafsets `Set.difference` Set.fromList lbls
+          in foldl' (\env l -> Map.insert l (flatten env cafset) env) env lbls
 
         g = stronglyConnCompFromEdgedVerticesOrd
               [ DigraphNode (l,cafs) l (Set.elems cafs)
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index ba3b1c8a53..fce8f7dae8 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -29,6 +29,7 @@ import UniqDFM
 import qualified TrieMap as TM
 import Unique
 import Control.Arrow (first, second)
+import Data.List (foldl')
 
 -- -----------------------------------------------------------------------------
 -- Eliminate common blocks
@@ -173,7 +174,7 @@ hash_block block =
         hash_tgt (ForeignTarget e _) = hash_e e
         hash_tgt (PrimTarget _) = 31 -- lots of these
 
-        hash_list f = foldl (\z x -> f x + z) (0::Word32)
+        hash_list f = foldl' (\z x -> f x + z) (0::Word32)
 
         cvt = fromInteger . toInteger
 
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index 8863012f20..da365cfe7f 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -24,6 +24,7 @@ import Panic
 import Util
 
 import Control.Monad
+import Data.List
 
 
 -- Note [What is shortcutting]
@@ -177,7 +178,7 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
      -- a map of blocks. We process each element from blocks and update
      -- blockmap accordingly
      blocks = postorderDfs g
-     blockmap = foldr addBlock emptyBody blocks
+     blockmap = foldl' (flip addBlock) emptyBody blocks
 
      -- Accumulator contains three components:
      --  * map of blocks in a graph
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 2602dc8d14..3f1633404c 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -37,7 +37,7 @@ import qualified Data.Set as Set
 import Control.Monad.Fix
 import Data.Array as Array
 import Data.Bits
-import Data.List (nub)
+import Data.List (nub, foldl')
 
 {- Note [Stack Layout]
 
@@ -322,7 +322,7 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high
        --    Sp = Sp + sp_off -- Sp adjustment goes here
        --    last1            -- the last node
        --
-       let middle_pre = blockToList $ foldl blockSnoc middle0 middle1
+       let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1
 
        let final_blocks =
                manifestSp dflags final_stackmaps stack0 sp0 final_sp_high
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 3459284c0b..eeae96083a 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -330,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 insertBlock) blockEnv'' jumpBlocks
               let g' = ofBlockMap ppId blockEnv'''
               -- pprTrace "g' pre jumps" (ppr g') $ do
               return (mapInsert ppId g' newGraphEnv)
@@ -373,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)
+                    (postorderDfs 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)
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index 464a041c1e..487f0bc244 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -24,6 +24,7 @@ import PprCmm ()
 import qualified Data.IntSet as IntSet
 import Data.List (partition)
 import qualified Data.Set as Set
+import Data.List
 import Data.Maybe
 
 -- Compact sets for membership tests of local variables.
@@ -233,7 +234,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
 
             live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs
 
-      final_middle = foldl blockSnoc middle' dropped_last
+      final_middle = foldl' blockSnoc middle' dropped_last
 
       sunk' = mapUnion sunk $
                  mapFromList [ (l, filterAssignments dflags (getLive l) assigs'')
@@ -343,7 +344,7 @@ walk dflags nodes assigs = go nodes emptyBlock assigs
       (dropped, as') = dropAssignmentsSimple dflags
                           (\a -> conflicts dflags a node2) as1
 
-      block' = foldl blockSnoc block dropped `blockSnoc` node2
+      block' = foldl' blockSnoc block dropped `blockSnoc` node2
 
 
 --