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.

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