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.

5 files changed, 99 insertions, 7 deletions

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