Add option to give each usage of a data constructor its own info table

The `-fdistinct-constructor-tables` flag will generate a fresh info
table for the usage of any data constructor. This is useful for
debugging as now by inspecting the info table, you can determine which
usage of a constructor caused that allocation rather than the old
situation where the info table always mapped to the definition site of
the data constructor which is useless.

In conjunction with `-hi` and `-finfo-table-map` this gives a more fine
grained understanding of where constructor allocations arise from in a
program.

1 files changed, 17 insertions, 10 deletions

diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
index f89f465d12..d60b52536f 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -64,8 +64,9 @@ import GHC.SysTools.FileCleanup
 
 import GHC.Data.Stream
 import GHC.Data.OrdList
+import GHC.Types.Unique.Map
 
-import Control.Monad (when,void)
+import Control.Monad (when,void, forM_)
 import GHC.Utils.Misc
 import System.IO.Unsafe
 import qualified Data.ByteString as BS
@@ -87,7 +88,7 @@ codeGen :: Logger
         -> Stream IO CmmGroup (SDoc, ModuleLFInfos)       -- Output as a stream, so codegen can
                                        -- be interleaved with output
 
-codeGen logger dflags this_mod ip_map@(InfoTableProvMap _) data_tycons
+codeGen logger dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) 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
@@ -132,10 +133,15 @@ codeGen logger dflags this_mod ip_map@(InfoTableProvMap _) data_tycons
                 -- enumeration type Note that the closure pointers are
                 -- tagged.
                  when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
-                 mapM_ (cg . cgDataCon) (tyConDataCons tycon)
+                 -- Emit normal info_tables, for data constructors defined in this module.
+                 mapM_ (cg . cgDataCon DefinitionSite) (tyConDataCons tycon)
 
         ; mapM_ do_tycon data_tycons
 
+        -- Emit special info tables for everything used in this module
+        -- This will only do something if  `-fdistinct-info-tables` is turned on.
+        ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite this_mod k) dc)) (nonDetEltsUFM denv)
+
         ; final_state <- liftIO (readIORef cgref)
         ; let cg_id_infos = cgs_binds . codegen_state $ final_state
               used_info = fromOL . codegen_used_info $ final_state
@@ -210,8 +216,8 @@ cgTopBinding logger dflags (StgTopStringLit id str) = do
 cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
         -- The Id is passed along for setting up a binding...
 
-cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
-  = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)
+cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn _ts args)
+  = cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args)
       -- con args are always non-void,
       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
 
@@ -250,11 +256,12 @@ cgEnumerationTyCon tycon
              | con <- tyConDataCons tycon]
 
 
--- | Generate the entry code, info tables, and (for niladic constructor)
+cgDataCon :: ConInfoTableLocation -> DataCon -> FCode ()
+-- Generate the entry code, info tables, and (for niladic constructor)
 -- the static closure, for a constructor.
-cgDataCon :: DataCon -> FCode ()
-cgDataCon data_con
-  = do  { profile <- getProfile
+cgDataCon mn data_con
+  = do  { MASSERT( not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con) )
+        ; profile <- getProfile
         ; platform <- getPlatform
         ; let
             (tot_wds, --  #ptr_wds + #nonptr_wds
@@ -264,7 +271,7 @@ cgDataCon data_con
             nonptr_wds   = tot_wds - ptr_wds
 
             dyn_info_tbl =
-              mkDataConInfoTable profile data_con False ptr_wds nonptr_wds
+              mkDataConInfoTable profile data_con mn False ptr_wds nonptr_wds
 
             -- We're generating info tables, so we don't know and care about
             -- what the actual arguments are. Using () here as the place holder.