diff options
author | Andreas Klebinger <klebinger.andreas@gmx.at> | 2020-01-22 15:24:08 +0100 |
---|---|---|
committer | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2020-01-31 12:21:10 +0300 |
commit | 2a87a565365d1724a83cd0d5c5fc3b696210c4f2 (patch) | |
tree | 648ae769b299abab942ebaca5a8ba54da798284e | |
parent | c846618ae0f8601515683a4c7677c20c3272a50f (diff) | |
download | haskell-2a87a565365d1724a83cd0d5c5fc3b696210c4f2.tar.gz |
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).
-rw-r--r-- | compiler/GHC/Cmm/CLabel.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Dataflow/Collections.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Dataflow/Label.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Info/Build.hs | 21 | ||||
-rw-r--r-- | compiler/GHC/Stg/DepAnal.hs | 27 | ||||
-rw-r--r-- | compiler/GHC/Stg/Pipeline.hs | 2 | ||||
-rw-r--r-- | compiler/basicTypes/NameEnv.hs | 12 | ||||
-rw-r--r-- | compiler/main/DriverPipeline.hs | 3 | ||||
-rw-r--r-- | compiler/main/HscMain.hs | 21 |
9 files changed, 62 insertions, 33 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 diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs index 03c2150102..6aef33e410 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 0781b1a6d8..5db264254c 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 391b989915..baa396a1b4 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 |