diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Cmm/CLabel.hs | 56 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/Parser.y | 15 | ||||
| -rw-r--r-- | compiler/GHC/CoreToStg.hs | 17 | ||||
| -rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 125 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Flags.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Hooks.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 66 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Coverage.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Debug.hs | 140 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm.hs | 49 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Closure.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Monad.hs | 13 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Prof.hs | 53 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Types.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Utils.hs | 36 | ||||
| -rw-r--r-- | compiler/GHC/Types/IPE.hs | 24 | ||||
| -rw-r--r-- | compiler/GHC/Types/SrcLoc.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Types/Unique/Map.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Unit/Module/Name.hs | 2 |
21 files changed, 554 insertions, 73 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index 4b30bc8cf1..1afb97dcd8 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -83,6 +83,9 @@ module GHC.Cmm.CLabel ( mkForeignLabel, mkCCLabel, mkCCSLabel, + mkIPELabel, + InfoProvEnt(..), + mkDynamicLinkerLabel, mkPicBaseLabel, mkDeadStripPreventer, @@ -148,6 +151,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 @@ -251,6 +255,7 @@ data CLabel | CC_Label CostCentre | CCS_Label CostCentreStack + | IPE_Label InfoProvEnt -- | These labels are generated and used inside the NCG only. @@ -342,6 +347,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 @@ -384,6 +391,8 @@ instance Ord CLabel where compare _ HpcTicksLabel{} = GT compare SRTLabel{} _ = LT compare _ SRTLabel{} = GT + compare (IPE_Label {}) _ = LT + compare _ (IPE_Label{}) = GT -- | Record where a foreign label is stored. data ForeignLabelSource @@ -416,7 +425,7 @@ pprDebugCLabel platform lbl = pprCLabel platform AsmStyle lbl <> parens extra where extra = case lbl of IdLabel _ _ info - -> text "IdLabel" <> whenPprDebug (text ":" <> text (show info)) + -> text "IdLabel" <> whenPprDebug (text ":" <> ppr info) CmmLabel pkg _ext _name _info -> text "CmmLabel" <+> ppr pkg @@ -452,7 +461,25 @@ data IdLabelInfo -- instead of a closure entry-point. -- See Note [Proc-point local block entry-point]. - deriving (Eq, Ord, Show) + deriving (Eq, Ord) + +instance Outputable IdLabelInfo where + ppr Closure = text "Closure" + ppr InfoTable = text "InfoTable" + ppr Entry = text "Entry" + ppr Slow = text "Slow" + + ppr LocalInfoTable = text "LocalInfoTable" + 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 ClosureTable = text "ClosureTable" + ppr Bytes = text "Bytes" + ppr BlockInfoTable = text "BlockInfoTable" data RtsLabelInfo @@ -710,11 +737,28 @@ foreignLabelStdcallInfo _lbl = Nothing mkBitmapLabel :: Unique -> CLabel mkBitmapLabel uniq = LargeBitmapLabel uniq +-- | Info Table Provenance Entry +-- See Note [Mapping Info Tables to Source Positions] +data InfoProvEnt = InfoProvEnt + { infoTablePtr :: !CLabel + -- Address of the info table + , infoProvEntClosureType :: !Int + -- The closure type of the info table (from ClosureMacros.h) + , infoTableType :: !String + -- The rendered Haskell type of the closure the table represents + , infoProvModule :: !Module + -- Origin module + , infoTableProv :: !(Maybe (RealSrcSpan, String)) } + -- Position and information about the info table + deriving (Eq, Ord) + -- Constructing Cost Center Labels mkCCLabel :: CostCentre -> CLabel mkCCSLabel :: CostCentreStack -> CLabel +mkIPELabel :: InfoProvEnt -> CLabel mkCCLabel cc = CC_Label cc mkCCSLabel ccs = CCS_Label ccs +mkIPELabel ipe = IPE_Label ipe mkRtsApFastLabel :: FastString -> CLabel mkRtsApFastLabel str = RtsLabel (RtsApFast (NonDetFastString str)) @@ -863,6 +907,7 @@ needsCDecl (CmmLabel pkgId (NeedExternDecl external) _ _) 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" @@ -985,6 +1030,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 @@ -1044,6 +1090,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 @@ -1057,7 +1104,7 @@ idInfoLabelType info = LocalInfoTable -> DataLabel BlockInfoTable -> DataLabel Closure -> GcPtrLabel - ConInfoTable -> DataLabel + ConInfoTable {} -> DataLabel ClosureTable -> DataLabel RednCounts -> DataLabel Bytes -> DataLabel @@ -1132,6 +1179,7 @@ labelDynamic config lbl = -- CCS_Label always contains a CostCentre defined in the current module CCS_Label _ -> False + IPE_Label {} -> True HpcTicksLabel m -> externalDynamicRefs && this_mod /= m @@ -1356,6 +1404,8 @@ pprCLabel platform sty lbl = CC_Label cc -> maybe_underscore $ ppr cc CCS_Label ccs -> maybe_underscore $ ppr ccs + IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCode CStyle (pdoc platform l) <> text "_" <> ppr m <> text "_ipe") + CmmLabel _ _ fs CmmCode -> maybe_underscore $ ftext fs CmmLabel _ _ fs CmmData -> maybe_underscore $ ftext fs diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index c04c9b82ca..92e981a841 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -221,6 +221,7 @@ import GHC.StgToCmm.Expr import GHC.StgToCmm.Closure import GHC.StgToCmm.Layout hiding (ArgRep(..)) import GHC.StgToCmm.Ticky +import GHC.StgToCmm.Prof import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame ) import GHC.Core ( Tickish(SourceNote) ) @@ -1448,8 +1449,9 @@ initEnv profile = listToUFM [ ] where platform = profilePlatform profile -parseCmmFile :: DynFlags -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe CmmGroup) -parseCmmFile dflags home_unit filename = do + +parseCmmFile :: DynFlags -> Module -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe (CmmGroup, [InfoProvEnt])) +parseCmmFile dflags this_mod home_unit filename = do buf <- hGetStringBuffer filename let init_loc = mkRealSrcLoc (mkFastString filename) 1 1 @@ -1463,8 +1465,13 @@ parseCmmFile dflags home_unit filename = do return (warnings, errors, Nothing) POk pst code -> do st <- initC - let fcode = getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return () - (cmm,_) = runC dflags no_module st fcode + let fcode = do + ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return () + let used_info = map (cmmInfoTableToInfoProvEnt this_mod) + (mapMaybe topInfoTable cmm) + ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info + return (cmm ++ cmm2, used_info) + (cmm, _) = runC dflags no_module st fcode (warnings,errors) = getMessages pst if not (isEmptyBag errors) then return (warnings, errors, Nothing) diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 5a53cc933f..2f9e3816ef 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -22,6 +22,7 @@ import GHC.Core.Utils ( exprType, findDefault, isJoinBind , exprIsTickedString_maybe ) import GHC.Core.Opt.Arity ( manifestArity ) import GHC.Stg.Syntax +import GHC.Stg.Debug import GHC.Core.Type import GHC.Types.RepType @@ -46,6 +47,7 @@ import GHC.Driver.Session import GHC.Platform.Ways import GHC.Driver.Ppr import GHC.Types.ForeignCall +import GHC.Types.IPE import GHC.Types.Demand ( isUsedOnceDmd ) import GHC.Builtin.PrimOps ( PrimCall(..) ) import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) @@ -226,14 +228,21 @@ import qualified Data.Set as Set -- Setting variable info: top-level, binds, RHSs -- -------------------------------------------------------------- -coreToStg :: DynFlags -> Module -> CoreProgram - -> ([StgTopBinding], CollectedCCs) -coreToStg dflags this_mod pgm - = (pgm', final_ccs) + +coreToStg :: DynFlags -> Module -> ModLocation -> CoreProgram + -> ([StgTopBinding], InfoTableProvMap, CollectedCCs) +coreToStg dflags this_mod ml pgm + = (pgm'', denv, final_ccs) where (_, (local_ccs, local_cc_stacks), pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm + -- See Note [Mapping Info Tables to Source Positions] + (!pgm'', !denv) = + if gopt Opt_InfoTableMap dflags + then collectDebugInformation dflags ml pgm' + else (pgm', emptyInfoTableProvMap) + prof = WayProf `Set.member` ways dflags final_ccs diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 134ee2f960..f6b9e9738c 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -10,6 +10,7 @@ module GHC.Driver.CodeOutput ( codeOutput , outputForeignStubs , profilingInitCode + , ipInitCode ) where @@ -37,6 +38,7 @@ import qualified GHC.Data.Stream as Stream import GHC.SysTools.FileCleanup + import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic @@ -70,7 +72,7 @@ codeOutput :: Logger -> Module -> FilePath -> ModLocation - -> ForeignStubs + -> (a -> ForeignStubs) -> [(ForeignSrcLang, FilePath)] -- ^ additional files to be compiled with the C compiler -> [UnitId] @@ -80,7 +82,7 @@ codeOutput :: Logger [(ForeignSrcLang, FilePath)]{-foreign_fps-}, a) -codeOutput logger dflags unit_state this_mod filenm location foreign_stubs foreign_fps pkg_deps +codeOutput logger dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps cmm_stream = do { @@ -107,7 +109,6 @@ codeOutput logger dflags unit_state this_mod filenm location foreign_stubs forei ; return cmm } - ; stubs_exist <- outputForeignStubs logger dflags unit_state this_mod location foreign_stubs ; a <- case backend dflags of NCG -> outputAsm logger dflags this_mod location filenm linted_cmm_stream @@ -115,6 +116,8 @@ codeOutput logger dflags unit_state this_mod filenm location foreign_stubs forei LLVM -> outputLlvm logger dflags filenm linted_cmm_stream Interpreter -> panic "codeOutput: Interpreter" NoBackend -> panic "codeOutput: NoBackend" + ; let stubs = genForeignStubs a + ; stubs_exist <- outputForeignStubs logger dflags unit_state this_mod location stubs ; return (filenm, stubs_exist, foreign_fps, a) } @@ -225,9 +228,14 @@ outputForeignStubs logger dflags unit_state mod location stubs -- we need the #includes from the rts package for the stub files let rts_includes = - let rts_pkg = unsafeLookupUnitId unit_state rtsUnitId in - concatMap mk_include (unitIncludes rts_pkg) - mk_include i = "#include \"" ++ ST.unpack i ++ "\"\n" + let mrts_pkg = lookupUnitId unit_state rtsUnitId + mk_include i = "#include \"" ++ ST.unpack i ++ "\"\n" + in case mrts_pkg of + Just rts_pkg -> concatMap mk_include (unitIncludes rts_pkg) + -- This case only happens when compiling foreign stub for the rts + -- library itself. The only time we do this at the moment is for + -- IPE information for the RTS info tables + Nothing -> "" -- wrapper code mentions the ffi_arg type, which comes from ffi.h ffi_includes @@ -314,3 +322,108 @@ profilingInitCode platform this_mod (local_CCs, singleton_CCSs) | cc <- ccs ] ++ [text "NULL"]) <> semi + +-- | Generate code to initialise info pointer origin +-- See note [Mapping Info Tables to Source Positions] +ipInitCode :: DynFlags -> Module -> [InfoProvEnt] -> SDoc +ipInitCode dflags this_mod ents + = if not (gopt Opt_InfoTableMap dflags) + then empty + else withPprStyle (PprCode CStyle) $ 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 + platform = targetPlatform dflags + emit_ipe_decl ipe = + text "extern InfoProvEnt" <+> ipe_lbl <> text "[];" + where ipe_lbl = pprCLabel platform CStyle (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 $ [ pprCLabel platform CStyle (mkIPELabel ipe) <> comma + | ipe <- ipes + ] ++ [text "NULL"]) + <> 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 728b6159a6..955b6fabd1 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -132,6 +132,8 @@ data GeneralFlag | Opt_FastLlvm -- hidden flag | Opt_NoTypeableBinds + | Opt_InfoTableMap + | Opt_WarnIsError -- -Werror; makes warnings fatal | Opt_ShowWarnGroups -- Show the group a warning belongs to | Opt_HideSourcePaths -- Hide module source/object paths diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs index cb21072bd6..4cf62412b5 100644 --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -46,6 +46,7 @@ import GHC.Types.Id import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.CostCentre +import GHC.Types.IPE import GHC.Types.Meta import GHC.Types.HpcInfo @@ -70,6 +71,7 @@ import GHC.Data.Bag import qualified Data.Kind import System.Process +import GHC.Utils.Outputable ( SDoc ) {- ************************************************************************ @@ -143,8 +145,8 @@ data Hooks = Hooks , getValueSafelyHook :: !(Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))) , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) - , stgToCmmHook :: !(Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs - -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)) + , stgToCmmHook :: !(Maybe (DynFlags -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs + -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup (SDoc, ModuleLFInfos))) , cmmToRawCmmHook :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a))) } diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index f16685775b..fea51a7f96 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fprof-auto-top #-} ------------------------------------------------------------------------------- @@ -186,6 +188,7 @@ import GHC.Types.Var.Env ( emptyTidyEnv ) import GHC.Types.Error import GHC.Types.Fixity.Env import GHC.Types.CostCentre +import GHC.Types.IPE import GHC.Types.Unique.Supply import GHC.Types.SourceFile import GHC.Types.SrcLoc @@ -1536,19 +1539,18 @@ hscGenHardCode hsc_env cgguts location output_filename = do corePrepPgm hsc_env this_mod location core_binds data_tycons ----------------- Convert to STG ------------------ - (stg_binds, (caf_ccs, caf_cc_stacks)) + (stg_binds, denv, (caf_ccs, caf_cc_stacks)) <- {-# SCC "CoreToStg" #-} - myCoreToStg logger dflags this_mod prepd_binds + myCoreToStg logger dflags this_mod location prepd_binds - let cost_centre_info = (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) + let cost_centre_info = + (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) platform = targetPlatform dflags prof_init - | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info - | otherwise = empty - foreign_stubs = foreign_stubs0 `appendStubC` prof_init + | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info + | otherwise = empty ------------------ Code generation ------------------ - -- 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. @@ -1558,7 +1560,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do (text "CodeGen"<+>brackets (ppr this_mod)) (const ()) $ do cmms <- {-# SCC "StgToCmm" #-} - doCodeGen hsc_env this_mod data_tycons + doCodeGen hsc_env this_mod denv data_tycons cost_centre_info stg_binds hpc_info @@ -1574,6 +1576,8 @@ hscGenHardCode hsc_env cgguts location output_filename = do return a rawcmms1 = Stream.mapM dump rawcmms0 + let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init `appendStubC` (cgIPEStub st) + (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos) <- {-# SCC "codeOutput" #-} codeOutput logger dflags (hsc_units hsc_env) this_mod output_filename location @@ -1615,24 +1619,24 @@ hscInteractive hsc_env cgguts location = do ------------------------------ -hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () +hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath) hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let hooks = hsc_hooks hsc_env home_unit = hsc_home_unit hsc_env platform = targetPlatform dflags - cmm <- ioMsgMaybe + -- Make up a module name to give the NCG. We can't pass bottom here + -- lest we reproduce #11784. + mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename + cmm_mod = mkHomeModule home_unit mod_name + (cmm, ents) <- ioMsgMaybe $ do (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) - $ parseCmmFile dflags home_unit filename + $ parseCmmFile dflags cmm_mod home_unit filename return (mkMessages (fmap pprWarning warns `unionBags` fmap pprError errs), cmm) liftIO $ do dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) - let -- Make up a module name to give the NCG. We can't pass bottom here - -- lest we reproduce #11784. - mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename - cmm_mod = mkHomeModule home_unit mod_name -- Compile decls in Cmm files one decl at a time, to avoid re-ordering -- them in SRT analysis. @@ -1651,9 +1655,14 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do Nothing -> cmmToRawCmm logger dflags (Stream.yield cmmgroup) Just h -> h dflags Nothing (Stream.yield cmmgroup) - _ <- codeOutput logger dflags (hsc_units hsc_env) cmm_mod output_filename no_loc NoStubs [] [] + let foreign_stubs _ = + let ip_init = ipInitCode dflags cmm_mod ents + in NoStubs `appendStubC` ip_init + + (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) + <- codeOutput logger dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] [] rawCmms - return () + return stub_c_exists where no_loc = ModLocation{ ml_hs_file = Just filename, ml_hi_file = panic "hscCompileCmmFile: no hi file", @@ -1680,7 +1689,7 @@ This reduces residency towards the end of the CodeGen phase significantly (5-10%). -} -doCodeGen :: HscEnv -> Module -> [TyCon] +doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs -> [StgTopBinding] -> HpcInfo @@ -1688,7 +1697,7 @@ doCodeGen :: HscEnv -> Module -> [TyCon] -- 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 data_tycons +doCodeGen hsc_env this_mod denv data_tycons cost_centre_info stg_binds hpc_info = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env @@ -1703,10 +1712,10 @@ doCodeGen hsc_env this_mod data_tycons Nothing -> StgToCmm.codeGen logger Just h -> h - let cmm_stream :: Stream IO CmmGroup ModuleLFInfos + let cmm_stream :: Stream IO CmmGroup (SDoc, ModuleLFInfos) -- See Note [Forcing of stg_binds] cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-} - stg_to_cmm dflags this_mod data_tycons cost_centre_info stg_binds_w_fvs hpc_info + stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info -- codegen consumes a stream of CmmGroup, and produces a new -- stream of CmmGroup (not necessarily synchronised: one @@ -1723,12 +1732,12 @@ doCodeGen hsc_env this_mod data_tycons pipeline_stream :: Stream IO CmmGroupSRTs CgInfos pipeline_stream = do - (non_cafs, lf_infos) <- + (non_cafs, (used_info, lf_infos)) <- {-# SCC "cmmPipeline" #-} Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1 <&> first (srtMapNonCAFs . moduleSRTMap) - return CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos } + return CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos, cgIPEStub = used_info } dump2 a = do unless (null a) $ @@ -1737,19 +1746,20 @@ doCodeGen hsc_env this_mod data_tycons return (Stream.mapM dump2 pipeline_stream) -myCoreToStg :: Logger -> DynFlags -> Module -> CoreProgram +myCoreToStg :: Logger -> DynFlags -> Module -> ModLocation -> CoreProgram -> IO ( [StgTopBinding] -- output program + , InfoTableProvMap , CollectedCCs ) -- CAF cost centre info (declared and used) -myCoreToStg logger dflags this_mod prepd_binds = do - let (stg_binds, cost_centre_info) +myCoreToStg logger dflags this_mod ml prepd_binds = do + let (stg_binds, denv, cost_centre_info) = {-# SCC "Core2Stg" #-} - coreToStg dflags this_mod prepd_binds + coreToStg dflags this_mod ml prepd_binds stg_binds2 <- {-# SCC "Stg2Stg" #-} stg2stg logger dflags this_mod stg_binds - return (stg_binds2, cost_centre_info) + return (stg_binds2, denv, cost_centre_info) {- ********************************************************************** diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index df54f35e04..e0367d08d4 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -1394,7 +1394,9 @@ runPhase (RealPhase Cmm) input_fn = do let next_phase = hscPostBackendPhase HsSrcFile (backend dflags) output_fn <- phaseOutputFilename next_phase PipeState{hsc_env} <- getPipeState - liftIO $ hscCompileCmmFile hsc_env input_fn output_fn + mstub <- liftIO $ hscCompileCmmFile hsc_env input_fn output_fn + stub_o <- liftIO (mapM (compileStub hsc_env) mstub) + setForeignOs (maybeToList stub_o) return (RealPhase next_phase, output_fn) ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index f7424f5003..98c46427e6 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -2776,6 +2776,8 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "fprof-callers" (HasArg setCallerCcFilters) + , make_ord_flag defGhcFlag "finfo-table-map" + (NoArg (setGeneralFlag Opt_InfoTableMap)) ------ Compiler flags ----------------------------------------------- , make_ord_flag defGhcFlag "fasm" (NoArg (setObjBackend NCG)) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index df7d00071b..8180696700 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -1036,13 +1036,17 @@ data TickTransEnv = TTE { fileName :: FastString data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes deriving (Eq) +sourceNotesEnabled :: DynFlags -> Bool +sourceNotesEnabled dflags = + (debugLevel dflags > 0) || (gopt Opt_InfoTableMap dflags) + coveragePasses :: DynFlags -> [TickishType] coveragePasses dflags = ifa (breakpointsEnabled dflags) Breakpoints $ ifa (gopt Opt_Hpc dflags) HpcTicks $ ifa (sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto) ProfNotes $ - ifa (debugLevel dflags > 0) SourceNotes [] + ifa (sourceNotesEnabled dflags) SourceNotes [] where ifa f x xs | f = x:xs | otherwise = xs 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)}) + diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 3d1f962267..f89f465d12 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -19,7 +19,7 @@ import GHC.Prelude as Prelude import GHC.Driver.Backend import GHC.Driver.Session -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 @@ -39,6 +39,7 @@ import GHC.Cmm.Graph import GHC.Stg.Syntax import GHC.Types.CostCentre +import GHC.Types.IPE import GHC.Types.HpcInfo import GHC.Types.Id import GHC.Types.Id.Info @@ -64,41 +65,56 @@ import GHC.SysTools.FileCleanup import GHC.Data.Stream import GHC.Data.OrdList -import Data.IORef import Control.Monad (when,void) import GHC.Utils.Misc import System.IO.Unsafe import qualified Data.ByteString as BS +import Data.Maybe +import Data.IORef + +data CodeGenState = CodeGenState { codegen_used_info :: !(OrdList CmmInfoTable) + , codegen_state :: !CgState } + codeGen :: Logger -> DynFlags -> Module + -> InfoTableProvMap -> [TyCon] -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [CgStgTopBinding] -- Bindings to convert -> HpcInfo - -> Stream IO CmmGroup ModuleLFInfos - -- Output as a stream, so codegen can + -> Stream IO CmmGroup (SDoc, ModuleLFInfos) -- Output as a stream, so codegen can -- be interleaved with output -codeGen logger dflags this_mod data_tycons +codeGen logger dflags this_mod ip_map@(InfoTableProvMap _) 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 - -- we would need to add a state monad layer. - ; cgref <- liftIO $ newIORef =<< initC - ; let cg :: FCode () -> Stream IO CmmGroup () + -- we would need to add a state monad layer which regresses + -- allocations by 0.5-2%. + ; cgref <- liftIO $ initC >>= \s -> newIORef (CodeGenState mempty s) + ; let cg :: FCode a -> Stream IO CmmGroup a cg fcode = do - cmm <- liftIO . withTimingSilent logger dflags (text "STG -> Cmm") (`seq` ()) $ do - st <- readIORef cgref + (a, cmm) <- liftIO . withTimingSilent logger dflags (text "STG -> Cmm") (`seq` ()) $ do + CodeGenState ts st <- readIORef cgref let (a,st') = runC dflags this_mod st (getCmm fcode) -- NB. stub-out cgs_tops and cgs_stmts. This fixes -- a big space leak. DO NOT REMOVE! - writeIORef cgref $! st'{ cgs_tops = nilOL, - cgs_stmts = mkNop } + -- This is observed by the #3294 test + let !used_info + | gopt Opt_InfoTableMap dflags = toOL (mapMaybe topInfoTable (snd a)) `mappend` ts + | otherwise = mempty + writeIORef cgref $! + CodeGenState used_info + (st'{ cgs_tops = nilOL, + cgs_stmts = mkNop + }) + return a yield cmm + return a -- Note [codegen-split-init] the cmm_init block must come -- FIRST. This is because when -split-objs is on we need to @@ -107,7 +123,6 @@ codeGen logger dflags this_mod data_tycons ; cg (mkModuleInit cost_centre_info this_mod hpc_info) ; mapM_ (cg . cgTopBinding logger dflags) stg_binds - -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to -- (say) PrelBase_True_closure, which is defined in @@ -121,7 +136,11 @@ codeGen logger dflags this_mod data_tycons ; mapM_ do_tycon data_tycons - ; cg_id_infos <- cgs_binds <$> liftIO (readIORef cgref) + ; final_state <- liftIO (readIORef cgref) + ; let cg_id_infos = cgs_binds . codegen_state $ final_state + used_info = fromOL . codegen_used_info $ final_state + + ; !foreign_stub <- cg (initInfoTableProv used_info ip_map this_mod) -- See Note [Conveying CAF-info and LFInfo between modules] in -- GHC.StgToCmm.Types @@ -136,7 +155,7 @@ codeGen logger dflags this_mod data_tycons | otherwise = mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos)) - ; return generatedInfo + ; return (foreign_stub, generatedInfo) } --------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index ddd8a8a988..5c9b904896 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -97,6 +97,7 @@ 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 diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 3066609d7e..163f7a2a8a 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -59,9 +59,8 @@ module GHC.StgToCmm.Monad ( -- more localised access to monad state CgIdInfo(..), getBinds, setBinds, - -- out of general friendliness, we also export ... - CgInfoDownwards(..), CgState(..) -- non-abstract + CgInfoDownwards(..), CgState(..) -- non-abstract ) where import GHC.Prelude hiding( sequence, succ ) @@ -335,6 +334,9 @@ data CgState cgs_hp_usg :: HeapUsage, cgs_uniqs :: UniqSupply } +-- If you are wondering why you have to be careful forcing CgState then +-- the reason is the knot-tying in 'getHeapUsage'. This problem is tracked +-- in #19245 data HeapUsage -- See Note [Virtual and real heap pointers] = HeapUsage { @@ -400,7 +402,6 @@ s1 `addCodeBlocksFrom` s2 = s1 { cgs_stmts = cgs_stmts s1 CmmGraph.<*> cgs_stmts s2, cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 } - -- 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 -- heap high water mark you have to take the max of virtHp and hwHp. Remember, @@ -828,15 +829,15 @@ emitProc mb_info lbl live blocks offset do_layout ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } -getCmm :: FCode () -> FCode CmmGroup +getCmm :: FCode a -> FCode (a, CmmGroup) -- Get all the CmmTops (there should be no stmts) -- Return a single Cmm which may be split from other Cmms by -- object splitting (at a later stage) getCmm code = do { state1 <- getState - ; ((), state2) <- withState code (state1 { cgs_tops = nilOL }) + ; (a, state2) <- withState code (state1 { cgs_tops = nilOL }) ; setState $ state2 { cgs_tops = cgs_tops state1 } - ; return (fromOL (cgs_tops state2)) } + ; return (a, fromOL (cgs_tops state2)) } mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index 473e240a54..451d38ec4c 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -10,6 +10,9 @@ module GHC.StgToCmm.Prof ( initCostCentres, ccType, ccsType, mkCCostCentre, mkCCostCentreStack, + -- infoTablePRov + initInfoTableProv, emitInfoTableProv, + -- Cost-centre Profiling dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, enterCostCentreThunk, enterCostCentreFun, @@ -41,10 +44,13 @@ import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Types.CostCentre +import GHC.Types.IPE import GHC.Data.FastString import GHC.Unit.Module as Module import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Driver.CodeOutput ( ipInitCode ) + import Control.Monad import Data.Char (ord) @@ -269,6 +275,53 @@ sizeof_ccs_words platform where (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform + +initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> Module -> FCode SDoc +-- Emit the declarations +initInfoTableProv infos itmap this_mod + = do + dflags <- getDynFlags + let ents = convertInfoProvMap dflags infos this_mod itmap + --pprTraceM "UsedInfo" (ppr (length infos)) + --pprTraceM "initInfoTable" (ppr (length ents)) + -- Output the actual IPE data + mapM_ emitInfoTableProv ents + -- Create the C stub which initialises the IPE_LIST + return (ipInitCode dflags this_mod ents) + +--- Info Table Prov stuff +emitInfoTableProv :: InfoProvEnt -> FCode () +emitInfoTableProv ip = do + { dflags <- getDynFlags + ; let mod = infoProvModule ip + ; let (src, label) = maybe ("", "") (\(s, l) -> (showPpr dflags s, l)) (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) + + ; ty_string <- newByteStringCLit (bytesFS (mkFastString (infoTableType ip))) + ; loc <- newByteStringCLit $ bytesFS $ mkFastString $ src + -- XXX going via FastString to get UTF-8 encoding is silly + ; table_name <- newByteStringCLit $ bytesFS $ mkFastString $ + showPpr dflags (pprCLabel platform CStyle (infoTablePtr ip)) + + ; closure_type <- newByteStringCLit $ bytesFS $ mkFastString $ + showPpr dflags (text $ show $ infoProvEntClosureType ip) + ; let + lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer + table_name, -- char *table_name + closure_type, -- char *closure_desc -- Filled in from the InfoTable + ty_string, -- char *ty_string + label, -- char *label, + modl, -- char *module, + loc, -- char *srcloc, + zero platform -- struct _InfoProvEnt *link + ] + ; emitDataLits (mkIPELabel ip) lits + } -- --------------------------------------------------------------------------- -- Set the current cost centre stack diff --git a/compiler/GHC/StgToCmm/Types.hs b/compiler/GHC/StgToCmm/Types.hs index e59792cb57..944ff4b072 100644 --- a/compiler/GHC/StgToCmm/Types.hs +++ b/compiler/GHC/StgToCmm/Types.hs @@ -20,6 +20,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Utils.Outputable + {- Note [Conveying CAF-info and LFInfo between modules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -86,6 +87,8 @@ data CgInfos = CgInfos -- either not exported of CAFFY. , cgLFInfos :: !ModuleLFInfos -- ^ LambdaFormInfos of exported closures in the current module. + , cgIPEStub :: !SDoc + -- ^ The C stub which is used for IPE information } -------------------------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index a900de3677..bc10eaf4ea 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -44,6 +44,8 @@ module GHC.StgToCmm.Utils ( whenUpdRemSetEnabled, emitUpdRemSetPush, emitUpdRemSetPushThunk, + + convertInfoProvMap, cmmInfoTableToInfoProvEnt ) where #include "HsVersions.h" @@ -79,6 +81,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.RepType import GHC.Types.CostCentre +import GHC.Types.IPE import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 @@ -86,7 +89,9 @@ import qualified Data.Map as M import Data.Char import Data.List (sortBy) import Data.Ord - +import GHC.Types.Unique.Map +import Data.Maybe +import GHC.Driver.Ppr ------------------------------------------------------------------------- -- @@ -631,3 +636,32 @@ emitUpdRemSetPushThunk ptr = [(CmmReg (CmmGlobal BaseReg), AddrHint), (ptr, AddrHint)] False + +-- | A bare bones InfoProvEnt for things which don't have a good source location +cmmInfoTableToInfoProvEnt :: Module -> CmmInfoTable -> InfoProvEnt +cmmInfoTableToInfoProvEnt this_mod cmit = + let cl = cit_lbl cmit + cn = rtsClosureType (cit_rep cmit) + in InfoProvEnt cl cn "" this_mod Nothing + +-- | 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) = + map (\cmit -> + let cl = cit_lbl cmit + cn = rtsClosureType (cit_rep cmit) + + tyString :: Outputable a => a -> String + tyString t = showPpr dflags t + + lookupClosureMap :: Maybe InfoProvEnt + lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of + Just (ty, ss, l) -> Just (InfoProvEnt cl cn (tyString ty) this_mod (Just (ss, l))) + Nothing -> Nothing + + -- 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 diff --git a/compiler/GHC/Types/IPE.hs b/compiler/GHC/Types/IPE.hs new file mode 100644 index 0000000000..78c929c4db --- /dev/null +++ b/compiler/GHC/Types/IPE.hs @@ -0,0 +1,24 @@ +module GHC.Types.IPE(ClosureMap, InfoTableProvMap(..) + , emptyInfoTableProvMap) where + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Types.SrcLoc + +import GHC.Types.Unique.Map +import GHC.Core.Type + +-- | A map from a 'Name' to the best approximate source position that +-- name arose from. +type ClosureMap = UniqMap Name -- The binding + (Type, RealSrcSpan, String) + -- The best approximate source position. + -- (rendered type, source position, source note + -- label) + +data InfoTableProvMap = InfoTableProvMap + { provClosure :: ClosureMap } + +emptyInfoTableProvMap :: InfoTableProvMap +emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs index 7dd7b297e3..1ec91017ca 100644 --- a/compiler/GHC/Types/SrcLoc.hs +++ b/compiler/GHC/Types/SrcLoc.hs @@ -51,6 +51,7 @@ module GHC.Types.SrcLoc ( pprUserRealSpan, pprUnhelpfulSpanReason, pprUserSpan, unhelpfulSpanFS, + srcSpanToRealSrcSpan, -- ** Unsafely deconstructing SrcSpan -- These are dubious exports, because they crash on some inputs @@ -616,6 +617,10 @@ srcSpanFileName_maybe :: SrcSpan -> Maybe FastString srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s) srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing +srcSpanToRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan +srcSpanToRealSrcSpan (RealSrcSpan ss _) = Just ss +srcSpanToRealSrcSpan _ = Nothing + {- ************************************************************************ * * diff --git a/compiler/GHC/Types/Unique/Map.hs b/compiler/GHC/Types/Unique/Map.hs index 667d5806d0..d31043353d 100644 --- a/compiler/GHC/Types/Unique/Map.hs +++ b/compiler/GHC/Types/Unique/Map.hs @@ -10,7 +10,7 @@ -- -- Key preservation is right-biased. module GHC.Types.Unique.Map ( - UniqMap, + UniqMap(..), emptyUniqMap, isNullUniqMap, unitUniqMap, diff --git a/compiler/GHC/Unit/Module/Name.hs b/compiler/GHC/Unit/Module/Name.hs index 76c40f6a87..cc5e430bd6 100644 --- a/compiler/GHC/Unit/Module/Name.hs +++ b/compiler/GHC/Unit/Module/Name.hs @@ -30,7 +30,7 @@ import Text.ParserCombinators.ReadP (ReadP) import Data.Char (isAlphaNum) -- | A ModuleName is essentially a simple string, e.g. @Data.List@. -newtype ModuleName = ModuleName FastString +newtype ModuleName = ModuleName FastString deriving Show instance Uniquable ModuleName where getUnique (ModuleName nm) = getUnique nm |