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

9 files changed, 62 insertions, 33 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index c83dba8..8cac0aa 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 f131f17..bb762bf 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 c571ced..b27ff34 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 8dbe13d..d90c776 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 a042902..5729128 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 87690b9..de426ad 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
diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs
index 03c2150..6aef33e 100644
--- a/compiler/basicTypes/NameEnv.hs
+++ b/compiler/basicTypes/NameEnv.hs
@@ -6,6 +6,9 @@
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module NameEnv (
         -- * Var, Id and TyVar environments (maps)
         NameEnv,
@@ -60,7 +63,8 @@ deterministic even when the edges are not in deterministic order as explained
 in Note [Deterministic SCC] in Digraph.
 -}
 
-depAnal :: (node -> [Name])      -- Defs
+depAnal :: forall node.
+           (node -> [Name])      -- Defs
         -> (node -> [Name])      -- Uses
         -> [node]
         -> [SCC node]
@@ -69,11 +73,13 @@ depAnal :: (node -> [Name])      -- Defs
 --
 -- The get_defs and get_uses functions are called only once per node
 depAnal get_defs get_uses nodes
-  = stronglyConnCompFromEdgedVerticesUniq (map mk_node keyed_nodes)
+  = stronglyConnCompFromEdgedVerticesUniq graph_nodes
   where
+    graph_nodes = (map mk_node keyed_nodes) :: [Node Int node]
     keyed_nodes = nodes `zip` [(1::Int)..]
     mk_node (node, key) =
-      DigraphNode node key (mapMaybe (lookupNameEnv key_map) (get_uses node))
+      let !edges = (mapMaybe (lookupNameEnv key_map) (get_uses node))
+      in DigraphNode node key edges
 
     key_map :: NameEnv Int   -- Maps a Name to the key of the decl that defines it
     key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node]
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 0781b1a..5db2642 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1193,7 +1193,8 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do
                       hscGenHardCode hsc_env' cgguts mod_location output_fn
 
                     final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just caf_infos))
-                    let final_mod_details = updateModDetailsCafInfos caf_infos mod_details
+                    let final_mod_details = {-# SCC updateModDetailsCafInfos #-}
+                                            updateModDetailsCafInfos caf_infos mod_details
                     setIface final_iface final_mod_details
 
                     -- See Note [Writing interface files]
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 391b989..baa396a 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1542,6 +1542,24 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
 
 -------------------- Stuff for new code gen ---------------------
 
+{-
+Note [Forcing of stg_binds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The two last steps in the STG pipeline are:
+
+* Sorting the bindings in dependency order.
+* Annotating them with free variables.
+
+We want to make sure we do not keep references to unannotated STG bindings
+alive, nor references to bindings which have already been compiled to Cmm.
+
+We explicitly force the bindings to avoid this.
+
+This reduces residency towards the end of the CodeGen phase significantly
+(5-10%).
+-}
+
 doCodeGen   :: HscEnv -> Module -> [TyCon]
             -> CollectedCCs
             -> [StgTopBinding]
@@ -1557,7 +1575,8 @@ doCodeGen hsc_env this_mod data_tycons
     let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
 
     let cmm_stream :: Stream IO CmmGroup ()
-        cmm_stream = {-# SCC "StgToCmm" #-}
+        -- See Note [Forcing of stg_binds]
+        cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
             lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons
                            cost_centre_info stg_binds_w_fvs hpc_info