A few optimizations in STG and Cmm parts:

(Guided by the profiler output)

- Add a few bang patterns, INLINABLE annotations, and a seqList in a few
  places in Cmm and STG parts.

- Do not add external variables as dependencies in STG dependency
  analysis (GHC.Stg.DepAnal).

4 files changed, 19 insertions, 11 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index c83dba8f39..8cac0aa5dd 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -7,6 +7,7 @@
 -----------------------------------------------------------------------------
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
 
 module GHC.Cmm.CLabel (
         CLabel, -- abstract type
@@ -468,7 +469,7 @@ mkRednCountsLabel       name    =
 mkLocalClosureLabel      :: Name -> CafInfo -> CLabel
 mkLocalInfoTableLabel    :: Name -> CafInfo -> CLabel
 mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel
-mkLocalClosureLabel     name c  = IdLabel name  c Closure
+mkLocalClosureLabel   !name !c  = IdLabel name  c Closure
 mkLocalInfoTableLabel   name c  = IdLabel name  c LocalInfoTable
 mkLocalClosureTableLabel name c = IdLabel name  c ClosureTable
 
diff --git a/compiler/GHC/Cmm/Dataflow/Collections.hs b/compiler/GHC/Cmm/Dataflow/Collections.hs
index f131f17cc1..bb762bf698 100644
--- a/compiler/GHC/Cmm/Dataflow/Collections.hs
+++ b/compiler/GHC/Cmm/Dataflow/Collections.hs
@@ -167,11 +167,14 @@ instance IsMap UniqueMap where
   mapFoldr k z (UM m) = M.foldr k z m
   mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m
   mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m
+  {-# INLINEABLE mapFilter #-}
   mapFilter f (UM m) = UM (M.filter f m)
+  {-# INLINEABLE mapFilterWithKey #-}
   mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)
 
   mapElems (UM m) = M.elems m
   mapKeys (UM m) = M.keys m
+  {-# INLINEABLE mapToList #-}
   mapToList (UM m) = M.toList m
   mapFromList assocs = UM (M.fromList assocs)
   mapFromListWith f assocs = UM (M.fromListWith f assocs)
diff --git a/compiler/GHC/Cmm/Dataflow/Label.hs b/compiler/GHC/Cmm/Dataflow/Label.hs
index c571cedb48..b27ff341e5 100644
--- a/compiler/GHC/Cmm/Dataflow/Label.hs
+++ b/compiler/GHC/Cmm/Dataflow/Label.hs
@@ -107,11 +107,14 @@ instance IsMap LabelMap where
   mapFoldlWithKey k z (LM m) =
       mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
   mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m
+  {-# INLINEABLE mapFilter #-}
   mapFilter f (LM m) = LM (mapFilter f m)
+  {-# INLINEABLE mapFilterWithKey #-}
   mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)
 
   mapElems (LM m) = mapElems m
   mapKeys (LM m) = map mkHooplLabel (mapKeys m)
+  {-# INLINEABLE mapToList #-}
   mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]
   mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
   mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs
index 8dbe13d937..d90c776c88 100644
--- a/compiler/GHC/Cmm/Info/Build.hs
+++ b/compiler/GHC/Cmm/Info/Build.hs
@@ -34,11 +34,10 @@ import GHC.StgToCmm.Heap
 import ErrUtils
 
 import Control.Monad
-import Data.Map (Map)
-import qualified Data.Map as Map
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Tuple
 import Control.Monad.Trans.State
 import Control.Monad.Trans.Class
 import Data.List (unzip4)
@@ -435,7 +434,7 @@ type CAFSet = Set CAFLabel
 type CAFEnv = LabelMap CAFSet
 
 mkCAFLabel :: CLabel -> CAFLabel
-mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)
+mkCAFLabel lbl = CAFLabel $! toClosureLbl lbl
 
 -- This is a label that we can put in an SRT.  It *must* be a closure label,
 -- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
@@ -605,7 +604,7 @@ emptySRT mod =
 -}
 
 data SomeLabel
-  = BlockLabel Label
+  = BlockLabel !Label
   | DeclLabel CLabel
   deriving (Eq, Ord)
 
@@ -630,13 +629,13 @@ getLabelledBlocks (CmmData _ (CmmStaticsRaw _ _)) =
 getLabelledBlocks (CmmData _ (CmmStatics lbl _ _ _)) =
   [ (DeclLabel lbl, mkCAFLabel lbl) ]
 getLabelledBlocks (CmmProc top_info _ _ _) =
-  [ (BlockLabel blockId, mkCAFLabel (cit_lbl info))
+  [ (BlockLabel blockId, caf_lbl)
   | (blockId, info) <- mapToList (info_tbls top_info)
   , let rep = cit_rep info
   , not (isStaticRep rep) || not (isThunkRep rep)
+  , let !caf_lbl = mkCAFLabel (cit_lbl info)
   ]
 
-
 -- | Put the labelled blocks that we will be annotating with SRTs into
 -- dependency order.  This is so that we can process them one at a
 -- time, resolving references to earlier blocks to point to their
@@ -651,8 +650,10 @@ depAnalSRTs cafEnv cafEnv_static decls =
                            text "nodes:" <+> ppr (map node_payload nodes) $$
                            text "graph:" <+> ppr graph) graph
  where
+  labelledBlocks :: [(SomeLabel, CAFLabel)]
   labelledBlocks = concatMap getLabelledBlocks decls
-  labelToBlock = Map.fromList (map swap labelledBlocks)
+  labelToBlock :: Map CAFLabel SomeLabel
+  labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks
 
   nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)]
   nodes = [ DigraphNode (l,lbl,cafs') l
@@ -696,7 +697,7 @@ getStaticFuns decls =
   , Just (id, _) <- [cit_clo info]
   , let rep = cit_rep info
   , isStaticRep rep && isFunRep rep
-  , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
+  , let !lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
   ]
 
 
@@ -769,7 +770,7 @@ doSRTs dflags moduleSRTInfo procs data_ = do
   -- them.
   let
     sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
-    sccs = depAnalSRTs cafEnv static_data_env decls
+    sccs = {-# SCC depAnalSRTs #-} depAnalSRTs cafEnv static_data_env decls
 
     cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]
     cafsWithSRTs = getCAFs cafEnv decls