[Git][ghc/ghc][wip/con-info] 3 commits: Working
Matthew Pickering
gitlab at gitlab.haskell.org
Sat Jun 6 13:36:02 UTC 2020
Matthew Pickering pushed to branch wip/con-info at Glasgow Haskell Compiler / GHC
Commits:
4f0a6890 by Matthew Pickering at 2020-06-05T19:56:20+01:00
Working
- - - - -
f879243c by Matthew Pickering at 2020-06-05T19:56:24+01:00
Add new profiling mode -hi profile by info table
- - - - -
b27ea3e7 by Matthew Pickering at 2020-06-06T14:35:29+01:00
working
- - - - -
28 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/Pipeline.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/Bind.hs
- compiler/GHC/StgToCmm/Env.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/Flags.h
- includes/rts/prof/CCS.h
- libraries/base/GHC/RTS/Flags.hsc
- rts/ProfHeap.c
- rts/Profiling.c
- rts/RtsFlags.c
- rts/Trace.c
- rts/Trace.h
- rts/eventlog/EventLog.c
- rts/eventlog/EventLog.h
- utils/check-api-annotations/check-api-annotations.cabal
- utils/check-ppr/check-ppr.cabal
- utils/ghc-pkg/ghc-pkg.cabal
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -669,11 +669,12 @@ mkBitmapLabel uniq = LargeBitmapLabel uniq
data InfoTableEnt = InfoTableEnt { infoTablePtr :: CLabel
+ , infoTableEntClosureType :: Int
, infoTableProv :: (Module, RealSrcSpan, String) }
deriving (Eq, Ord)
instance Outputable InfoTableEnt where
- ppr (InfoTableEnt l p) = ppr l <> colon <> ppr p
+ ppr (InfoTableEnt l ct p) = ppr l <> colon <> ppr ct <> colon <> ppr p
-- Constructing Cost Center Labels
mkCCLabel :: CostCentre -> CLabel
@@ -1092,7 +1093,7 @@ labelDynamic config this_mod lbl =
-- CCS_Label always contains a CostCentre defined in the current module
CCS_Label _ -> False
- IPE_Label {} -> False
+ IPE_Label {} -> True
HpcTicksLabel m ->
externalDynamicRefs && this_mod /= m
@@ -1316,7 +1317,7 @@ pprCLbl dflags = \case
(CC_Label cc) -> ppr cc
(CCS_Label ccs) -> ppr ccs
- (IPE_Label (InfoTableEnt l _)) -> ppr l <> text "_ipe"
+ (IPE_Label (InfoTableEnt l _ (m, _, _))) -> pprCode CStyle (ppr l) <> text "_" <> ppr m <> text "_ipe"
(HpcTicksLabel mod) -> text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc")
(AsmTempLabel {}) -> panic "pprCLbl AsmTempLabel"
=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -21,6 +21,7 @@ import GHC.Cmm.ContFlowOpt
import GHC.Cmm.LayoutStack
import GHC.Cmm.Sink
import GHC.Cmm.Dataflow.Collections
+import GHC.Types.Name.Set
import GHC.Types.Unique.Supply
import GHC.Driver.Session
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -689,8 +689,12 @@ coreToStgRhs :: (Id,CoreExpr)
coreToStgRhs (bndr, rhs) = do
new_rhs <- coreToStgExpr rhs
- recordStgIdPosition bndr (quickSourcePos rhs)
- return (mkStgRhs bndr new_rhs)
+ let new_stg_rhs = (mkStgRhs bndr new_rhs)
+ case new_stg_rhs of
+ StgRhsClosure {} -> recordStgIdPosition bndr (((, occNameString (getOccName bndr))) <$> (srcSpanToRealSrcSpan (nameSrcSpan (getName bndr))))
+ _ -> return ()
+ return new_stg_rhs
+
quickSourcePos (Tick (SourceNote ss m) _) = Just (ss, m)
quickSourcePos _ = Nothing
@@ -936,7 +940,7 @@ recordStgIdPosition id ss = CtsM $ \_ _ -> do
--pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr ss)
case firstJust ss cc of
Nothing -> return ()
- Just r -> modify (\env -> env { provClosure = addToUniqMap (provClosure env) id r})
+ Just r -> modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) r})
withSpan :: (RealSrcSpan, String) -> CtsM a -> CtsM a
withSpan s (CtsM act) = CtsM (\a b -> local (const $ Just s) (act a b))
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -27,7 +27,7 @@ import GHC.Types.Unique.Supply ( mkSplitUniqSupply )
import GHC.Driver.Finder ( mkStubPaths )
import GHC.CmmToC ( writeC )
import GHC.Cmm.Lint ( cmmLint )
-import GHC.Cmm ( RawCmmGroup )
+import GHC.Cmm ( RawCmmGroup , CmmInfoTable )
import GHC.Cmm.CLabel
import GHC.Driver.Types
import GHC.Driver.Session
@@ -42,11 +42,13 @@ import GHC.Utils.Outputable
import GHC.Unit
import GHC.Types.SrcLoc
import GHC.Types.CostCentre
+import GHC.Types.Name.Set
import Control.Exception
import System.Directory
import System.FilePath
import System.IO
+import Data.IORef
{-
************************************************************************
@@ -60,17 +62,17 @@ codeOutput :: DynFlags
-> Module
-> FilePath
-> ModLocation
- -> ForeignStubs
-> [(ForeignSrcLang, FilePath)]
-- ^ additional files to be compiled with with the C compiler
-> [UnitId]
+ -> IO ForeignStubs
-> Stream IO RawCmmGroup a -- Compiled C--
-> IO (FilePath,
(Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
[(ForeignSrcLang, FilePath)]{-foreign_fps-},
a)
-codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
+codeOutput dflags this_mod filenm location foreign_fps pkg_deps genForeignStubs
cmm_stream
=
do {
@@ -97,7 +99,6 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
; return cmm
}
- ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
; a <- case hscTarget dflags of
HscAsm -> outputAsm dflags this_mod location filenm
linted_cmm_stream
@@ -105,6 +106,8 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
HscLlvm -> outputLlvm dflags filenm linted_cmm_stream
HscInterpreted -> panic "codeOutput: HscInterpreted"
HscNothing -> panic "codeOutput: HscNothing"
+ ; stubs <- genForeignStubs
+ ; stubs_exist <- outputForeignStubs dflags this_mod location stubs
; return (filenm, stubs_exist, foreign_fps, a)
}
@@ -321,11 +324,11 @@ profilingInitCode dflags this_mod (local_CCs, singleton_CCSs)
-- | Generate code to initialise info pointer origin
-ipInitCode :: DynFlags -> Module -> InfoTableProvMap -> SDoc
-ipInitCode dflags this_mod (InfoTableProvMap dcmap closure_map)
- = pprTraceIt "codeOutput" $ if not (gopt Opt_SccProfilingOn dflags)
- then empty
- else vcat
+ipInitCode :: [CmmInfoTable] -> DynFlags -> Module -> InfoTableProvMap -> SDoc
+ipInitCode used_info dflags this_mod (InfoTableProvMap dcmap closure_map)
+ = if not (gopt Opt_SccProfilingOn dflags)
+ then empty
+ else withPprStyle (mkCodeStyle CStyle) $ pprTraceIt "ipInitCode" $ vcat
$ map emit_ipe_decl ents
++ [emit_ipe_list ents]
++ [ text "static void ip_init_" <> ppr this_mod
@@ -337,7 +340,7 @@ ipInitCode dflags this_mod (InfoTableProvMap dcmap closure_map)
]
where
dc_ents = convertDCMap this_mod dcmap
- closure_ents = convertClosureMap this_mod closure_map
+ closure_ents = convertClosureMap used_info this_mod closure_map
ents = closure_ents ++ dc_ents
emit_ipe_decl ipe =
text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"
=====================================
compiler/GHC/Driver/Hooks.hs
=====================================
@@ -57,6 +57,9 @@ import GHC.Cmm
import GHC.Hs.Extension
import GHC.Types.Unique.Map
import GHC.Core.DataCon
+import GHC.Types.Name.Set
+import Data.IORef
+import GHC.Cmm.CLabel
import Data.Maybe
@@ -112,7 +115,7 @@ data Hooks = Hooks
, createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)
, stgToCmmHook :: Maybe (DynFlags -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs
- -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ())
+ -> [CgStgTopBinding] -> HpcInfo -> IORef [CmmInfoTable] -> Stream IO CmmGroup ())
, cmmToRawCmmHook :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a))
}
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -151,6 +151,7 @@ import GHC.Runtime.Loader ( initializePlugins )
import GHC.Driver.Session
import GHC.Utils.Error
+import Data.IORef
import GHC.Utils.Outputable
import GHC.Types.Name.Env
@@ -1419,11 +1420,9 @@ 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
- ip_init = ipInitCode dflags this_mod denv
- foreign_stubs = foreign_stubs0 `appendStubC` prof_init `appendStubC` ip_init
------------------ Code generation ------------------
-
+ lref <- newIORef []
-- The back-end is streamed: each top-level function goes
-- from Stg all the way to asm before dealing with the next
-- top-level function, so showPass isn't very useful here.
@@ -1435,7 +1434,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
cmms <- {-# SCC "StgToCmm" #-}
doCodeGen hsc_env this_mod denv data_tycons
cost_centre_info
- stg_binds hpc_info
+ stg_binds hpc_info lref
------------------ Code output -----------------------
rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
@@ -1448,10 +1447,16 @@ hscGenHardCode hsc_env cgguts location output_filename = do
return a
rawcmms1 = Stream.mapM dump rawcmms0
+ let foreign_stubs = do
+ used_info <- readIORef lref
+ pprTraceM "used_info" (ppr (length used_info))
+ let ip_init = ipInitCode used_info dflags this_mod denv
+ return $ foreign_stubs0 `appendStubC` prof_init `appendStubC` ip_init
+
(output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, caf_infos)
<- {-# SCC "codeOutput" #-}
codeOutput dflags this_mod output_filename location
- foreign_stubs foreign_files dependencies rawcmms1
+ foreign_files dependencies foreign_stubs rawcmms1
return (output_filename, stub_c_exists, foreign_fps, caf_infos)
@@ -1513,7 +1518,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
FormatCMM (ppr cmmgroup)
rawCmms <- lookupHook cmmToRawCmmHook
(\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup)
- _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []
+ _ <- codeOutput dflags cmm_mod output_filename no_loc [] [] (return NoStubs)
rawCmms
return ()
where
@@ -1546,23 +1551,23 @@ doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
+ -> IORef [CmmInfoTable]
-> IO (Stream IO CmmGroupSRTs NameSet)
-- Note we produce a 'Stream' of CmmGroups, so that the
-- backend can be run incrementally. Otherwise it generates all
-- the C-- up front, which has a significant space cost.
doCodeGen hsc_env this_mod denv data_tycons
- cost_centre_info stg_binds hpc_info = do
+ cost_centre_info stg_binds hpc_info lref = do
let dflags = hsc_dflags hsc_env
let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings stg_binds_w_fvs)
-
let cmm_stream :: Stream IO CmmGroup ()
-- See Note [Forcing of stg_binds]
cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod denv data_tycons
- cost_centre_info stg_binds_w_fvs hpc_info
+ cost_centre_info stg_binds_w_fvs hpc_info lref
-- codegen consumes a stream of CmmGroup, and produces a new
-- stream of CmmGroup (not necessarily synchronised: one
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Types.Basic
import GHC.Types.Var.Set ( isEmptyDVarSet )
import GHC.SysTools.FileCleanup
import GHC.Types.Unique.FM
+import GHC.Types.Name.Set
import GHC.Data.OrdList
import GHC.Cmm.Graph
@@ -69,11 +70,12 @@ codeGen :: DynFlags
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [CgStgTopBinding] -- Bindings to convert
-> HpcInfo
+ -> IORef [CmmInfoTable]
-> Stream IO CmmGroup () -- Output as a stream, so codegen can
-- be interleaved with output
-codeGen dflags this_mod (InfoTableProvMap (dcmap@(UniqMap denv)) clmap) data_tycons
- cost_centre_info stg_binds hpc_info
+codeGen dflags this_mod ip_map@(InfoTableProvMap (dcmap@(UniqMap denv)) _) data_tycons
+ cost_centre_info stg_binds hpc_info lref
= do { -- cg: run the code generator, and yield the resulting CmmGroup
-- Using an IORef to store the state is a bit crude, but otherwise
-- we would need to add a state monad layer.
@@ -88,19 +90,19 @@ codeGen dflags this_mod (InfoTableProvMap (dcmap@(UniqMap denv)) clmap) data_tyc
-- a big space leak. DO NOT REMOVE!
writeIORef cgref $! st'{ cgs_tops = nilOL,
cgs_stmts = mkNop }
- return a
+ return a --cgs_used_info st')
yield cmm
-- Note [codegen-split-init] the cmm_init block must come
-- 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
- (((convertDCMap this_mod dcmap))
- ++ (convertClosureMap this_mod clmap)))
+ ; cg (mkModuleInit cost_centre_info this_mod hpc_info [])
; mapM_ (cg . cgTopBinding dflags) stg_binds
-
+ ; cgs <- liftIO (readIORef cgref)
+ ; liftIO $ writeIORef lref (cgs_used_info cgs)
+ ; cg (initInfoTableProv ip_map this_mod)
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
-- (say) PrelBase_True_closure, which is defined in
@@ -170,6 +172,7 @@ cgTopBinding dflags (StgTopStringLit id str) = do
cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
-- The Id is passed along for setting up a binding...
+--cgTopRhs _ _ bndr _ | pprTrace "cgTopRhs" (ppr bndr) False = undefined
cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn args)
= cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args)
-- con args are always non-void,
@@ -194,7 +197,7 @@ mkModuleInit
mkModuleInit cost_centre_info this_mod hpc_info info_ents
= do { initHpc this_mod hpc_info
; initCostCentres cost_centre_info
- ; initInfoTableProv info_ents
+ -- ; initInfoTableProv info_ents
}
=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -89,11 +89,11 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body =
-- hole detection from working in that case. Test
-- concurrent/should_run/4030 fails, for instance.
--
- gen_code _ _ closure_label
- | StgApp f [] <- body, null args, isNonRec rec
- = do
- cg_info <- getCgIdInfo f
- emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]
+ --gen_code _ _ closure_label
+ -- | StgApp f [] <- body, null args, isNonRec rec
+ -- = do
+ -- cg_info <- getCgIdInfo f
+ -- emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]
gen_code dflags lf_info _closure_label
= do { let name = idName id
@@ -124,14 +124,16 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body =
cgBind :: CgStgBinding -> FCode ()
cgBind (StgNonRec name rhs)
- = do { (info, fcode) <- cgRhs name rhs
+ = do { --pprTraceM "cgBind" (ppr name)
+ ; (info, fcode) <- cgRhs name rhs
; addBindC info
; init <- fcode
; emit init }
-- init cannot be used in body, so slightly better to sink it eagerly
cgBind (StgRec pairs)
- = do { r <- sequence $ unzipWith cgRhs pairs
+ = do { --pprTraceM "cgBindRec" (ppr $ map fst pairs)
+ ; r <- sequence $ unzipWith cgRhs pairs
; let (id_infos, fcodes) = unzip r
; addBindsC id_infos
; (inits, body) <- getCodeR $ sequence fcodes
@@ -314,7 +316,7 @@ mkRhsClosure dflags bndr _cc
, idArity fun_id == unknownArity -- don't spoil a known call
-- Ha! an Ap thunk
- = cgRhsStdThunk bndr lf_info payload
+ = pprTrace "AP" (ppr bndr) cgRhsStdThunk bndr lf_info payload
where
n_fvs = length fvs
@@ -340,7 +342,7 @@ mkRhsClosure dflags bndr cc fvs upd_flag args body
-- stored in the closure itself, so it will make sure that
-- Node points to it...
; let reduced_fvs = filter (NonVoid bndr /=) fvs
-
+ ; -- pprTraceM "DEF" (ppr bndr)
-- MAKE CLOSURE INFO FOR THIS CLOSURE
; mod_name <- getModuleName
; let name = idName bndr
=====================================
compiler/GHC/StgToCmm/Env.hs
=====================================
@@ -112,6 +112,7 @@ maybeLetNoEscape _other = Nothing
addBindC :: CgIdInfo -> FCode ()
addBindC stuff_to_bind = do
binds <- getBinds
+ --pprTraceM "ADDING BIND" (ppr (cg_id stuff_to_bind) $$ ppr stuff_to_bind)
setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
addBindsC :: [CgIdInfo] -> FCode ()
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -87,7 +87,8 @@ cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
cgExpr (StgLet _ binds expr) = do { cgBind binds; cgExpr expr }
cgExpr (StgLetNoEscape _ binds expr) =
- do { u <- newUnique
+ do { -- pprTraceM "JOIN" (ppr binds)
+ ; u <- newUnique
; let join_id = mkBlockId u
; cgLneBinds join_id binds
; r <- cgExpr expr
=====================================
compiler/GHC/StgToCmm/Monad.hs
=====================================
@@ -55,6 +55,7 @@ module GHC.StgToCmm.Monad (
CgIdInfo(..),
getBinds, setBinds,
withEnclosingSpan, getEnclosingSpan,
+ getUsedInfo, addUsedInfo,
-- out of general friendliness, we also export ...
CgInfoDownwards(..), CgState(..) -- non-abstract
) where
@@ -81,6 +82,8 @@ import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Types.SrcLoc
+import GHC.Types.Name.Set
+import GHC.Types.Unique.FM
import Control.Monad
import Data.List
@@ -310,7 +313,10 @@ data CgState
cgs_hp_usg :: HeapUsage,
- cgs_uniqs :: UniqSupply }
+ cgs_uniqs :: UniqSupply,
+ -- | These are IDs which have an info table
+ cgs_used_info :: [CmmInfoTable]
+ }
data HeapUsage -- See Note [Virtual and real heap pointers]
= HeapUsage {
@@ -360,7 +366,8 @@ initCgState uniqs
, cgs_tops = nilOL
, cgs_binds = emptyVarEnv
, cgs_hp_usg = initHpUsage
- , cgs_uniqs = uniqs }
+ , cgs_uniqs = uniqs
+ , cgs_used_info = [] }
stateIncUsage :: CgState -> CgState -> CgState
-- stateIncUsage@ e1 e2 incorporates in e1
@@ -374,8 +381,12 @@ addCodeBlocksFrom :: CgState -> CgState -> CgState
-- (The cgs_stmts will often be empty, but not always; see codeOnly)
s1 `addCodeBlocksFrom` s2
= s1 { cgs_stmts = cgs_stmts s1 CmmGraph.<*> cgs_stmts s2,
- cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
+ cgs_tops = cgs_tops s1 `appOL` cgs_tops s2,
+ cgs_used_info = (cgs_used_info s1) ++ (cgs_used_info s2)
+ }
+addUsedInfo :: CmmInfoTable -> CgState -> CgState
+addUsedInfo cl cg = cg { cgs_used_info = cl : cgs_used_info cg }
-- The heap high water mark is the larger of virtHp and hwHp. The latter is
-- only records the high water marks of forked-off branches, so to find the
@@ -428,6 +439,9 @@ setRealHp new_realHp
= do { hp_usage <- getHpUsage
; setHpUsage (hp_usage {realHp = new_realHp}) }
+getUsedInfo :: FCode [CmmInfoTable]
+getUsedInfo = cgs_used_info <$> getState
+
getBinds :: FCode CgBindings
getBinds = do
state <- getState
@@ -790,7 +804,8 @@ emitProc mb_info lbl live blocks offset do_layout
proc_block = CmmProc tinfo lbl live blks
; state <- getState
- ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+ ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block
+ , cgs_used_info = maybe (cgs_used_info state) (: cgs_used_info state) mb_info } }
getCmm :: FCode () -> FCode CmmGroup
-- Get all the CmmTops (there should be no stmts)
=====================================
compiler/GHC/StgToCmm/Prof.hs
=====================================
@@ -44,6 +44,11 @@ import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Unit.Module as Module
import GHC.Utils.Outputable
+import GHC.Types.Var.Env
+import GHC.Types.Unique.FM
+import GHC.Types.Unique.Set
+import Control.Monad.IO.Class
+import Data.IORef
import Control.Monad
import Data.Char (ord)
@@ -274,12 +279,20 @@ sizeof_ccs_words dflags
(ws,ms) = sIZEOF_CostCentreStack dflags `divMod` platformWordSizeInBytes platform
-initInfoTableProv :: [InfoTableEnt] -> FCode ()
+initInfoTableProv :: InfoTableProvMap -> Module -> FCode ()
-- Emit the declarations
-initInfoTableProv ents
+initInfoTableProv (InfoTableProvMap dcmap clmap) this_mod
= do dflags <- getDynFlags
--- pprTraceM "initInfoTable" (ppr (length ents))
--- pprTraceM "initInfoTable" (vcat (map ppr ents))
+ binds <- getBinds
+ infos <- getUsedInfo
+
+ let ents = (((convertDCMap this_mod dcmap))
+ ++ (convertClosureMap infos this_mod clmap))
+ pprTraceM "binds" (ppr (sizeUFM binds))
+
+ pprTraceM "UsedInfo" (ppr (length infos))
+
+ pprTraceM "initInfoTable" (ppr (length ents))
mapM_ emitInfoTableProv ents
--- Info Table Prov stuff
@@ -296,8 +309,15 @@ emitInfoTableProv ip = do
; loc <- newByteStringCLit $ bytesFS $ mkFastString $
showPpr dflags src
-- XXX going via FastString to get UTF-8 encoding is silly
+ ; table_name <- newByteStringCLit $ bytesFS $ mkFastString $
+ showPpr dflags (infoTablePtr ip)
+
+ ; closure_type <- newByteStringCLit $ bytesFS $ mkFastString $
+ showPpr dflags (text $ show $ infoTableEntClosureType ip)
; let
lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer
+ table_name, -- char *table_name
+ closure_type, -- char *closure_desc -- Filled in from the InfoTable
label, -- char *label,
modl, -- char *module,
loc, -- char *srcloc,
=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -92,6 +92,7 @@ import GHC.Types.Unique.FM
import Data.Maybe
import GHC.Core.DataCon
import GHC.Types.Id
+import GHC.Types.Name.Set
-------------------------------------------------------------------------
@@ -633,9 +634,14 @@ emitUpdRemSetPushThunk ptr = do
False
-convertClosureMap :: Module -> ClosureMap -> [InfoTableEnt]
-convertClosureMap this_mod (UniqMap denv) =
- map (\(bndr, (ss, l)) -> InfoTableEnt (mkClosureLabel (idName bndr) (idCafInfo bndr)) (this_mod, ss, l)) (nonDetEltsUFM denv)
+convertClosureMap :: [CmmInfoTable] -> Module -> ClosureMap -> [InfoTableEnt]
+convertClosureMap defns this_mod denv =
+ mapMaybe (\cmit -> do
+ let cl = cit_lbl cmit
+ cn = rtsClosureType (cit_rep cmit)
+ n <- hasHaskellName cl
+ (ss, l) <- lookupUniqMap denv n
+ return (InfoTableEnt cl cn (this_mod, ss, l))) defns
convertDCMap :: Module -> DCMap -> [InfoTableEnt]
convertDCMap this_mod (UniqMap denv) =
@@ -644,4 +650,4 @@ convertDCMap this_mod (UniqMap denv) =
Nothing -> Nothing
Just (ss, l) -> Just $
InfoTableEnt (mkConInfoTableLabel (dataConName dc) (Just (this_mod, k)))
- (this_mod, ss, l)) ns) (nonDetEltsUFM denv)
+ 0 (this_mod, ss, l)) ns) (nonDetEltsUFM denv)
=====================================
compiler/GHC/Types/CostCentre.hs
=====================================
@@ -189,7 +189,7 @@ data CostCentreStack
type DCMap = UniqMap DataCon [(Int, Maybe (RealSrcSpan, String))]
-type ClosureMap = UniqMap Id (RealSrcSpan, String)
+type ClosureMap = UniqMap Name (RealSrcSpan, String)
data InfoTableProvMap = InfoTableProvMap
{ provDC :: DCMap
=====================================
includes/rts/EventLogFormat.h
=====================================
@@ -218,7 +218,8 @@ typedef enum {
HEAP_PROF_BREAKDOWN_TYPE_DESCR,
HEAP_PROF_BREAKDOWN_RETAINER,
HEAP_PROF_BREAKDOWN_BIOGRAPHY,
- HEAP_PROF_BREAKDOWN_CLOSURE_TYPE
+ HEAP_PROF_BREAKDOWN_CLOSURE_TYPE,
+ HEAP_PROF_BREAKDOWN_INFO_TABLE
} HeapProfBreakdown;
#if !defined(EVENTLOG_CONSTANTS_ONLY)
=====================================
includes/rts/Flags.h
=====================================
@@ -141,6 +141,7 @@ typedef struct _PROFILING_FLAGS {
# define HEAP_BY_LDV 7
# define HEAP_BY_CLOSURE_TYPE 8
+# define HEAP_BY_INFO_TABLE 9
Time heapProfileInterval; /* time between samples */
uint32_t heapProfileIntervalTicks; /* ticks between samples (derived) */
=====================================
includes/rts/prof/CCS.h
=====================================
@@ -74,6 +74,8 @@ typedef struct CostCentreStack_ {
typedef struct InfoProv_{
+ char * table_name;
+ char * closure_desc;
char * label;
char * module;
char * srcloc;
=====================================
libraries/base/GHC/RTS/Flags.hsc
=====================================
@@ -219,6 +219,7 @@ data DoHeapProfile
| HeapByRetainer
| HeapByLDV
| HeapByClosureType
+ | HeapByInfoTable
deriving ( Show -- ^ @since 4.8.0.0
)
@@ -232,6 +233,7 @@ instance Enum DoHeapProfile where
fromEnum HeapByRetainer = #{const HEAP_BY_RETAINER}
fromEnum HeapByLDV = #{const HEAP_BY_LDV}
fromEnum HeapByClosureType = #{const HEAP_BY_CLOSURE_TYPE}
+ fromEnum HeapByInfoTable = #{const HEAP_BY_INFO_TABLE}
toEnum #{const NO_HEAP_PROFILING} = NoHeapProfiling
toEnum #{const HEAP_BY_CCS} = HeapByCCS
@@ -241,6 +243,7 @@ instance Enum DoHeapProfile where
toEnum #{const HEAP_BY_RETAINER} = HeapByRetainer
toEnum #{const HEAP_BY_LDV} = HeapByLDV
toEnum #{const HEAP_BY_CLOSURE_TYPE} = HeapByClosureType
+ toEnum #{const HEAP_BY_INFO_TABLE} = HeapByInfoTable
toEnum e = errorWithoutStackTrace ("invalid enum for DoHeapProfile: " ++ show e)
-- | Parameters of the cost-center profiler
=====================================
rts/ProfHeap.c
=====================================
@@ -238,6 +238,10 @@ closureIdentity( const StgClosure *p )
return closure_type_names[info->type];
}
}
+ case HEAP_BY_INFO_TABLE: {
+ const StgInfoTable *info;
+ return get_itbl(p);
+ }
default:
barf("closureIdentity");
@@ -939,6 +943,14 @@ dumpCensus( Census *census )
traceHeapProfSampleString(0, (char *)ctr->identity,
count * sizeof(W_));
break;
+ case HEAP_BY_INFO_TABLE:
+ fprintf(hp_file, "%p", ctr->identity);
+ // TODO now all the types in this mode are just THUNK closures so
+ // don't really need to add any more info
+ char str[100];
+ sprintf(str, "%p", ctr->identity);
+ traceHeapProfSampleString(0, str, count * sizeof(W_));
+ break;
#if defined(PROFILING)
case HEAP_BY_CCS:
fprint_ccs(hp_file, (CostCentreStack *)ctr->identity,
=====================================
rts/Profiling.c
=====================================
@@ -154,7 +154,7 @@ dumpIPEToEventLog(void)
InfoProvEnt *ip, *next;
for (ip = IPE_LIST; ip != NULL; ip = next) {
next = ip->link;
- traceIPE(ip->info, ip->prov.label,
+ traceIPE(ip->info, ip->prov.table_name, ip->prov.closure_desc, ip->prov.label,
ip->prov.module, ip->prov.srcloc);
}
#endif
@@ -358,6 +358,7 @@ static void
registerInfoProvEnt(InfoProvEnt *ipe)
{
//if (ipe->link == NULL) {
+ //
ipe->link = IPE_LIST;
IPE_LIST = ipe;
//}
=====================================
rts/RtsFlags.c
=====================================
@@ -1316,6 +1316,10 @@ error = true;
OPTION_UNSAFE;
RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_CLOSURE_TYPE;
break;
+ case 'i':
+ OPTION_UNSAFE;
+ RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_INFO_TABLE;
+ break;
default:
OPTION_SAFE;
PROFILING_BUILD_ONLY();
@@ -2057,6 +2061,7 @@ static bool read_heap_profiling_flag(const char *arg)
case 'd':
case 'Y':
case 'y':
+ case 'i':
case 'R':
case 'r':
case 'B':
@@ -2137,6 +2142,9 @@ static bool read_heap_profiling_flag(const char *arg)
case 'y':
RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_TYPE;
break;
+ case 'i':
+ RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_INFO_TABLE;
+ break;
case 'R':
case 'r':
RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_RETAINER;
=====================================
rts/Trace.c
=====================================
@@ -644,12 +644,14 @@ void traceHeapProfCostCentre(StgWord32 ccID,
}
void traceIPE(StgInfoTable * info,
+ const char *table_name,
+ const char *closure_desc,
const char *label,
const char *module,
const char *srcloc )
{
if (eventlog_enabled) {
- postIPE(info, label, module, srcloc);
+ postIPE(info, table_name, closure_desc, label, module, srcloc);
}
}
=====================================
rts/Trace.h
=====================================
@@ -303,6 +303,8 @@ void traceHeapProfCostCentre(StgWord32 ccID,
const char *srcloc,
StgBool is_caf);
void traceIPE(StgInfoTable *info,
+ const char *table_name,
+ const char *closure_desc,
const char *label,
const char *module,
const char *srcloc );
@@ -358,7 +360,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 traceIPE(info, table_name, closure_desc, label, module, srcloc) /* nothing */
#define traceHeapProfSampleBegin(era) /* nothing */
#define traceHeapBioProfSampleBegin(era, time) /* nothing */
#define traceHeapProfSampleEnd(era) /* nothing */
=====================================
rts/eventlog/EventLog.c
=====================================
@@ -1301,6 +1301,8 @@ static HeapProfBreakdown getHeapProfBreakdown(void)
return HEAP_PROF_BREAKDOWN_BIOGRAPHY;
case HEAP_BY_CLOSURE_TYPE:
return HEAP_PROF_BREAKDOWN_CLOSURE_TYPE;
+ case HEAP_BY_INFO_TABLE:
+ return HEAP_PROF_BREAKDOWN_INFO_TABLE;
default:
barf("getHeapProfBreakdown: unknown heap profiling mode");
}
@@ -1412,19 +1414,25 @@ void postHeapProfCostCentre(StgWord32 ccID,
RELEASE_LOCK(&eventBufMutex);
}
void postIPE(StgWord64 info,
+ const char *table_name,
+ const char *closure_desc,
const char *label,
const char *module,
const char *srcloc)
{
ACQUIRE_LOCK(&eventBufMutex);
+ StgWord table_name_len = strlen(table_name);
+ StgWord closure_desc_len = strlen(closure_desc);
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;
+ StgWord len = 8+table_name_len+closure_desc_len+label_len+module_len+srcloc_len+3;
ensureRoomForVariableEvent(&eventBuf, len);
postEventHeader(&eventBuf, EVENT_IPE);
postPayloadSize(&eventBuf, len);
postWord64(&eventBuf, info);
+ postString(&eventBuf, table_name);
+ postString(&eventBuf, closure_desc);
postString(&eventBuf, label);
postString(&eventBuf, module);
postString(&eventBuf, srcloc);
=====================================
rts/eventlog/EventLog.h
=====================================
@@ -158,6 +158,8 @@ void postHeapProfCostCentre(StgWord32 ccID,
const char *srcloc,
StgBool is_caf);
void postIPE(StgWord64 info,
+ const char *table_name,
+ const char *closure_desc,
const char *label,
const char *module,
const char *srcloc);
=====================================
utils/check-api-annotations/check-api-annotations.cabal
=====================================
@@ -20,7 +20,7 @@ Executable check-api-annotations
Main-Is: Main.hs
- Ghc-Options: -Wall
+ Ghc-Options: -Wall -g3 -ddump-cmm -ddump-stg -fforce-recomp
Build-Depends: base >= 4 && < 5,
containers,
=====================================
utils/check-ppr/check-ppr.cabal
=====================================
@@ -20,7 +20,7 @@ Executable check-ppr
Main-Is: Main.hs
- Ghc-Options: -Wall
+ Ghc-Options: -Wall -g3
Build-Depends: base >= 4 && < 5,
bytestring,
=====================================
utils/ghc-pkg/ghc-pkg.cabal
=====================================
@@ -23,6 +23,7 @@ Flag terminfo
Executable ghc-pkg
Default-Language: Haskell2010
Main-Is: Main.hs
+ ghc-options: -g3
Other-Extensions: CPP
Build-Depends: base >= 4 && < 5,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a88925f4510497ac395a856d0473cc621a6f02f...b27ea3e7f630331db271d2c6664a210fde0c56c8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a88925f4510497ac395a856d0473cc621a6f02f...b27ea3e7f630331db271d2c6664a210fde0c56c8
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/20200606/ab3520b1/attachment-0001.html>
More information about the ghc-commits
mailing list