From 4b297979d25740d31241a9000e36068db112545a Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Wed, 18 Nov 2020 11:36:07 +0000 Subject: Add -finfo-table-map which maps info tables to source positions This new flag embeds a lookup table from the address of an info table to information about that info table. The main interface for consulting the map is the `lookupIPE` C function > InfoProvEnt * lookupIPE(StgInfoTable *info) The `InfoProvEnt` has the following structure: > typedef struct InfoProv_{ > char * table_name; > char * closure_desc; > char * ty_desc; > char * label; > char * module; > char * srcloc; > } InfoProv; > > typedef struct InfoProvEnt_ { > StgInfoTable * info; > InfoProv prov; > struct InfoProvEnt_ *link; > } InfoProvEnt; The source positions are approximated in a similar way to the source positions for DWARF debugging information. They are only approximate but in our experience provide a good enough hint about where the problem might be. It is therefore recommended to use this flag in conjunction with `-g` for more accurate locations. The lookup table is also emitted into the eventlog when it is available as it is intended to be used with the `-hi` profiling mode. Using this flag will significantly increase the size of the resulting object file but only by a factor of 2-3x in our experience. --- compiler/GHC/Stg/Debug.hs | 140 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 140 insertions(+) create mode 100644 compiler/GHC/Stg/Debug.hs (limited to 'compiler/GHC/Stg') diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs new file mode 100644 index 0000000000..e6e85f7db7 --- /dev/null +++ b/compiler/GHC/Stg/Debug.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE TupleSections #-} +-- This module contains functions which implement +-- the -finfo-table-map and -fdistinct-constructor-tables flags +module GHC.Stg.Debug(collectDebugInformation) where + + +import GHC.Prelude + +import GHC.Core +import GHC.Stg.Syntax + +import GHC.Types.Id +import GHC.Core.DataCon +import GHC.Types.IPE +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 +import Control.Monad.Trans.State +import Control.Monad.Trans.Class +import GHC.Types.Unique.Map +import GHC.Types.SrcLoc +import Control.Applicative + +data SpanWithLabel = SpanWithLabel RealSrcSpan String + +data R = R { rDynFlags :: DynFlags, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel } + +type M a = ReaderT R (State InfoTableProvMap) a + +withSpan :: (RealSrcSpan, String) -> M a -> M a +withSpan (new_s, new_l) act = local maybe_replace act + where + maybe_replace r@R{ rModLocation = cur_mod, rSpan = Just (SpanWithLabel old_s _old_l) } + -- prefer spans from the current module + | Just (unpackFS $ srcSpanFile old_s) == ml_hs_file cur_mod + , Just (unpackFS $ srcSpanFile new_s) /= ml_hs_file cur_mod + = r + maybe_replace r + = r { rSpan = Just (SpanWithLabel new_s new_l) } + +collectDebugInformation :: DynFlags -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap) +collectDebugInformation dflags ml bs = + runState (runReaderT (mapM collectTop bs) (R dflags ml Nothing)) emptyInfoTableProvMap + +collectTop :: StgTopBinding -> M StgTopBinding +collectTop (StgTopLifted t) = StgTopLifted <$> collectStgBind t +collectTop tb = return tb + +collectStgBind :: StgBinding -> M StgBinding +collectStgBind (StgNonRec bndr rhs) = do + rhs' <- collectStgRhs bndr rhs + return (StgNonRec bndr rhs') +collectStgBind (StgRec pairs) = do + es <- mapM (\(b, e) -> (b,) <$> collectStgRhs b e) pairs + return (StgRec es) + +collectStgRhs :: Id -> StgRhs -> M StgRhs +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) + + +recordInfo :: Id -> StgExpr -> M () +recordInfo bndr new_rhs = do + modLoc <- asks rModLocation + let + thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc + -- A span from the ticks surrounding the new_rhs + best_span = quickSourcePos thisFile new_rhs + -- A back-up span if the bndr had a source position, many do not (think internally generated ids) + bndr_span = (\s -> SpanWithLabel s (occNameString (getOccName bndr))) + <$> srcSpanToRealSrcSpan (nameSrcSpan (getName bndr)) + recordStgIdPosition bndr best_span bndr_span + +collectExpr :: StgExpr -> M StgExpr +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 (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 + go (StgLet ext bind body) = do + bind' <- collectStgBind bind + body' <- go body + return (StgLet ext bind' body') + go (StgLetNoEscape ext bind body) = do + bind' <- collectStgBind bind + body' <- go body + return (StgLetNoEscape ext bind' body') + + go (StgTick tick e) = do + let k = case tick of + SourceNote ss fp -> withSpan (ss, fp) + _ -> id + e' <- k (go e) + return (StgTick tick e') + +collectAlt :: StgAlt -> M StgAlt +collectAlt (ac, bs, e) = (ac, bs, ) <$> collectExpr e + +-- | Try to find the best source position surrounding a 'StgExpr'. The +-- heuristic strips ticks from the current expression until it finds one which +-- is from the module currently being compiled. This is the same method that +-- the DWARF information uses to give locations to info tables. +-- +-- It is usually a better alternative than using the 'RealSrcSpan' which is carefully +-- propagated downwards by 'withSpan'. It's "quick" because it works only using immediate context rather +-- than looking at the parent context like 'withSpan' +quickSourcePos :: FastString -> StgExpr -> Maybe SpanWithLabel +quickSourcePos cur_mod (StgTick (SourceNote ss m) e) + | srcSpanFile ss == cur_mod = Just (SpanWithLabel ss m) + | otherwise = quickSourcePos cur_mod e +quickSourcePos _ _ = Nothing + +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) + case best_span <|> cc <|> ss of + Nothing -> return () + Just (SpanWithLabel rss d) -> + lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, rss, d)}) + -- cgit v1.2.1