Commit 2a87a565 authored by Andreas Klebinger's avatar Andreas Klebinger Committed by Ömer Sinan Ağacan

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).
parent c846618a
......@@ -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
......
......@@ -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)
......@@ -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])
......
......@@ -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
......
......@@ -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.
......
......@@ -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
......
......@@ -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]
......
......@@ -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]
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment