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

6 files changed, 31 insertions, 28 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
diff --git a/compiler/GHC/Stg/DepAnal.hs b/compiler/GHC/Stg/DepAnal.hs
index a042902180..5729128126 100644
--- a/compiler/GHC/Stg/DepAnal.hs
+++ b/compiler/GHC/Stg/DepAnal.hs
@@ -6,11 +6,12 @@ import GhcPrelude
 
 import GHC.Stg.Syntax
 import Id
-import Name (Name)
+import Name (Name, nameIsLocalOrFrom)
 import NameEnv
 import Outputable
 import UniqSet (nonDetEltsUniqSet)
 import VarSet
+import Module (Module)
 
 import Data.Graph (SCC (..))
 
@@ -31,13 +32,13 @@ type FVs = VarSet
 -- of all bindings in the group.
 --
 -- Implementation: pass bound variables (BVs) to recursive calls, get free
--- variables (FVs) back.
+-- variables (FVs) back. We ignore imported FVs as they do not change the
+-- ordering but it improves performance.
 --
-annTopBindingsDeps :: [StgTopBinding] -> [(StgTopBinding, FVs)]
-annTopBindingsDeps bs = zip bs (map top_bind bs)
+annTopBindingsDeps :: Module -> [StgTopBinding] -> [(StgTopBinding, FVs)]
+annTopBindingsDeps this_mod bs = zip bs (map top_bind bs)
   where
     top_bind :: StgTopBinding -> FVs
-
     top_bind StgTopStringLit{} =
       emptyVarSet
 
@@ -45,10 +46,8 @@ annTopBindingsDeps bs = zip bs (map top_bind bs)
       binding emptyVarSet bs
 
     binding :: BVs -> StgBinding -> FVs
-
     binding bounds (StgNonRec _ r) =
       rhs bounds r
-
     binding bounds (StgRec bndrs) =
       unionVarSets $
         map (bind_non_rec (extendVarSetList bounds (map fst bndrs))) bndrs
@@ -58,7 +57,6 @@ annTopBindingsDeps bs = zip bs (map top_bind bs)
         rhs bounds r
 
     rhs :: BVs -> StgRhs -> FVs
-
     rhs bounds (StgRhsClosure _ _ _ as e) =
       expr (extendVarSetList bounds as) e
 
@@ -68,6 +66,7 @@ annTopBindingsDeps bs = zip bs (map top_bind bs)
     var :: BVs -> Var -> FVs
     var bounds v
       | not (elemVarSet v bounds)
+      , nameIsLocalOrFrom this_mod (idName v)
       = unitVarSet v
       | otherwise
       = emptyVarSet
@@ -80,7 +79,6 @@ annTopBindingsDeps bs = zip bs (map top_bind bs)
     args bounds as = unionVarSets (map (arg bounds) as)
 
     expr :: BVs -> StgExpr -> FVs
-
     expr bounds (StgApp f as) =
       var bounds f `unionVarSet` args bounds as
 
@@ -89,21 +87,16 @@ annTopBindingsDeps bs = zip bs (map top_bind bs)
 
     expr bounds (StgConApp _ as _) =
       args bounds as
-
     expr bounds (StgOpApp _ as _) =
       args bounds as
-
     expr _ lam@StgLam{} =
       pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ ppr lam)
-
     expr bounds (StgCase scrut scrut_bndr _ as) =
       expr bounds scrut `unionVarSet`
         alts (extendVarSet bounds scrut_bndr) as
-
     expr bounds (StgLet _ bs e) =
       binding bounds bs `unionVarSet`
         expr (extendVarSetList bounds (bindersOf bs)) e
-
     expr bounds (StgLetNoEscape _ bs e) =
       binding bounds bs `unionVarSet`
         expr (extendVarSetList bounds (bindersOf bs)) e
@@ -122,8 +115,10 @@ annTopBindingsDeps bs = zip bs (map top_bind bs)
 -- * Dependency sorting
 
 -- | Dependency sort a STG program so that dependencies come before uses.
-depSortStgPgm :: [StgTopBinding] -> [StgTopBinding]
-depSortStgPgm = map fst . depSort . annTopBindingsDeps
+depSortStgPgm :: Module -> [StgTopBinding] -> [StgTopBinding]
+depSortStgPgm this_mod =
+    {-# SCC "STG.depSort" #-}
+    map fst . depSort . annTopBindingsDeps this_mod
 
 -- | Sort free-variable-annotated STG bindings so that dependencies come before
 -- uses.
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
index 87690b90eb..de426adad7 100644
--- a/compiler/GHC/Stg/Pipeline.hs
+++ b/compiler/GHC/Stg/Pipeline.hs
@@ -65,7 +65,7 @@ stg2stg dflags this_mod binds
           -- dependency order. We also don't guarantee that StgLiftLams will
           -- preserve the order or only create minimal recursive groups, so a
           -- sorting pass is necessary.
-        ; let binds_sorted = depSortStgPgm binds'
+        ; let binds_sorted = depSortStgPgm this_mod binds'
         ; dump_when Opt_D_dump_stg_final "Final STG:" binds_sorted
 
         ; return binds_sorted