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.

1 files changed, 38 insertions, 28 deletions

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)
 
 
 {- **********************************************************************