diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Cmm/CLabel.hs | 70 | ||||
| -rw-r--r-- | compiler/GHC/CoreToStg.hs | 16 | ||||
| -rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 74 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Flags.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Stg/CSE.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Debug.hs | 122 | ||||
| -rw-r--r-- | compiler/GHC/Stg/DepAnal.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Stg/FVs.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Lift.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Lift/Analysis.hs | 11 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Lift/Monad.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Lint.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Stats.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Syntax.hs | 34 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Unarise.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm.hs | 27 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Bind.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Closure.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/DataCon.hs | 34 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Expr.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Monad.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Utils.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/Types/IPE.hs | 18 |
24 files changed, 323 insertions, 181 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index 1afb97dcd8..e2f7ce82bc 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -18,6 +18,8 @@ module GHC.Cmm.CLabel ( NeedExternDecl (..), ForeignLabelSource(..), DynamicLinkerLabelInfo(..), + ConInfoTableLocation(..), + getConInfoTableLocation, -- * Constructors mkClosureLabel, @@ -107,6 +109,7 @@ module GHC.Cmm.CLabel ( isIdLabel, isTickyLabel, hasHaskellName, + hasIdLabelInfo, isBytesLabel, isForeignLabel, isSomeRODataLabel, @@ -450,8 +453,18 @@ data IdLabelInfo | RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id - | ConEntry -- ^ Constructor entry point - | ConInfoTable -- ^ Corresponding info table + | ConEntry ConInfoTableLocation + -- ^ Constructor entry point, when `-fdistinct-info-tables` is enabled then + -- each usage of a constructor will be given a unique number and a fresh info + -- table will be created in the module where the constructor is used. The + -- argument is used to keep track of which info table a usage of a constructor + -- should use. When the argument is 'Nothing' then it uses the info table which + -- is defined in the module where the datatype is declared, this is the usual case. + -- When it is (Just (m, k)) it will use the kth info table defined in module m. The + -- point of this inefficiency is so that you can work out where allocations of data + -- constructors are coming from when you are debugging. + + | ConInfoTable ConInfoTableLocation -- ^ Corresponding info table | ClosureTable -- ^ Table of closures for Enum tycons @@ -463,6 +476,19 @@ data IdLabelInfo deriving (Eq, Ord) +-- | Which module is the info table from, and which number was it. +data ConInfoTableLocation = UsageSite Module Int + | DefinitionSite + deriving (Eq, Ord) + +instance Outputable ConInfoTableLocation where + ppr (UsageSite m n) = text "Loc(" <> ppr n <> text "):" <+> ppr m + ppr DefinitionSite = empty + +getConInfoTableLocation :: IdLabelInfo -> Maybe ConInfoTableLocation +getConInfoTableLocation (ConInfoTable ci) = Just ci +getConInfoTableLocation _ = Nothing + instance Outputable IdLabelInfo where ppr Closure = text "Closure" ppr InfoTable = text "InfoTable" @@ -473,10 +499,8 @@ instance Outputable IdLabelInfo where ppr LocalEntry = text "LocalEntry" ppr RednCounts = text "RednCounts" - ppr ConEntry = text "ConEntry" - ppr ConInfoTable = text "ConInfoTable" --- ppr (ConEntry mn) = text "ConEntry" <+> ppr mn --- ppr (ConInfoTable mn) = text "ConInfoTable" <+> ppr mn + ppr (ConEntry mn) = text "ConEntry" <+> ppr mn + ppr (ConInfoTable mn) = text "ConInfoTable" <+> ppr mn ppr ClosureTable = text "ClosureTable" ppr Bytes = text "Bytes" ppr BlockInfoTable = text "BlockInfoTable" @@ -544,13 +568,15 @@ mkClosureLabel :: Name -> CafInfo -> CLabel mkInfoTableLabel :: Name -> CafInfo -> CLabel mkEntryLabel :: Name -> CafInfo -> CLabel mkClosureTableLabel :: Name -> CafInfo -> CLabel -mkConInfoTableLabel :: Name -> CafInfo -> CLabel +mkConInfoTableLabel :: Name -> ConInfoTableLocation -> CLabel mkBytesLabel :: Name -> CLabel mkClosureLabel name c = IdLabel name c Closure mkInfoTableLabel name c = IdLabel name c InfoTable mkEntryLabel name c = IdLabel name c Entry mkClosureTableLabel name c = IdLabel name c ClosureTable -mkConInfoTableLabel name c = IdLabel name c ConInfoTable +-- Special case for the normal 'DefinitionSite' case so that the 'ConInfoTable' application can be floated to a CAF. +mkConInfoTableLabel name DefinitionSite = IdLabel name NoCafRefs (ConInfoTable DefinitionSite) +mkConInfoTableLabel name k = IdLabel name NoCafRefs (ConInfoTable k) mkBytesLabel name = IdLabel name NoCafRefs Bytes mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel @@ -706,7 +732,7 @@ isStaticClosureLabel _lbl = False isSomeRODataLabel :: CLabel -> Bool -- info table defined in haskell (.hs) isSomeRODataLabel (IdLabel _ _ ClosureTable) = True -isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True +isSomeRODataLabel (IdLabel _ _ ConInfoTable {}) = True isSomeRODataLabel (IdLabel _ _ InfoTable) = True isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True @@ -718,13 +744,13 @@ isSomeRODataLabel _lbl = False isInfoTableLabel :: CLabel -> Bool isInfoTableLabel (IdLabel _ _ InfoTable) = True isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True -isInfoTableLabel (IdLabel _ _ ConInfoTable) = True +isInfoTableLabel (IdLabel _ _ ConInfoTable {}) = True isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True isInfoTableLabel _ = False -- | Whether label is points to constructor info table isConInfoTableLabel :: CLabel -> Bool -isConInfoTableLabel (IdLabel _ _ ConInfoTable) = True +isConInfoTableLabel (IdLabel _ _ ConInfoTable {}) = True isConInfoTableLabel _ = False -- | Get the label size field from a ForeignLabel @@ -827,7 +853,8 @@ toSlowEntryLbl platform lbl = case lbl of toEntryLbl :: Platform -> CLabel -> CLabel toEntryLbl platform lbl = case lbl of IdLabel n c LocalInfoTable -> IdLabel n c LocalEntry - IdLabel n c ConInfoTable -> IdLabel n c ConEntry + IdLabel n c (ConInfoTable k) -> IdLabel n c (ConEntry k) + IdLabel n _ BlockInfoTable -> mkLocalBlockLabel (nameUnique n) -- See Note [Proc-point local block entry-point]. IdLabel n c _ -> IdLabel n c Entry @@ -838,7 +865,8 @@ toEntryLbl platform lbl = case lbl of toInfoLbl :: Platform -> CLabel -> CLabel toInfoLbl platform lbl = case lbl of IdLabel n c LocalEntry -> IdLabel n c LocalInfoTable - IdLabel n c ConEntry -> IdLabel n c ConInfoTable + IdLabel n c (ConEntry k) -> IdLabel n c (ConInfoTable k) + IdLabel n c _ -> IdLabel n c InfoTable CmmLabel m ext str CmmEntry -> CmmLabel m ext str CmmInfo CmmLabel m ext str CmmRet -> CmmLabel m ext str CmmRetInfo @@ -848,6 +876,10 @@ hasHaskellName :: CLabel -> Maybe Name hasHaskellName (IdLabel n _ _) = Just n hasHaskellName _ = Nothing +hasIdLabelInfo :: CLabel -> Maybe IdLabelInfo +hasIdLabelInfo (IdLabel _ _ l) = Just l +hasIdLabelInfo _ = Nothing + -- ----------------------------------------------------------------------------- -- Does a CLabel's referent itself refer to a CAF? hasCAF :: CLabel -> Bool @@ -1459,8 +1491,16 @@ ppIdFlavor x = pp_cSEP <> case x of LocalEntry -> text "entry" Slow -> text "slow" RednCounts -> text "ct" - ConEntry -> text "con_entry" - ConInfoTable -> text "con_info" + ConEntry loc -> + case loc of + DefinitionSite -> text "con_entry" + UsageSite m n -> + ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_entry" + ConInfoTable k -> + case k of + DefinitionSite -> text "con_info" + UsageSite m n -> + ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_info" ClosureTable -> text "closure_tbl" Bytes -> text "bytes" BlockInfoTable -> text "info" diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 2f9e3816ef..1bcf5bdfe9 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -545,7 +545,7 @@ coreToStgApp f args ticks = do res_ty = exprType (mkApps (Var f) args) app = case idDetails f of DataConWorkId dc - | saturated -> StgConApp dc args' + | saturated -> StgConApp dc NoNumber args' (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) -- Some primitive operator that might be implemented as a library call. @@ -602,7 +602,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument (aticks, arg'') = stripStgTicksTop tickishFloatable arg' stg_arg = case arg'' of StgApp v [] -> StgVarArg v - StgConApp con [] _ -> StgVarArg (dataConWorkId con) + StgConApp con _ [] _ -> StgVarArg (dataConWorkId con) StgLit lit -> StgLitArg lit _ -> pprPanic "coreToStgArgs" (ppr arg) @@ -719,13 +719,13 @@ mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs) -- After this point we know that `bndrs` is empty, -- so this is not a function binding - | StgConApp con args _ <- unticked_rhs + | StgConApp con mn args _ <- unticked_rhs , -- Dynamic StgConApps are updatable not (isDllConApp dflags this_mod con args) = -- CorePrep does this right, but just to make sure ASSERT2( not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) , ppr bndr $$ ppr con $$ ppr args) - ( StgRhsCon dontCareCCS con args, ccs ) + ( StgRhsCon dontCareCCS con mn ticks args, ccs ) -- Otherwise it's a CAF, see Note [Cost-centre initialization plan]. | gopt Opt_AutoSccsOnIndividualCafs dflags @@ -741,7 +741,7 @@ mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs) , ccs ) where - unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs + (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry | otherwise = Updatable @@ -777,15 +777,15 @@ mkStgRhs bndr (PreStgRhs bndrs rhs) ReEntrant -- ignored for LNE [] rhs - | StgConApp con args _ <- unticked_rhs - = StgRhsCon currentCCS con args + | StgConApp con mn args _ <- unticked_rhs + = StgRhsCon currentCCS con mn ticks args | otherwise = StgRhsClosure noExtFieldSilent currentCCS upd_flag [] rhs where - unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs + (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry | otherwise = Updatable diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index f6b9e9738c..5e0c5f0c05 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -353,77 +353,3 @@ ipInitCode dflags this_mod ents <> semi -{- -Note [Mapping Info Tables to Source Positions] - -This note describes what the `-finfo-table-map` flag achieves. - -When debugging memory issues it is very useful to be able to map a specific closure -to a position in the source. The prime example is being able to map a THUNK to -a specific place in the source program, the mapping is usually quite precise because -a fresh info table is created for each distinct THUNK. - -There are three parts to the implementation - -1. In CoreToStg, the SourceNote information is used in order to give a source location to -some specific closures. -2. In StgToCmm, the actually used info tables are recorded. -3. During code generation, a mapping from the info table to the statically -determined location is emitted which can then be queried at runtime by -various tools. - --- Giving Source Locations to Closures - -At the moment thunk and constructor closures are added to the map. This information -is collected in the `InfoTableProvMap` which provides a mapping from: - -1. Data constructors to a list of where they are used. -2. `Name`s and where they originate from. - -During the CoreToStg phase, this map is populated whenever something is turned into -a StgRhsClosure or an StgConApp. The current source position is recorded -depending on the location indicated by the surrounding SourceNote. - -The functions which add information to the map are `recordStgIdPosition` and -`incDc`. - -When the -fdistinct-constructor-tables` flag is turned on then every -usage of a data constructor gets its own distinct info table. This is orchestrated -in `coreToStgExpr` where an incrementing number is used to distinguish each -occurrence of a data constructor. - --- StgToCmm - -The info tables which are actually used in the generated program are recorded during the -conversion from STG to Cmm. The used info tables are recorded in the `emitProc` function. -All the used info tables are recorded in the `cgs_used_info` field. This step -is necessary because when the information about names is collected in the previous -phase it's unpredictable about which names will end up needing info tables. If -you don't record which ones are actually used then you end up generating code -which references info tables which don't exist. - --- Code Generation - -The output of these two phases is combined together during code generation. -A C stub is generated which -creates the static map from info table pointer to the information about where that -info table was created from. This is created by `ipInitCode` in the same manner as a -C stub is generated for cost centres. - -This information can be consumed in two ways. - -1. The complete mapping is emitted into the eventlog so that external tools such -as eventlog2html can use the information with the heap profile by info table mode. -2. The `lookupIPE` function can be used via the `whereFrom#` primop to introspect -information about a closure in a running Haskell program. - -Note [Distinct Info Tables for Constructors] - -In the old times, each usage of a data constructor used the same info table. -This made it impossible to distinguish which actual usuage of a data constructor was -contributing primarily to the allocation in a program. Using the `-fdistinct-info-tables` flag you -can cause code generation to generate a distinct info table for each usage of -a constructor. Then, when inspecting the heap you can see precisely which usage of a constructor -was responsible for each allocation. - --} diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 955b6fabd1..f15d0d4ba1 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -132,6 +132,7 @@ data GeneralFlag | Opt_FastLlvm -- hidden flag | Opt_NoTypeableBinds + | Opt_DistinctConstructorTables | Opt_InfoTableMap | Opt_WarnIsError -- -Werror; makes warnings fatal diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 98c46427e6..8237525fb7 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -2775,7 +2775,8 @@ dynamic_flags_deps = [ -- Caller-CC , make_ord_flag defGhcFlag "fprof-callers" (HasArg setCallerCcFilters) - + , make_ord_flag defGhcFlag "fdistinct-constructor-tables" + (NoArg (setGeneralFlag Opt_DistinctConstructorTables)) , make_ord_flag defGhcFlag "finfo-table-map" (NoArg (setGeneralFlag Opt_InfoTableMap)) ------ Compiler flags ----------------------------------------------- diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs index b9e6782f77..bc266d20ba 100644 --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -292,8 +292,8 @@ stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body) = let body' = stgCseExpr (initEnv in_scope) body in StgRhsClosure ext ccs upd args body' -stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args) - = StgRhsCon ccs dataCon args +stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args) + = StgRhsCon ccs dataCon mu ticks args ------------------------------ -- The actual AST traversal -- @@ -326,11 +326,11 @@ stgCseExpr env (StgCase scrut bndr ty alts) -- A constructor application. -- To be removed by a variable use when found in the CSE environment -stgCseExpr env (StgConApp dataCon args tys) +stgCseExpr env (StgConApp dataCon n args tys) | Just bndr' <- envLookup dataCon args' env = StgApp bndr' [] | otherwise - = StgConApp dataCon args' tys + = StgConApp dataCon n args' tys where args' = substArgs env args -- Let bindings @@ -395,7 +395,7 @@ stgCsePairs env0 ((b,e):pairs) -- The RHS of a binding. -- If it is a constructor application, either short-cut it or extend the environment stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv) -stgCseRhs env bndr (StgRhsCon ccs dataCon args) +stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args) | Just other_bndr <- envLookup dataCon args' env , not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers] = let env' = addSubst bndr other_bndr env @@ -403,7 +403,7 @@ stgCseRhs env bndr (StgRhsCon ccs dataCon args) | otherwise = let env' = addDataCon bndr dataCon args' env -- see note [Case 1: CSEing allocated closures] - pair = (bndr, StgRhsCon ccs dataCon args') + pair = (bndr, StgRhsCon ccs dataCon mu ticks args') in (Just pair, env') where args' = substArgs env args diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs index e6e85f7db7..823334e2aa 100644 --- a/compiler/GHC/Stg/Debug.hs +++ b/compiler/GHC/Stg/Debug.hs @@ -16,7 +16,6 @@ import GHC.Unit.Module import GHC.Types.Name ( getName, getOccName, occNameString, nameSrcSpan) import GHC.Data.FastString import GHC.Driver.Session -import GHC.Driver.Ppr import Control.Monad (when) import Control.Monad.Trans.Reader @@ -25,6 +24,8 @@ import Control.Monad.Trans.Class import GHC.Types.Unique.Map import GHC.Types.SrcLoc import Control.Applicative +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) data SpanWithLabel = SpanWithLabel RealSrcSpan String @@ -64,9 +65,9 @@ collectStgRhs bndr (StgRhsClosure ext cc us bs e)= do e' <- collectExpr e recordInfo bndr e' return $ StgRhsClosure ext cc us bs e' -collectStgRhs _bndr (StgRhsCon cc dc args) = do - --n' <- incDc dc ticks - return (StgRhsCon cc dc args) +collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args) = do + n' <- numberDataCon dc ticks + return (StgRhsCon cc dc n' ticks args) recordInfo :: Id -> StgExpr -> M () @@ -86,9 +87,9 @@ collectExpr = go where go (StgApp occ as) = return $ StgApp occ as go (StgLit lit) = return $ StgLit lit - go (StgConApp dc as tys) = do --- n' <- incDc dc [] - return (StgConApp dc as tys) + go (StgConApp dc _mn as tys) = do + n' <- numberDataCon dc [] + return (StgConApp dc n' as tys) go (StgOpApp op as ty) = return (StgOpApp op as ty) go (StgCase scrut bndr ty alts) = StgCase <$> collectExpr scrut <*> pure bndr <*> pure ty <*> mapM collectAlt alts @@ -129,7 +130,6 @@ recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M () recordStgIdPosition id best_span ss = do dflags <- asks rDynFlags when (gopt Opt_InfoTableMap dflags) $ do - let tyString = showPpr dflags (idType id) cc <- asks rSpan --Useful for debugging why a certain Id gets given a certain span --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss) @@ -138,3 +138,109 @@ recordStgIdPosition id best_span ss = do Just (SpanWithLabel rss d) -> lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, rss, d)}) +numberDataCon :: DataCon -> [Tickish Id] -> M ConstructorNumber +-- Unboxed tuples and sums do not allocate so they +-- have no info tables. +numberDataCon dc _ | isUnboxedTupleDataCon dc = return NoNumber +numberDataCon dc _ | isUnboxedSumDataCon dc = return NoNumber +numberDataCon dc ts = do + dflags <- asks rDynFlags + if not (gopt Opt_DistinctConstructorTables dflags) then return NoNumber else do + env <- lift get + mcc <- asks rSpan + let mbest_span = selectTick ts <|> mcc + case mbest_span of + Nothing -> return NoNumber + Just (SpanWithLabel rss l) -> do + let best_span = (rss, l) + let dcMap' = alterUniqMap (maybe (Just ((0, best_span) :| [] )) + (\xs@((k, _):|_) -> Just ((k + 1, best_span) `NE.cons` xs))) (provDC env) dc + lift $ put (env { provDC = dcMap' }) + let r = lookupUniqMap dcMap' dc + return $ case r of + Nothing -> NoNumber + Just res -> Numbered (fst (NE.head res)) + +selectTick :: [Tickish Id] -> Maybe SpanWithLabel +selectTick [] = Nothing +selectTick (SourceNote rss d : ts ) = selectTick ts <|> Just (SpanWithLabel rss d) +selectTick (_:ts) = selectTick ts + +{- +Note [Mapping Info Tables to Source Positions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This note describes what the `-finfo-table-map` flag achieves. + +When debugging memory issues it is very useful to be able to map a specific closure +to a position in the source. The prime example is being able to map a THUNK to +a specific place in the source program, the mapping is usually quite precise because +a fresh info table is created for each distinct THUNK. + +There are three parts to the implementation + +1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location to +some specific closures. +2. In StgToCmm, the actually used info tables are recorded in an IORef, this +is important as it's hard to predict beforehand what code generation will do +and which ids will end up in the generated program. +3. During code generation, a mapping from the info table to the statically +determined location is emitted which can then be queried at runtime by +various tools. + +-- Giving Source Locations to Closures + +At the moment thunk and constructor closures are added to the map. This information +is collected in the `InfoTableProvMap` which provides a mapping from: + +1. Data constructors to a list of where they are used. +2. `Name`s and where they originate from. + +During the CoreToStg phase, this map is populated whenever something is turned into +a StgRhsClosure or an StgConApp. The current source position is recorded +depending on the location indicated by the surrounding SourceNote. + +The functions which add information to the map are `recordStgIdPosition` and +`numberDataCon`. + +When the -fdistinct-constructor-tables` flag is turned on then every +usage of a data constructor gets its own distinct info table. This is orchestrated +in `collectExpr` where an incrementing number is used to distinguish each +occurrence of a data constructor. + +-- StgToCmm + +The info tables which are actually used in the generated program are recorded during the +conversion from STG to Cmm. The used info tables are recorded in the `emitProc` function. +All the used info tables are recorded in the `cgs_used_info` field. This step +is necessary because when the information about names is collected in the previous +phase it's unpredictable about which names will end up needing info tables. If +you don't record which ones are actually used then you end up generating code +which references info tables which don't exist. + +-- Code Generation + +The output of these two phases is combined together during code generation. +A C stub is generated which +creates the static map from info table pointer to the information about where that +info table was created from. This is created by `ipInitCode` in the same manner as a +C stub is generated for cost centres. + +This information can be consumed in two ways. + +1. The complete mapping is emitted into the eventlog so that external tools such +as eventlog2html can use the information with the heap profile by info table mode. +2. The `lookupIPE` function can be used via the `whereFrom#` primop to introspect +information about a closure in a running Haskell program. + +Note [Distinct Info Tables for Constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the old times, each usage of a data constructor used the same info table. +This made it impossible to distinguish which actual usuage of a data constructor was +contributing primarily to the allocation in a program. Using the `-fdistinct-info-tables` flag you +can cause code generation to generate a distinct info table for each usage of +a constructor. Then, when inspecting the heap you can see precisely which usage of a constructor +was responsible for each allocation. + +-} diff --git a/compiler/GHC/Stg/DepAnal.hs b/compiler/GHC/Stg/DepAnal.hs index 9bf4249f6f..0e53ffcca1 100644 --- a/compiler/GHC/Stg/DepAnal.hs +++ b/compiler/GHC/Stg/DepAnal.hs @@ -62,7 +62,7 @@ annTopBindingsDeps this_mod bs = zip bs (map top_bind bs) rhs bounds (StgRhsClosure _ _ _ as e) = expr (extendVarSetList bounds as) e - rhs bounds (StgRhsCon _ _ as) = + rhs bounds (StgRhsCon _ _ _ _ as) = args bounds as var :: BVs -> Var -> FVs @@ -87,7 +87,7 @@ annTopBindingsDeps this_mod bs = zip bs (map top_bind bs) expr _ StgLit{} = emptyVarSet - expr bounds (StgConApp _ as _) = + expr bounds (StgConApp _ _ as _) = args bounds as expr bounds (StgOpApp _ as _) = args bounds as diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs index bd699a1fe1..ce40307420 100644 --- a/compiler/GHC/Stg/FVs.hs +++ b/compiler/GHC/Stg/FVs.hs @@ -124,7 +124,7 @@ expr env = go go (StgApp occ as) = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ])) go (StgLit lit) = (StgLit lit, emptyDVarSet) - go (StgConApp dc as tys) = (StgConApp dc as tys, args env as) + go (StgConApp dc n as tys) = (StgConApp dc n as tys, args env as) go (StgOpApp op as ty) = (StgOpApp op as ty, args env as) go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs) where @@ -156,7 +156,7 @@ rhs env (StgRhsClosure _ ccs uf bndrs body) -- See Note [Tracking local binders] (body', body_fvs) = expr (addLocals bndrs env) body fvs = delDVarSetList body_fvs bndrs -rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as) +rhs env (StgRhsCon ccs dc mu ts as) = (StgRhsCon ccs dc mu ts as, args env as) alt :: Env -> StgAlt -> (CgStgAlt, DIdSet) alt env (con, bndrs, e) = ((con, bndrs, e'), fvs) diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs index 8f2337120e..4e7b66f23d 100644 --- a/compiler/GHC/Stg/Lift.hs +++ b/compiler/GHC/Stg/Lift.hs @@ -199,9 +199,9 @@ liftRhs -- as lambda binders, discarding all free vars. -> LlStgRhs -> LiftM OutStgRhs -liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args) +liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args) = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs) - StgRhsCon ccs con <$> traverse liftArgs args + StgRhsCon ccs con mn ts <$> traverse liftArgs args liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = -- This RHS wasn't lifted. withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> @@ -227,7 +227,7 @@ liftExpr (StgApp f args) = do fvs' <- formerFreeVars f let top_lvl_args = map StgVarArg fvs' ++ args' pure (StgApp f' top_lvl_args) -liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys +liftExpr (StgConApp con mn args tys) = StgConApp con mn <$> traverse liftArgs args <*> pure tys liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty liftExpr (StgCase scrut info ty alts) = do scrut' <- liftExpr scrut diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index 314e010ead..884489e0f7 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -114,9 +114,10 @@ type instance BinderP 'LiftLams = BinderInfo type instance XRhsClosure 'LiftLams = DIdSet type instance XLet 'LiftLams = Skeleton type instance XLetNoEscape 'LiftLams = Skeleton +type instance XConApp 'LiftLams = ConstructorNumber freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet -freeVarsOfRhs (StgRhsCon _ _ args) = mkDVarSet [ id | StgVarArg id <- args ] +freeVarsOfRhs (StgRhsCon _ _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ] freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs -- | Captures details of the syntax tree relevant to the cost model, such as @@ -210,8 +211,8 @@ tagSkeletonTopBind bind = bind' tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr) tagSkeletonExpr (StgLit lit) = (NilSk, emptyVarSet, StgLit lit) -tagSkeletonExpr (StgConApp con args tys) - = (NilSk, mkArgOccs args, StgConApp con args tys) +tagSkeletonExpr (StgConApp con mn args tys) + = (NilSk, mkArgOccs args, StgConApp con mn args tys) tagSkeletonExpr (StgOpApp op args ty) = (NilSk, mkArgOccs args, StgOpApp op args ty) tagSkeletonExpr (StgApp f args) @@ -314,8 +315,8 @@ tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs) bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs) tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs) -tagSkeletonRhs _ (StgRhsCon ccs dc args) - = (NilSk, mkArgOccs args, StgRhsCon ccs dc args) +tagSkeletonRhs _ (StgRhsCon ccs dc mn ts args) + = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn ts args) tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body) = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body') where diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs index 4b99521066..e43bda363d 100644 --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -194,9 +194,9 @@ removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body) | isCurrentCCS ccs = StgRhsClosure ext dontCareCCS upd bndrs body -removeRhsCCCS (StgRhsCon ccs con args) +removeRhsCCCS (StgRhsCon ccs con mu ts args) | isCurrentCCS ccs - = StgRhsCon dontCareCCS con args + = StgRhsCon dontCareCCS con mu ts args removeRhsCCCS rhs = rhs -- | The analysis monad consists of the following 'RWST' components: diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 0ee7381fe0..bf52840f5c 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -150,7 +150,7 @@ checkNoCurrentCCS rhs = do StgRhsClosure _ ccs _ _ _ | isCurrentCCS ccs -> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs') - StgRhsCon ccs _ _ + StgRhsCon ccs _ _ _ _ | isCurrentCCS ccs -> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs') _ -> return () @@ -165,7 +165,7 @@ lintStgRhs (StgRhsClosure _ _ _ binders expr) addInScopeVars binders $ lintStgExpr expr -lintStgRhs rhs@(StgRhsCon _ con args) = do +lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do opts <- getStgPprOpts addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ @@ -181,7 +181,7 @@ lintStgExpr (StgApp fun args) = do lintStgVar fun mapM_ lintStgArg args -lintStgExpr app@(StgConApp con args _arg_tys) = do +lintStgExpr app@(StgConApp con _n args _arg_tys) = do -- unboxed sums should vanish during unarise lf <- getLintFlags when (lf_unarised lf && isUnboxedSumDataCon con) $ do diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs index 0f806a3175..debe53201f 100644 --- a/compiler/GHC/Stg/Stats.hs +++ b/compiler/GHC/Stg/Stats.hs @@ -124,7 +124,7 @@ statBinding top (StgRec pairs) statRhs :: Bool -> (Id, StgRhs) -> StatEnv -statRhs top (_, StgRhsCon _ _ _) +statRhs top (_, StgRhsCon _ _ _ _ _) = countOne (ConstructorBinds top) statRhs top (_, StgRhsClosure _ _ u _ body) @@ -148,7 +148,7 @@ statExpr :: StgExpr -> StatEnv statExpr (StgApp _ _) = countOne Applications statExpr (StgLit _) = countOne Literals -statExpr (StgConApp _ _ _)= countOne ConstructorApps +statExpr (StgConApp _ _ _ _)= countOne ConstructorApps statExpr (StgOpApp _ _ _) = countOne PrimitiveApps statExpr (StgTick _ e) = statExpr e diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 25d01079df..185433100a 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -25,12 +25,14 @@ module GHC.Stg.Syntax ( GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), GenStgAlt, AltType(..), - StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, + StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, XConApp, NoExtFieldSilent, noExtFieldSilent, OutputablePass, UpdateFlag(..), isUpdatable, + ConstructorNumber(..), + -- a set of synonyms for the vanilla parameterisation StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt, @@ -242,6 +244,7 @@ literals. -- StgConApp is vital for returning unboxed tuples or sums -- which can't be let-bound | StgConApp DataCon + (XConApp pass) [StgArg] -- Saturated [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise @@ -416,6 +419,8 @@ important): -- from static closure. DataCon -- Constructor. Never an unboxed tuple or sum, as those -- are not allocated. + ConstructorNumber + [Tickish Id] [StgArg] -- Args {- @@ -478,6 +483,20 @@ type family XLet (pass :: StgPass) type instance XLet 'Vanilla = NoExtFieldSilent type instance XLet 'CodeGen = NoExtFieldSilent +type family XConApp (pass :: StgPass) +type instance XConApp 'Vanilla = ConstructorNumber +type instance XConApp 'CodeGen = ConstructorNumber + +-- | When `-fdistinct-constructor-tables` is turned on then +-- each usage of a constructor is given an unique number and +-- an info table is generated for each different constructor. +data ConstructorNumber = + NoNumber | Numbered Int + +instance Outputable ConstructorNumber where + ppr NoNumber = empty + ppr (Numbered n) = text "#" <> ppr n + type family XLetNoEscape (pass :: StgPass) type instance XLetNoEscape 'Vanilla = NoExtFieldSilent type instance XLetNoEscape 'CodeGen = NoExtFieldSilent @@ -486,7 +505,7 @@ stgRhsArity :: StgRhs -> Int stgRhsArity (StgRhsClosure _ _ _ bndrs _) = ASSERT( all isId bndrs ) length bndrs -- The arity never includes type parameters, but they should have gone by now -stgRhsArity (StgRhsCon _ _ _) = 0 +stgRhsArity (StgRhsCon _ _ _ _ _) = 0 {- ************************************************************************ @@ -648,6 +667,7 @@ likes terminators instead... Ditto for case alternatives. type OutputablePass pass = ( Outputable (XLet pass) + , Outputable (XConApp pass) , Outputable (XLetNoEscape pass) , Outputable (XRhsClosure pass) , OutputableBndr (BinderP pass) @@ -713,7 +733,7 @@ pprStgExpr opts e = case e of StgLit lit -> ppr lit -- general case StgApp func args -> hang (ppr func) 4 (interppSP args) - StgConApp con args _ -> hsep [ ppr con, brackets (interppSP args) ] + StgConApp con n args _ -> hsep [ ppr con, ppr n, brackets (interppSP args) ] StgOpApp op args _ -> hsep [ pprStgOp op, brackets (interppSP args)] -- special case: let v = <very specific thing> @@ -816,5 +836,9 @@ pprStgRhs opts rhs = case rhs of ]) 4 (pprStgExpr opts body) - StgRhsCon cc con args - -> hcat [ ppr cc, space, ppr con, text "! ", brackets (sep (map pprStgArg args))] + StgRhsCon cc con mid _ticks args + -> hcat [ ppr cc, space + , case mid of + NoNumber -> empty + Numbered n -> hcat [ppr n, space] + , ppr con, text "! ", brackets (sep (map pprStgArg args))] diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index 40dff5f33b..c9160ff72a 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -293,9 +293,9 @@ unariseRhs rho (StgRhsClosure ext ccs update_flag args expr) expr' <- unariseExpr rho' expr return (StgRhsClosure ext ccs update_flag args1 expr') -unariseRhs rho (StgRhsCon ccs con args) +unariseRhs rho (StgRhsCon ccs con mu ts args) = ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)) - return (StgRhsCon ccs con (unariseConArgs rho args)) + return (StgRhsCon ccs con mu ts (unariseConArgs rho args)) -------------------------------------------------------------------------------- @@ -325,13 +325,13 @@ unariseExpr rho e@(StgApp f args) unariseExpr _ (StgLit l) = return (StgLit l) -unariseExpr rho (StgConApp dc args ty_args) +unariseExpr rho (StgConApp dc n args ty_args) | Just args' <- unariseMulti_maybe rho dc args ty_args = return (mkTuple args') | otherwise , let args' = unariseConArgs rho args - = return (StgConApp dc args' (map stgArgType args')) + = return (StgConApp dc n args' (map stgArgType args')) unariseExpr rho (StgOpApp op args ty) = return (StgOpApp op (unariseFunArgs rho args) ty) @@ -345,7 +345,7 @@ unariseExpr rho (StgCase scrut bndr alt_ty alts) -- Handle strict lets for tuples and sums: -- case (# a,b #) of r -> rhs -- and analogously for sums - | StgConApp dc args ty_args <- scrut + | StgConApp dc _n args ty_args <- scrut , Just args' <- unariseMulti_maybe rho dc args ty_args = elimCase rho args' bndr alt_ty alts @@ -756,7 +756,7 @@ isUnboxedTupleBndr :: Id -> Bool isUnboxedTupleBndr = isUnboxedTupleType . idType mkTuple :: [StgArg] -> StgExpr -mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args) +mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args (map stgArgType args) tagAltTy :: AltType tagAltTy = PrimAlt IntRep diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index f89f465d12..d60b52536f 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -64,8 +64,9 @@ import GHC.SysTools.FileCleanup import GHC.Data.Stream import GHC.Data.OrdList +import GHC.Types.Unique.Map -import Control.Monad (when,void) +import Control.Monad (when,void, forM_) import GHC.Utils.Misc import System.IO.Unsafe import qualified Data.ByteString as BS @@ -87,7 +88,7 @@ codeGen :: Logger -> Stream IO CmmGroup (SDoc, ModuleLFInfos) -- Output as a stream, so codegen can -- be interleaved with output -codeGen logger dflags this_mod ip_map@(InfoTableProvMap _) data_tycons +codeGen logger dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) data_tycons cost_centre_info stg_binds hpc_info = do { -- cg: run the code generator, and yield the resulting CmmGroup -- Using an IORef to store the state is a bit crude, but otherwise @@ -132,10 +133,15 @@ codeGen logger dflags this_mod ip_map@(InfoTableProvMap _) data_tycons -- enumeration type Note that the closure pointers are -- tagged. when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon) - mapM_ (cg . cgDataCon) (tyConDataCons tycon) + -- Emit normal info_tables, for data constructors defined in this module. + mapM_ (cg . cgDataCon DefinitionSite) (tyConDataCons tycon) ; mapM_ do_tycon data_tycons + -- Emit special info tables for everything used in this module + -- This will only do something if `-fdistinct-info-tables` is turned on. + ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite this_mod k) dc)) (nonDetEltsUFM denv) + ; final_state <- liftIO (readIORef cgref) ; let cg_id_infos = cgs_binds . codegen_state $ final_state used_info = fromOL . codegen_used_info $ final_state @@ -210,8 +216,8 @@ cgTopBinding logger dflags (StgTopStringLit id str) = do cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) -- The Id is passed along for setting up a binding... -cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) - = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args) +cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn _ts args) + = cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args) -- con args are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise @@ -250,11 +256,12 @@ cgEnumerationTyCon tycon | con <- tyConDataCons tycon] --- | Generate the entry code, info tables, and (for niladic constructor) +cgDataCon :: ConInfoTableLocation -> DataCon -> FCode () +-- Generate the entry code, info tables, and (for niladic constructor) -- the static closure, for a constructor. -cgDataCon :: DataCon -> FCode () -cgDataCon data_con - = do { profile <- getProfile +cgDataCon mn data_con + = do { MASSERT( not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con) ) + ; profile <- getProfile ; platform <- getPlatform ; let (tot_wds, -- #ptr_wds + #nonptr_wds @@ -264,7 +271,7 @@ cgDataCon data_con nonptr_wds = tot_wds - ptr_wds dyn_info_tbl = - mkDataConInfoTable profile data_con False ptr_wds nonptr_wds + mkDataConInfoTable profile data_con mn False ptr_wds nonptr_wds -- We're generating info tables, so we don't know and care about -- what the actual arguments are. Using () here as the place holder. diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index ca39b7b362..c4d2174d13 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -205,9 +205,9 @@ cgRhs :: Id -- (see above) ) -cgRhs id (StgRhsCon cc con args) +cgRhs id (StgRhsCon cc con mn _ts args) = withNewTickyCounterCon (idName id) con $ - buildDynCon id True cc con (assertNonVoidStgArgs args) + buildDynCon id mn True cc con (assertNonVoidStgArgs args) -- con args are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 5c9b904896..d73f09e59d 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -97,7 +97,6 @@ import GHC.Types.Basic import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Unit.Module import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 @@ -906,8 +905,8 @@ getTyLitDescription l = -- CmmInfoTable-related things -------------------------------------- -mkDataConInfoTable :: Profile -> DataCon -> Bool -> Int -> Int -> CmmInfoTable -mkDataConInfoTable profile data_con is_static ptr_wds nonptr_wds +mkDataConInfoTable :: Profile -> DataCon -> ConInfoTableLocation -> Bool -> Int -> Int -> CmmInfoTable +mkDataConInfoTable profile data_con mn is_static ptr_wds nonptr_wds = CmmInfoTable { cit_lbl = info_lbl , cit_rep = sm_rep , cit_prof = prof @@ -915,7 +914,7 @@ mkDataConInfoTable profile data_con is_static ptr_wds nonptr_wds , cit_clo = Nothing } where name = dataConName data_con - info_lbl = mkConInfoTableLabel name NoCafRefs + info_lbl = mkConInfoTableLabel name mn -- NoCAFRefs sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds cl_type cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con) -- We keep the *zero-indexed* tag in the srt_len field diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 18a8775cdd..95e975fd0a 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- @@ -62,9 +63,10 @@ import Data.Char cgTopRhsCon :: DynFlags -> Id -- Name of thing bound to this RHS -> DataCon -- Id + -> ConstructorNumber -> [NonVoid StgArg] -- Args -> (CgIdInfo, FCode ()) -cgTopRhsCon dflags id con args +cgTopRhsCon dflags id con mn args | Just static_info <- precomputedStaticConInfo_maybe dflags id con args , let static_code | isInternalName name = pure () | otherwise = gen_code @@ -129,7 +131,7 @@ cgTopRhsCon dflags id con args -- we're not really going to emit an info table, so having -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields -- needs to poke around inside it. - info_tbl = mkDataConInfoTable profile con True ptr_wds nonptr_wds + info_tbl = mkDataConInfoTable profile con (addModuleLoc this_mod mn) True ptr_wds nonptr_wds ; payload <- mapM mk_payload (fix_padding nv_args_w_offsets) @@ -138,8 +140,17 @@ cgTopRhsCon dflags id con args -- TODO (osa): Why? -- BUILD THE OBJECT + -- + -- We're generating info tables, so we don't know and care about + -- what the actual arguments are. Using () here as the place holder. + ; emitDataCon closure_label info_tbl dontCareCCS payload } +addModuleLoc :: Module -> ConstructorNumber -> ConInfoTableLocation +addModuleLoc this_mod mn = do + case mn of + NoNumber -> DefinitionSite + Numbered n -> UsageSite this_mod n --------------------------------------------------------------- -- Lay out and allocate non-top-level constructors @@ -147,6 +158,7 @@ cgTopRhsCon dflags id con args buildDynCon :: Id -- Name of the thing to which this constr will -- be bound + -> ConstructorNumber -> Bool -- is it genuinely bound to that name, or just -- for profiling? -> CostCentreStack -- Where to grab cost centre from; @@ -155,13 +167,14 @@ buildDynCon :: Id -- Name of the thing to which this constr will -> [NonVoid StgArg] -- Its args -> FCode (CgIdInfo, FCode CmmAGraph) -- Return details about how to find it and initialization code -buildDynCon binder actually_bound cc con args +buildDynCon binder mn actually_bound cc con args = do dflags <- getDynFlags - buildDynCon' dflags binder actually_bound cc con args + buildDynCon' dflags binder mn actually_bound cc con args buildDynCon' :: DynFlags - -> Id -> Bool + -> Id -> ConstructorNumber + -> Bool -> CostCentreStack -> DataCon -> [NonVoid StgArg] @@ -178,13 +191,13 @@ the addr modes of the args is that we may be in a "knot", and premature looking at the args will cause the compiler to black-hole! -} -buildDynCon' dflags binder _ _cc con args +buildDynCon' dflags binder _ _ _cc con args | Just cgInfo <- precomputedStaticConInfo_maybe dflags binder con args -- , pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True = return (cgInfo, return mkNop) -------- buildDynCon': the general case ----------- -buildDynCon' _ binder actually_bound ccs con args +buildDynCon' _ binder mn actually_bound ccs con args = do { (id_info, reg) <- rhsIdInfo binder lf_info ; return (id_info, gen_code reg) } @@ -192,12 +205,13 @@ buildDynCon' _ binder actually_bound ccs con args lf_info = mkConLFInfo con gen_code reg - = do { profile <- getProfile + = do { modu <- getModuleName + ; profile <- getProfile ; let platform = profilePlatform profile (tot_wds, ptr_wds, args_w_offsets) - = mkVirtConstrOffsets profile (addArgReps args) + = mkVirtConstrOffsets profile (addArgReps args) nonptr_wds = tot_wds - ptr_wds - info_tbl = mkDataConInfoTable profile con False + info_tbl = mkDataConInfoTable profile con (addModuleLoc modu mn) False ptr_wds nonptr_wds ; let ticky_name | actually_bound = Just binder | otherwise = Nothing diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 7427547bf4..0e0990b901 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -112,7 +112,7 @@ cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do cgExpr (StgOpApp op args ty) = cgOpApp op args ty -cgExpr (StgConApp con args _)= cgConApp con args +cgExpr (StgConApp con mn args _) = cgConApp con mn args cgExpr (StgTick t e) = cgTick t >> cgExpr e cgExpr (StgLit lit) = do cmm_lit <- cgLit lit emitReturn [CmmLit cmm_lit] @@ -187,9 +187,9 @@ cgLetNoEscapeRhsBody -> FCode (CgIdInfo, FCode ()) cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body) = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body -cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) +cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn _ts args) = cgLetNoEscapeClosure bndr local_cc cc [] - (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $ + (StgConApp con mn args (pprPanic "cgLetNoEscapeRhsBody" $ text "StgRhsCon doesn't have type args")) -- For a constructor RHS we want to generate a single chunk of -- code which can be jumped to from many places, which will @@ -862,8 +862,8 @@ maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code = -- Tail calls ----------------------------------------------------------------------------- -cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind -cgConApp con stg_args +cgConApp :: DataCon -> ConstructorNumber -> [StgArg] -> FCode ReturnKind +cgConApp con mn stg_args | isUnboxedTupleDataCon con -- Unboxed tuple: assign and return = do { arg_exprs <- getNonVoidArgAmodes stg_args ; tickyUnboxedTupleReturn (length arg_exprs) @@ -871,7 +871,7 @@ cgConApp con stg_args | otherwise -- Boxed constructors; allocate and return = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args ) - do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False + do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) mn False currentCCS con (assertNonVoidStgArgs stg_args) -- con args are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 163f7a2a8a..fec12e16c7 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -93,7 +93,6 @@ import Control.Monad import Data.List (mapAccumL) - -------------------------------------------------------- -- The FCode monad and its types -- diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index bc10eaf4ea..8472711753 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -92,6 +92,10 @@ import Data.Ord import GHC.Types.Unique.Map import Data.Maybe import GHC.Driver.Ppr +import qualified Data.List.NonEmpty as NE +import GHC.Core.DataCon +import GHC.Types.Unique.FM +import GHC.Data.Maybe ------------------------------------------------------------------------- -- @@ -294,7 +298,8 @@ emitRODataLits :: CLabel -> [CmmLit] -> FCode () emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits) emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode () -emitDataCon lbl itbl ccs payload = emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload)) +emitDataCon lbl itbl ccs payload = + emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload)) newStringCLit :: String -> FCode CmmLit -- Make a global definition for the string, @@ -647,7 +652,7 @@ cmmInfoTableToInfoProvEnt this_mod cmit = -- | Convert source information collected about identifiers in 'GHC.STG.Debug' -- to entries suitable for placing into the info table provenenance table. convertInfoProvMap :: DynFlags -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt] -convertInfoProvMap dflags defns this_mod (InfoTableProvMap denv) = +convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv) = map (\cmit -> let cl = cit_lbl cmit cn = rtsClosureType (cit_rep cmit) @@ -660,8 +665,15 @@ convertInfoProvMap dflags defns this_mod (InfoTableProvMap denv) = Just (ty, ss, l) -> Just (InfoProvEnt cl cn (tyString ty) this_mod (Just (ss, l))) Nothing -> Nothing + lookupDataConMap = do + UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation + -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do + (dc, ns) <- (hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique) + -- Lookup is linear but lists will be small (< 100) + return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (lookup n (NE.toList ns)) + -- This catches things like prim closure types and anything else which doesn't have a -- source location simpleFallback = cmmInfoTableToInfoProvEnt this_mod cmit - in fromMaybe simpleFallback lookupClosureMap) defns + in fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns diff --git a/compiler/GHC/Types/IPE.hs b/compiler/GHC/Types/IPE.hs index 78c929c4db..2f4f0b35b4 100644 --- a/compiler/GHC/Types/IPE.hs +++ b/compiler/GHC/Types/IPE.hs @@ -1,13 +1,15 @@ -module GHC.Types.IPE(ClosureMap, InfoTableProvMap(..) +module GHC.Types.IPE(DCMap, ClosureMap, InfoTableProvMap(..) , emptyInfoTableProvMap) where import GHC.Prelude import GHC.Types.Name import GHC.Types.SrcLoc +import GHC.Core.DataCon import GHC.Types.Unique.Map import GHC.Core.Type +import Data.List.NonEmpty -- | A map from a 'Name' to the best approximate source position that -- name arose from. @@ -17,8 +19,18 @@ type ClosureMap = UniqMap Name -- The binding -- (rendered type, source position, source note -- label) +-- | A map storing all the different uses of a specific data constructor and the +-- approximate source position that usage arose from. +-- The 'Int' is an incrementing identifier which distinguishes each usage +-- of a constructor in a module. It is paired with the source position +-- the constructor was used at, if possible and a string which names +-- the source location. This is the same information as is the payload +-- for the 'GHC.Core.SourceNote' constructor. +type DCMap = UniqMap DataCon (NonEmpty (Int, (RealSrcSpan, String))) + data InfoTableProvMap = InfoTableProvMap - { provClosure :: ClosureMap } + { provDC :: DCMap + , provClosure :: ClosureMap } emptyInfoTableProvMap :: InfoTableProvMap -emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap +emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap |