[Git][ghc/ghc][wip/con-info] 2 commits: Checkpoint: SrcSpan information now correct for info tables
Matthew Pickering
gitlab at gitlab.haskell.org
Sat May 16 16:48:53 UTC 2020
Matthew Pickering pushed to branch wip/con-info at Glasgow Haskell Compiler / GHC
Commits:
4861f0f3 by Matthew Pickering at 2020-05-16T12:57:02+01:00
Checkpoint: SrcSpan information now correct for info tables
- - - - -
5040ba85 by Matthew Pickering at 2020-05-16T17:44:03+01:00
WIP: Add InfoProvElt and dump source locations of info tables into
eventlog
- - - - -
24 changed files:
- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/DataCon.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToCmm/Monad.hs
- compiler/GHC/StgToCmm/Prof.hs
- compiler/GHC/StgToCmm/Utils.hs
- compiler/GHC/Types/CostCentre.hs
- includes/rts/EventLogFormat.h
- includes/rts/Profiling.h
- includes/rts/prof/CCS.h
- rts/Profiling.c
- rts/RtsSymbols.c
- rts/Trace.c
- rts/Trace.h
- rts/eventlog/EventLog.c
- rts/eventlog/EventLog.h
Changes:
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -166,9 +166,10 @@ data CmmInfoTable
-- GHC.Cmm.Info.Build.doSRTs.
}
+
data ProfilingInfo
= NoProfilingInfo
- | ProfilingInfo ByteString ByteString -- closure_type, closure_desc
+ | ProfilingInfo ByteString ByteString -- closure_type, closure_desc
-----------------------------------------------------------------------------
-- Static Data
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -13,6 +13,7 @@
module GHC.Cmm.CLabel (
CLabel, -- abstract type
ForeignLabelSource(..),
+ InfoTableEnt(..),
pprDebugCLabel,
mkClosureLabel,
@@ -87,6 +88,8 @@ module GHC.Cmm.CLabel (
isStaticClosureLabel,
mkCCLabel, mkCCSLabel,
+ mkIPELabel, InfoTableEnt(..),
+
DynamicLinkerLabelInfo(..),
mkDynamicLinkerLabel,
dynamicLinkerLabelInfo,
@@ -133,6 +136,7 @@ import GHC.Types.Unique.Set
import GHC.Utils.Misc
import GHC.Core.Ppr ( {- instances -} )
import GHC.CmmToAsm.Config
+import GHC.Types.SrcLoc
-- -----------------------------------------------------------------------------
-- The CLabel type
@@ -235,6 +239,7 @@ data CLabel
| CC_Label CostCentre
| CCS_Label CostCentreStack
+ | IPE_Label InfoTableEnt
-- | These labels are generated and used inside the NCG only.
@@ -307,6 +312,8 @@ instance Ord CLabel where
compare a1 a2
compare (CCS_Label a1) (CCS_Label a2) =
compare a1 a2
+ compare (IPE_Label a1) (IPE_Label a2) =
+ compare a1 a2
compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =
compare a1 a2 `thenCmp`
compare b1 b2
@@ -484,13 +491,13 @@ mkClosureLabel :: Name -> CafInfo -> CLabel
mkInfoTableLabel :: Name -> CafInfo -> CLabel
mkEntryLabel :: Name -> CafInfo -> CLabel
mkClosureTableLabel :: Name -> CafInfo -> CLabel
-mkConInfoTableLabel :: Name -> (Maybe (Module, Int)) -> CafInfo -> CLabel
+mkConInfoTableLabel :: Name -> (Maybe (Module, Int)) -> 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 k c = IdLabel name c (ConInfoTable k)
+mkConInfoTableLabel name k = IdLabel name NoCafRefs (ConInfoTable k)
mkBytesLabel name = IdLabel name NoCafRefs Bytes
mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel
@@ -660,11 +667,18 @@ foreignLabelStdcallInfo _lbl = Nothing
mkBitmapLabel :: Unique -> CLabel
mkBitmapLabel uniq = LargeBitmapLabel uniq
+
+data InfoTableEnt = InfoTableEnt { infoTablePtr :: CLabel
+ , infoTableProv :: (Module, RealSrcSpan, String) }
+ deriving (Eq, Ord)
+
-- Constructing Cost Center Labels
mkCCLabel :: CostCentre -> CLabel
mkCCSLabel :: CostCentreStack -> CLabel
+mkIPELabel :: InfoTableEnt -> CLabel
mkCCLabel cc = CC_Label cc
mkCCSLabel ccs = CCS_Label ccs
+mkIPELabel ipe = IPE_Label ipe
mkRtsApFastLabel :: FastString -> CLabel
mkRtsApFastLabel str = RtsLabel (RtsApFast str)
@@ -803,6 +817,7 @@ needsCDecl (CmmLabel pkgId _ _)
needsCDecl l@(ForeignLabel{}) = not (isMathFun l)
needsCDecl (CC_Label _) = True
needsCDecl (CCS_Label _) = True
+needsCDecl (IPE_Label {}) = True
needsCDecl (HpcTicksLabel _) = True
needsCDecl (DynamicLinkerLabel {}) = panic "needsCDecl DynamicLinkerLabel"
needsCDecl PicBaseLabel = panic "needsCDecl PicBaseLabel"
@@ -925,6 +940,7 @@ externallyVisibleCLabel (ForeignLabel{}) = True
externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info
externallyVisibleCLabel (CC_Label _) = True
externallyVisibleCLabel (CCS_Label _) = True
+externallyVisibleCLabel (IPE_Label {}) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel (LargeBitmapLabel _) = False
@@ -984,6 +1000,7 @@ labelType (AsmTempDerivedLabel _ _) = panic "labelType(AsmTempDerive
labelType (StringLitLabel _) = DataLabel
labelType (CC_Label _) = DataLabel
labelType (CCS_Label _) = DataLabel
+labelType (IPE_Label {}) = DataLabel
labelType (DynamicLinkerLabel _ _) = DataLabel -- Is this right?
labelType PicBaseLabel = DataLabel
labelType (DeadStripPreventer _) = DataLabel
@@ -1072,6 +1089,7 @@ labelDynamic config this_mod lbl =
-- CCS_Label always contains a CostCentre defined in the current module
CCS_Label _ -> False
+ IPE_Label {} -> False
HpcTicksLabel m ->
externalDynamicRefs && this_mod /= m
@@ -1295,6 +1313,7 @@ pprCLbl dflags = \case
(CC_Label cc) -> ppr cc
(CCS_Label ccs) -> ppr ccs
+ (IPE_Label (InfoTableEnt l _)) -> ppr l <> text "_ipe"
(HpcTicksLabel mod) -> text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc")
(AsmTempLabel {}) -> panic "pprCLbl AsmTempLabel"
=====================================
compiler/GHC/Cmm/DebugBlock.hs
=====================================
@@ -189,7 +189,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
ticks = nubBy (flip tickishContains) $
bCtxsTicks bctxs ++ ticksToCopy scope
stick = case filter isSourceTick ticks of
- [] -> cstick
+ [] -> pprTraceIt "DWARF-C" cstick
sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)
-- | Build a map of blocks sorted by their tick scopes
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -11,7 +11,7 @@
-- And, as we have the info in hand, we may convert some lets to
-- let-no-escapes.
-module GHC.CoreToStg ( coreToStg ) where
+module GHC.CoreToStg ( coreToStg ) where
#include "HsVersions.h"
@@ -53,8 +53,9 @@ import Data.List.NonEmpty (nonEmpty, toList)
import Data.Maybe (fromMaybe)
import Control.Monad (ap)
import qualified Data.Set as Set
-import Control.Monad.Trans.State
+import Control.Monad.Trans.RWS
import GHC.Types.Unique.Map
+import GHC.Types.SrcLoc
-- Note [Live vs free]
-- ~~~~~~~~~~~~~~~~~~~
@@ -226,7 +227,6 @@ import GHC.Types.Unique.Map
-- Setting variable info: top-level, binds, RHSs
-- --------------------------------------------------------------
-type DCMap = UniqMap DataCon Int
coreToStg :: DynFlags -> Module -> CoreProgram
-> ([StgTopBinding], DCMap, CollectedCCs)
@@ -410,12 +410,12 @@ coreToStgExpr expr@(Lam _ _)
return result_expr
coreToStgExpr (Tick tick expr)
- = do case tick of
- HpcTick{} -> return ()
- ProfNote{} -> return ()
- SourceNote{} -> return ()
- Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
- expr2 <- coreToStgExpr expr
+ = do let k = case tick of
+ HpcTick{} -> id
+ ProfNote{} -> id
+ SourceNote ss fp -> withSpan (ss, fp)
+ Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
+ expr2 <- k (coreToStgExpr expr)
return (StgTick tick expr2)
coreToStgExpr (Cast expr _)
@@ -833,7 +833,7 @@ isPAP env _ = False
newtype CtsM a = CtsM
{ unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs
-> IdEnv HowBound
- -> State DCMap a
+ -> RWS (Maybe (RealSrcSpan, String)) () DCMap a
}
deriving (Functor)
@@ -870,7 +870,9 @@ data LetInfo
-- The std monad functions:
initCts :: DynFlags -> IdEnv HowBound -> DCMap -> CtsM a -> (a, DCMap)
-initCts dflags env u m = flip runState u (unCtsM m dflags env)
+initCts dflags env u m =
+ let (a, d, ()) = runRWS (unCtsM m dflags env) Nothing u
+ in (a, d)
@@ -915,11 +917,14 @@ lookupBinding env v = case lookupVarEnv env v of
incDc :: DataCon -> CtsM Int
incDc dc = CtsM $ \_ _ -> do
env <- get
- let env' = alterUniqMap (maybe (Just 0) (Just . (+1))) env dc
+ cc <- ask
+ let env' = alterUniqMap (maybe (Just [(0, cc)]) (\xs@((k, _):_) -> Just ((k + 1, cc) : xs))) env dc
put env'
let Just r = lookupUniqMap env' dc
- return r
+ return (fst (head r))
+withSpan :: (RealSrcSpan, String) -> CtsM a -> CtsM a
+withSpan s (CtsM act) = CtsM (\a b -> local (const $ Just s) (act a b))
getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
getAllCAFsCC this_mod =
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeApplications #-}
{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
@@ -10,6 +11,7 @@ module GHC.Driver.CodeOutput
( codeOutput
, outputForeignStubs
, profilingInitCode
+ , ipInitCode
)
where
@@ -32,6 +34,8 @@ import GHC.Driver.Session
import GHC.Data.Stream ( Stream )
import qualified GHC.Data.Stream as Stream
import GHC.SysTools.FileCleanup
+import GHC.StgToCmm.Utils
+
import GHC.Utils.Error
import GHC.Utils.Outputable
@@ -314,3 +318,35 @@ profilingInitCode dflags this_mod (local_CCs, singleton_CCSs)
| cc <- ccs
] ++ [text "NULL"])
<> semi
+
+
+-- | Generate code to initialise info pointer origin
+ipInitCode :: DynFlags -> Module -> DCMap -> SDoc
+ipInitCode dflags this_mod dcmap
+ = pprTraceIt "codeOutput" $ if not (gopt Opt_SccProfilingOn dflags)
+ then empty
+ else vcat
+ $ map emit_ipe_decl ents
+ ++ [emit_ipe_list ents]
+ ++ [ text "static void ip_init_" <> ppr this_mod
+ <> text "(void) __attribute__((constructor));"
+ , text "static void ip_init_" <> ppr this_mod <> text "(void)"
+ , braces (vcat
+ [ text "registerInfoProvList" <> parens local_ipe_list_label <> semi
+ ])
+ ]
+ where
+ ents = convertDCMap this_mod dcmap
+ emit_ipe_decl ipe =
+ text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"
+ where ipe_lbl = ppr (mkIPELabel ipe)
+ local_ipe_list_label = text "local_ipe_" <> ppr this_mod
+ emit_ipe_list ipes =
+ text "static InfoProvEnt *" <> local_ipe_list_label <> text "[] ="
+ <+> braces (vcat $ [ ppr (mkIPELabel ipe) <> comma
+ | ipe <- ipes
+ ] ++ [text "NULL"])
+ <> semi
+
+
+
=====================================
compiler/GHC/Driver/Hooks.hs
=====================================
@@ -110,7 +110,8 @@ data Hooks = Hooks
, getValueSafelyHook :: Maybe (HscEnv -> Name -> Type
-> IO (Maybe HValue))
, createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)
- , stgToCmmHook :: Maybe (DynFlags -> Module -> UniqMap DataCon Int -> [TyCon] -> CollectedCCs
+ , stgToCmmHook :: Maybe (DynFlags -> Module -> DCMap -> [TyCon] -> CollectedCCs
+
-> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ())
, cmmToRawCmmHook :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a))
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -138,6 +138,7 @@ import GHC.Cmm.Parser ( parseCmmFile )
import GHC.Cmm.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Info
+import GHC.Cmm.CLabel
import GHC.Driver.CodeOutput
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
@@ -1418,7 +1419,8 @@ hscGenHardCode hsc_env cgguts location output_filename = do
let cost_centre_info =
(S.toList local_ccs ++ caf_ccs, caf_cc_stacks)
prof_init = profilingInitCode dflags this_mod cost_centre_info
- foreign_stubs = foreign_stubs0 `appendStubC` prof_init
+ ip_init = ipInitCode dflags this_mod denv
+ foreign_stubs = foreign_stubs0 `appendStubC` prof_init `appendStubC` ip_init
------------------ Code generation ------------------
@@ -1540,7 +1542,7 @@ This reduces residency towards the end of the CodeGen phase significantly
(5-10%).
-}
-doCodeGen :: HscEnv -> Module -> UniqMap DataCon Int -> [TyCon]
+doCodeGen :: HscEnv -> Module -> DCMap -> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
@@ -1589,7 +1591,7 @@ doCodeGen hsc_env this_mod denv data_tycons
myCoreToStg :: DynFlags -> Module -> CoreProgram
-> IO ( [StgTopBinding] -- output program
- , UniqMap DataCon Int
+ , DCMap
, CollectedCCs ) -- CAF cost centre info (declared and used)
myCoreToStg dflags this_mod prepd_binds = do
let (stg_binds, denv, cost_centre_info)
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -15,7 +15,7 @@ module GHC.StgToCmm ( codeGen ) where
import GHC.Prelude as Prelude
-import GHC.StgToCmm.Prof (initCostCentres, ldvEnter)
+import GHC.StgToCmm.Prof (initInfoTableProv, initCostCentres, ldvEnter)
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Env
import GHC.StgToCmm.Bind
@@ -58,10 +58,13 @@ import GHC.Utils.Misc
import System.IO.Unsafe
import qualified Data.ByteString as BS
import GHC.Types.Unique.Map
+import GHC.Types.SrcLoc
+import Data.Maybe
+
codeGen :: DynFlags
-> Module
- -> UniqMap DataCon Int
+ -> DCMap
-> [TyCon]
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [CgStgTopBinding] -- Bindings to convert
@@ -69,7 +72,7 @@ codeGen :: DynFlags
-> Stream IO CmmGroup () -- Output as a stream, so codegen can
-- be interleaved with output
-codeGen dflags this_mod (UniqMap denv) data_tycons
+codeGen dflags this_mod dcmap@(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
@@ -92,7 +95,7 @@ codeGen dflags this_mod (UniqMap denv) data_tycons
-- FIRST. This is because when -split-objs is on we need to
-- combine this block with its initialisation routines; see
-- Note [pipeline-split-init].
- ; cg (mkModuleInit cost_centre_info this_mod hpc_info)
+ ; cg (mkModuleInit cost_centre_info this_mod hpc_info (convertDCMap this_mod dcmap))
; mapM_ (cg . cgTopBinding dflags) stg_binds
@@ -106,11 +109,11 @@ codeGen dflags this_mod (UniqMap denv) data_tycons
-- tagged.
when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
-- Emit normal info_tables, just in case
- mapM_ (cg . cgDataCon Nothing) (tyConDataCons tycon)
+ mapM_ (cg . cgDataCon Nothing Nothing) (tyConDataCons tycon)
-- Emit special info tables for everything used in this module
; mapM_ do_tycon data_tycons
- ; mapM_ (\(dc, n) -> forM_ [0..n] $ \k -> cg (cgDataCon (Just (this_mod, k)) dc)) (nonDetEltsUFM denv)
+ ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, ss) -> cg (cgDataCon (Just (this_mod, k)) ss dc)) (nonDetEltsUFM denv)
}
---------------------------------------------------------------
@@ -183,11 +186,13 @@ mkModuleInit
:: CollectedCCs -- cost centre info
-> Module
-> HpcInfo
+ -> [InfoTableEnt]
-> FCode ()
-mkModuleInit cost_centre_info this_mod hpc_info
+mkModuleInit cost_centre_info this_mod hpc_info info_ents
= do { initHpc this_mod hpc_info
; initCostCentres cost_centre_info
+ ; initInfoTableProv info_ents
}
@@ -205,12 +210,12 @@ cgEnumerationTyCon tycon
| con <- tyConDataCons tycon]
-cgDataCon :: Maybe (Module, Int) -> DataCon -> FCode ()
+cgDataCon :: Maybe (Module, Int) -> Maybe (RealSrcSpan, String) -> DataCon -> FCode ()
-- Generate the entry code, info tables, and (for niladic constructor)
-- the static closure, for a constructor.
-cgDataCon _ data_con | isUnboxedTupleCon data_con = return ()
-cgDataCon mn data_con
- = do { pprTraceM "cgDataCon" (ppr mn <+> ppr data_con)
+cgDataCon _ _ data_con | isUnboxedTupleCon data_con = return ()
+cgDataCon mn ms data_con
+ = do { pprTraceM "cgDataCon" (ppr mn <+> ppr ms <+> ppr data_con)
; dflags <- getDynFlags
; platform <- getPlatform
; let
@@ -221,7 +226,7 @@ cgDataCon mn data_con
nonptr_wds = tot_wds - ptr_wds
dyn_info_tbl =
- mkDataConInfoTable dflags data_con mn False ptr_wds nonptr_wds
+ mkDataConInfoTable dflags data_con mn ms 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.
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -71,6 +71,8 @@ import GHC.Runtime.Heap.Layout
import GHC.Cmm
import GHC.Cmm.Ppr.Expr() -- For Outputable instances
+import GHC.Types.SrcLoc
+
import GHC.Types.CostCentre
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
@@ -947,8 +949,8 @@ getTyLitDescription l =
-- CmmInfoTable-related things
--------------------------------------
-mkDataConInfoTable :: DynFlags -> DataCon -> Maybe (Module, Int) -> Bool -> Int -> Int -> CmmInfoTable
-mkDataConInfoTable dflags data_con mn is_static ptr_wds nonptr_wds
+mkDataConInfoTable :: DynFlags -> DataCon -> Maybe (Module, Int) -> Maybe (RealSrcSpan, String) -> Bool -> Int -> Int -> CmmInfoTable
+mkDataConInfoTable dflags data_con mn mspn is_static ptr_wds nonptr_wds
= CmmInfoTable { cit_lbl = info_lbl
, cit_rep = sm_rep
, cit_prof = prof
@@ -956,7 +958,7 @@ mkDataConInfoTable dflags data_con mn is_static ptr_wds nonptr_wds
, cit_clo = Nothing }
where
name = dataConName data_con
- info_lbl = mkConInfoTableLabel name mn NoCafRefs
+ info_lbl = mkConInfoTableLabel name mn
sm_rep = mkHeapRep dflags 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
@@ -966,7 +968,11 @@ mkDataConInfoTable dflags data_con mn is_static ptr_wds nonptr_wds
| otherwise = ProfilingInfo ty_descr val_descr
ty_descr = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con
- val_descr = BS8.pack $ occNameString $ getOccName data_con
+ val_descr = BS8.pack $ (occNameString $ getOccName data_con) ++ span_string
+
+ span_string = case mspn of
+ Nothing -> ""
+ Just (spn, f) -> f ++ ":" ++ show (srcSpanStartLine spn) ++ ":" ++ show (srcSpanStartCol spn)
-- We need a black-hole closure info to pass to @allocDynClosure@ when we
-- want to allocate the black hole on entry to a CAF.
=====================================
compiler/GHC/StgToCmm/DataCon.hs
=====================================
@@ -30,6 +30,7 @@ import GHC.StgToCmm.Layout
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
+import GHC.Types.SrcLoc
import GHC.Cmm.Expr
import GHC.Cmm.Utils
@@ -113,7 +114,7 @@ cgTopRhsCon dflags id con mn 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 dflags con ((this_mod,) <$> mn) True ptr_wds nonptr_wds
+ info_tbl = mkDataConInfoTable dflags con ((this_mod,) <$> mn) Nothing True ptr_wds nonptr_wds
; payload <- mapM mk_payload nv_args_w_offsets
@@ -146,11 +147,13 @@ buildDynCon :: Id -- Name of the thing to which this constr will
-- Return details about how to find it and initialization code
buildDynCon binder mn actually_bound cc con args
= do dflags <- getDynFlags
- buildDynCon' dflags binder mn actually_bound cc con args
+ spn <- getEnclosingSpan
+ buildDynCon' dflags binder mn spn actually_bound cc con args
buildDynCon' :: DynFlags
- -> Id -> Maybe Int -> Bool
+ -> Id -> Maybe Int -> Maybe (RealSrcSpan, String)
+ -> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
@@ -167,13 +170,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' dflags binder mn actually_bound ccs con args
+buildDynCon' dflags binder mn spn actually_bound ccs con args
= do { (id_info, reg) <- rhsIdInfo binder lf_info
; return (id_info, gen_code reg)
}
@@ -185,7 +188,7 @@ buildDynCon' dflags binder mn actually_bound ccs con args
; let (tot_wds, ptr_wds, args_w_offsets)
= mkVirtConstrOffsets dflags (addArgReps args)
nonptr_wds = tot_wds - ptr_wds
- info_tbl = mkDataConInfoTable dflags con ((modu,) <$> mn) False
+ info_tbl = mkDataConInfoTable dflags con ((modu,) <$> mn) spn False
ptr_wds nonptr_wds
; let ticky_name | actually_bound = Just binder
| otherwise = Nothing
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -81,7 +81,7 @@ cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
cgExpr (StgOpApp op args ty) = cgOpApp op args ty
cgExpr (StgConApp con mn args _)= cgConApp con mn args
-cgExpr (StgTick t e) = cgTick t >> cgExpr e
+cgExpr (StgTick t e) = cgTick t (cgExpr e)
cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
emitReturn [CmmLit cmm_lit]
@@ -1083,12 +1083,12 @@ emitEnter fun = do
-- | Generate Cmm code for a tick. Depending on the type of Tickish,
-- this will either generate actual Cmm instrumentation code, or
-- simply pass on the annotation as a @CmmTickish at .
-cgTick :: Tickish Id -> FCode ()
-cgTick tick
+cgTick :: Tickish Id -> FCode a -> FCode a
+cgTick tick k
= do { platform <- getPlatform
; case tick of
- ProfNote cc t p -> emitSetCCC cc t p
- HpcTick m n -> emit (mkTickBox platform m n)
- SourceNote s n -> emitTick $ SourceNote s n
- _other -> return () -- ignore
+ ProfNote cc t p -> emitSetCCC cc t p >> k
+ HpcTick m n -> emit (mkTickBox platform m n) >> k
+ SourceNote s n -> emitTick (SourceNote s n) >> withEnclosingSpan s n k
+ _other -> k
}
=====================================
compiler/GHC/StgToCmm/Monad.hs
=====================================
@@ -54,7 +54,7 @@ module GHC.StgToCmm.Monad (
-- more localised access to monad state
CgIdInfo(..),
getBinds, setBinds,
-
+ withEnclosingSpan, getEnclosingSpan,
-- out of general friendliness, we also export ...
CgInfoDownwards(..), CgState(..) -- non-abstract
) where
@@ -80,6 +80,7 @@ import GHC.Types.Unique.Supply
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Misc
+import GHC.Types.SrcLoc
import Control.Monad
import Data.List
@@ -166,7 +167,8 @@ data CgInfoDownwards -- information only passed *downwards* by the monad
-- as local jumps? See Note
-- [Self-recursive tail calls] in
-- GHC.StgToCmm.Expr
- cgd_tick_scope:: CmmTickScope -- Tick scope for new blocks & ticks
+ cgd_tick_scope:: CmmTickScope, -- Tick scope for new blocks & ticks
+ cgd_enclosing_span :: Maybe (RealSrcSpan, String) --
}
type CgBindings = IdEnv CgIdInfo
@@ -281,7 +283,8 @@ initCgInfoDown dflags mod
, cgd_ticky = mkTopTickyCtrLabel
, cgd_sequel = initSequel
, cgd_self_loop = Nothing
- , cgd_tick_scope= GlobalScope }
+ , cgd_tick_scope= GlobalScope
+ , cgd_enclosing_span = Nothing }
initSequel :: Sequel
initSequel = Return
@@ -455,6 +458,12 @@ newUnique = do
return u
------------------
+withEnclosingSpan :: RealSrcSpan -> String -> FCode a -> FCode a
+withEnclosingSpan ss s (FCode f)= FCode $ \info_down st -> f (info_down { cgd_enclosing_span = Just (ss, s) }) st
+
+getEnclosingSpan :: FCode (Maybe (RealSrcSpan, String))
+getEnclosingSpan = FCode $ \info_down st -> (cgd_enclosing_span info_down, st)
+
getInfoDown :: FCode CgInfoDownwards
getInfoDown = FCode $ \info_down state -> (info_down,state)
=====================================
compiler/GHC/StgToCmm/Prof.hs
=====================================
@@ -10,6 +10,9 @@ module GHC.StgToCmm.Prof (
initCostCentres, ccType, ccsType,
mkCCostCentre, mkCCostCentreStack,
+ -- infoTablePRov
+ initInfoTableProv,
+
-- Cost-centre Profiling
dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
enterCostCentreThunk, enterCostCentreFun,
@@ -270,6 +273,37 @@ sizeof_ccs_words dflags
platform = targetPlatform dflags
(ws,ms) = sIZEOF_CostCentreStack dflags `divMod` platformWordSizeInBytes platform
+
+initInfoTableProv :: [InfoTableEnt] -> FCode ()
+-- Emit the declarations
+initInfoTableProv ents
+ = do dflags <- getDynFlags
+ pprTraceM "initInfoTable" (ppr (length ents))
+ mapM_ emitInfoTableProv ents
+
+--- Info Table Prov stuff
+emitInfoTableProv :: InfoTableEnt -> FCode ()
+emitInfoTableProv ip = do
+ { dflags <- getDynFlags
+ ; let (mod, src, label) = infoTableProv ip
+ ; platform <- getPlatform
+ -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
+ ; label <- newByteStringCLit (bytesFS $ mkFastString label)
+ ; modl <- newByteStringCLit (bytesFS $ moduleNameFS
+ $ moduleName
+ $ mod)
+ ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
+ showPpr dflags src
+ -- XXX going via FastString to get UTF-8 encoding is silly
+ ; let
+ lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer
+ label, -- char *label,
+ modl, -- char *module,
+ loc, -- char *srcloc,
+ zero platform -- struct _InfoProvEnt *link
+ ]
+ ; emitDataLits (mkIPELabel ip) lits
+ }
-- ---------------------------------------------------------------------------
-- Set the current cost centre stack
@@ -298,6 +332,7 @@ bumpSccCount dflags ccs
(cmmOffsetB platform ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
where platform = targetPlatform dflags
+
-----------------------------------------------------------------------------
--
-- Lag/drag/void stuff
=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -44,6 +44,8 @@ module GHC.StgToCmm.Utils (
whenUpdRemSetEnabled,
emitUpdRemSetPush,
emitUpdRemSetPushThunk,
+
+ convertDCMap
) where
#include "HsVersions.h"
@@ -85,6 +87,10 @@ import qualified Data.Map as M
import Data.Char
import Data.List
import Data.Ord
+import GHC.Types.Unique.Map
+import GHC.Types.Unique.FM
+import Data.Maybe
+import GHC.Core.DataCon
-------------------------------------------------------------------------
@@ -624,3 +630,13 @@ emitUpdRemSetPushThunk ptr = do
[(CmmReg (CmmGlobal BaseReg), AddrHint),
(ptr, AddrHint)]
False
+
+
+convertDCMap :: Module -> DCMap -> [InfoTableEnt]
+convertDCMap this_mod (UniqMap denv) =
+ concatMap (\(dc, ns) -> mapMaybe (\(k, mss) ->
+ case mss of
+ Nothing -> Nothing
+ Just (ss, l) -> Just $
+ InfoTableEnt (mkConInfoTableLabel (dataConName dc) (Just (this_mod, k)))
+ (this_mod, ss, l)) ns) (nonDetEltsUFM denv)
\ No newline at end of file
=====================================
compiler/GHC/Types/CostCentre.hs
=====================================
@@ -2,7 +2,7 @@
module GHC.Types.CostCentre (
CostCentre(..), CcName, CCFlavour(..),
-- All abstract except to friend: ParseIface.y
-
+ DCMap,
CostCentreStack,
CollectedCCs, emptyCollectedCCs, collectCC,
currentCCS, dontCareCCS,
@@ -32,6 +32,8 @@ import GHC.Types.SrcLoc
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Types.CostCentre.State
+import GHC.Core.DataCon
+import GHC.Types.Unique.Map
import Data.Data
@@ -185,6 +187,8 @@ data CostCentreStack
deriving (Eq, Ord) -- needed for Ord on CLabel
+type DCMap = UniqMap DataCon [(Int, Maybe (RealSrcSpan, String))]
+
-- synonym for triple which describes the cost centre info in the generated
-- code for a module.
=====================================
includes/rts/EventLogFormat.h
=====================================
@@ -142,6 +142,7 @@
#define EVENT_HEAP_BIO_PROF_SAMPLE_BEGIN 166
#define EVENT_PROF_SAMPLE_COST_CENTRE 167
#define EVENT_PROF_BEGIN 168
+#define EVENT_IPE 169
#define EVENT_USER_BINARY_MSG 181
=====================================
includes/rts/Profiling.h
=====================================
@@ -14,4 +14,5 @@
#pragma once
void registerCcList(CostCentre **cc_list);
+void registerInfoProvList(InfoProvEnt **cc_list);
void registerCcsList(CostCentreStack **cc_list);
=====================================
includes/rts/prof/CCS.h
=====================================
@@ -73,6 +73,19 @@ typedef struct CostCentreStack_ {
} CostCentreStack;
+typedef struct InfoProv_{
+ char * label;
+ char * module;
+ char * srcloc;
+} InfoProv;
+
+typedef struct InfoProvEnt_ {
+ StgInfoTable * info;
+ InfoProv prov;
+ struct InfoProvEnt_ *link;
+} InfoProvEnt;
+
+
/* -----------------------------------------------------------------------------
* Start and stop the profiling timer. These can be called from
* Haskell to restrict the profile to portion(s) of the execution.
@@ -177,6 +190,7 @@ void enterFunCCS (StgRegTable *reg, CostCentreStack *);
CostCentre *mkCostCentre (char *label, char *module, char *srcloc);
extern CostCentre * RTS_VAR(CC_LIST); // registered CC list
+extern InfoProvEnt * RTS_VAR(IPE_LIST); // registered IP list
/* -----------------------------------------------------------------------------
* Declaring Cost Centres & Cost Centre Stacks.
=====================================
rts/Profiling.c
=====================================
@@ -57,6 +57,8 @@ CostCentre *CC_LIST = NULL;
// parent of all cost centres stacks (done in initProfiling2()).
static CostCentreStack *CCS_LIST = NULL;
+InfoProvEnt *IPE_LIST = NULL;
+
#if defined(THREADED_RTS)
static Mutex ccs_mutex;
#endif
@@ -145,6 +147,19 @@ dumpCostCentresToEventLog(void)
#endif
}
+static void
+dumpIPEToEventLog(void)
+{
+#if defined(PROFILING)
+ InfoProvEnt *ip, *next;
+ for (ip = IPE_LIST; ip != NULL; ip = next) {
+ next = ip->link;
+ traceIPE(ip->info, ip->prov.label,
+ ip->prov.module, ip->prov.srcloc);
+ }
+#endif
+}
+
void initProfiling (void)
{
// initialise our arena
@@ -202,6 +217,7 @@ void initProfiling (void)
}
dumpCostCentresToEventLog();
+ dumpIPEToEventLog();
}
@@ -338,6 +354,15 @@ static void registerCCS(CostCentreStack *ccs)
}
}
+static void
+registerInfoProvEnt(InfoProvEnt *ipe)
+{
+ //if (ipe->link == NULL) {
+ ipe->link = IPE_LIST;
+ IPE_LIST = ipe;
+ //}
+}
+
void registerCcList(CostCentre **cc_list)
{
for (CostCentre **i = cc_list; *i != NULL; i++) {
@@ -352,6 +377,13 @@ void registerCcsList(CostCentreStack **cc_list)
}
}
+void registerInfoProvList(InfoProvEnt **ent_list)
+{
+ for (InfoProvEnt **i = ent_list; *i != NULL; i++) {
+ registerInfoProvEnt(*i);
+ }
+}
+
/* -----------------------------------------------------------------------------
Set CCCS when entering a function.
=====================================
rts/RtsSymbols.c
=====================================
@@ -527,11 +527,13 @@
#define RTS_PROF_SYMBOLS \
SymI_HasProto(CCS_DONT_CARE) \
SymI_HasProto(CC_LIST) \
+ SymI_HasProto(IPE_LIST) \
SymI_HasProto(stg_restore_cccs_info) \
SymI_HasProto(enterFunCCS) \
SymI_HasProto(pushCostCentre) \
SymI_HasProto(mkCostCentre) \
SymI_HasProto(registerCcList) \
+ SymI_HasProto(registerInfoProvList) \
SymI_HasProto(registerCcsList) \
SymI_HasProto(era)
#else
=====================================
rts/Trace.c
=====================================
@@ -643,6 +643,16 @@ void traceHeapProfCostCentre(StgWord32 ccID,
}
}
+void traceIPE(StgInfoTable * info,
+ const char *label,
+ const char *module,
+ const char *srcloc )
+{
+ if (eventlog_enabled) {
+ postIPE(info, label, module, srcloc);
+ }
+}
+
// This one is for .hp samples
void traceHeapProfSampleCostCentre(StgWord8 profile_id,
CostCentreStack *stack, StgWord residency)
=====================================
rts/Trace.h
=====================================
@@ -302,6 +302,10 @@ void traceHeapProfCostCentre(StgWord32 ccID,
const char *module,
const char *srcloc,
StgBool is_caf);
+void traceIPE(StgInfoTable *info,
+ const char *label,
+ const char *module,
+ const char *srcloc );
void traceHeapProfSampleCostCentre(StgWord8 profile_id,
CostCentreStack *stack, StgWord residency);
@@ -354,6 +358,7 @@ void flushTrace(void);
#define traceTaskDelete_(taskID) /* nothing */
#define traceHeapProfBegin(profile_id) /* nothing */
#define traceHeapProfCostCentre(ccID, label, module, srcloc, is_caf) /* nothing */
+#define traceIPE(info, label, module, srcloc) /* nothing */
#define traceHeapProfSampleBegin(era) /* nothing */
#define traceHeapBioProfSampleBegin(era, time) /* nothing */
#define traceHeapProfSampleEnd(era) /* nothing */
=====================================
rts/eventlog/EventLog.c
=====================================
@@ -104,6 +104,7 @@ char *EventDesc[] = {
[EVENT_HACK_BUG_T9003] = "Empty event for bug #9003",
[EVENT_HEAP_PROF_BEGIN] = "Start of heap profile",
[EVENT_HEAP_PROF_COST_CENTRE] = "Cost center definition",
+ [EVENT_IPE] = "ITE",
[EVENT_HEAP_PROF_SAMPLE_BEGIN] = "Start of heap profile sample",
[EVENT_HEAP_BIO_PROF_SAMPLE_BEGIN] = "Start of heap profile (biographical) sample",
[EVENT_HEAP_PROF_SAMPLE_END] = "End of heap profile sample",
@@ -433,6 +434,9 @@ init_event_types(void)
case EVENT_HEAP_PROF_COST_CENTRE:
eventTypes[t].size = EVENT_SIZE_DYNAMIC;
break;
+ case EVENT_IPE:
+ eventTypes[t].size = EVENT_SIZE_DYNAMIC;
+ break;
case EVENT_HEAP_PROF_SAMPLE_BEGIN:
eventTypes[t].size = 8;
@@ -1407,6 +1411,25 @@ void postHeapProfCostCentre(StgWord32 ccID,
postWord8(&eventBuf, is_caf);
RELEASE_LOCK(&eventBufMutex);
}
+void postIPE(StgWord64 info,
+ const char *label,
+ const char *module,
+ const char *srcloc)
+{
+ ACQUIRE_LOCK(&eventBufMutex);
+ StgWord label_len = strlen(label);
+ StgWord module_len = strlen(module);
+ StgWord srcloc_len = strlen(srcloc);
+ StgWord len = 8+label_len+module_len+srcloc_len+3;
+ ensureRoomForVariableEvent(&eventBuf, len);
+ postEventHeader(&eventBuf, EVENT_IPE);
+ postPayloadSize(&eventBuf, len);
+ postWord64(&eventBuf, info);
+ postString(&eventBuf, label);
+ postString(&eventBuf, module);
+ postString(&eventBuf, srcloc);
+ RELEASE_LOCK(&eventBufMutex);
+}
void postHeapProfSampleCostCentre(StgWord8 profile_id,
CostCentreStack *stack,
=====================================
rts/eventlog/EventLog.h
=====================================
@@ -157,6 +157,10 @@ void postHeapProfCostCentre(StgWord32 ccID,
const char *module,
const char *srcloc,
StgBool is_caf);
+void postIPE(StgWord64 info,
+ const char *label,
+ const char *module,
+ const char *srcloc);
void postHeapProfSampleCostCentre(StgWord8 profile_id,
CostCentreStack *stack,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/65c5a4d7e40c2d357f34127d55d1cc0bbb535e8c...5040ba85bec702e45116e1e57f1150ca2b09bd89
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/65c5a4d7e40c2d357f34127d55d1cc0bbb535e8c...5040ba85bec702e45116e1e57f1150ca2b09bd89
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200516/b6496b85/attachment-0001.html>
More information about the ghc-commits
mailing list