summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2020-11-18 11:36:07 +0000
committerMatthew Pickering <matthewtpickering@gmail.com>2021-03-03 19:09:34 +0000
commit4b297979d25740d31241a9000e36068db112545a (patch)
treee2e40fa7922fb4a91125c73fcbae04e7a6a66f73 /compiler/GHC
parent8402ea951b31e01a925ca691747d1757eaf31fcc (diff)
downloadhaskell-4b297979d25740d31241a9000e36068db112545a.tar.gz
Add -finfo-table-map which maps info tables to source positions
This new flag embeds a lookup table from the address of an info table to information about that info table. The main interface for consulting the map is the `lookupIPE` C function > InfoProvEnt * lookupIPE(StgInfoTable *info) The `InfoProvEnt` has the following structure: > typedef struct InfoProv_{ > char * table_name; > char * closure_desc; > char * ty_desc; > char * label; > char * module; > char * srcloc; > } InfoProv; > > typedef struct InfoProvEnt_ { > StgInfoTable * info; > InfoProv prov; > struct InfoProvEnt_ *link; > } InfoProvEnt; The source positions are approximated in a similar way to the source positions for DWARF debugging information. They are only approximate but in our experience provide a good enough hint about where the problem might be. It is therefore recommended to use this flag in conjunction with `-g<n>` for more accurate locations. The lookup table is also emitted into the eventlog when it is available as it is intended to be used with the `-hi` profiling mode. Using this flag will significantly increase the size of the resulting object file but only by a factor of 2-3x in our experience.
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Cmm/CLabel.hs56
-rw-r--r--compiler/GHC/Cmm/Parser.y15
-rw-r--r--compiler/GHC/CoreToStg.hs17
-rw-r--r--compiler/GHC/Driver/CodeOutput.hs125
-rw-r--r--compiler/GHC/Driver/Flags.hs2
-rw-r--r--compiler/GHC/Driver/Hooks.hs6
-rw-r--r--compiler/GHC/Driver/Main.hs66
-rw-r--r--compiler/GHC/Driver/Pipeline.hs4
-rw-r--r--compiler/GHC/Driver/Session.hs2
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs6
-rw-r--r--compiler/GHC/Stg/Debug.hs140
-rw-r--r--compiler/GHC/StgToCmm.hs49
-rw-r--r--compiler/GHC/StgToCmm/Closure.hs1
-rw-r--r--compiler/GHC/StgToCmm/Monad.hs13
-rw-r--r--compiler/GHC/StgToCmm/Prof.hs53
-rw-r--r--compiler/GHC/StgToCmm/Types.hs3
-rw-r--r--compiler/GHC/StgToCmm/Utils.hs36
-rw-r--r--compiler/GHC/Types/IPE.hs24
-rw-r--r--compiler/GHC/Types/SrcLoc.hs5
-rw-r--r--compiler/GHC/Types/Unique/Map.hs2
-rw-r--r--compiler/GHC/Unit/Module/Name.hs2
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