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.

24 files changed, 323 insertions, 181 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index 1afb97dcd8..e2f7ce82bc 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -18,6 +18,8 @@ module GHC.Cmm.CLabel (
         NeedExternDecl (..),
         ForeignLabelSource(..),
         DynamicLinkerLabelInfo(..),
+        ConInfoTableLocation(..),
+        getConInfoTableLocation,
 
         -- * Constructors
         mkClosureLabel,
@@ -107,6 +109,7 @@ module GHC.Cmm.CLabel (
         isIdLabel,
         isTickyLabel,
         hasHaskellName,
+        hasIdLabelInfo,
         isBytesLabel,
         isForeignLabel,
         isSomeRODataLabel,
@@ -450,8 +453,18 @@ data IdLabelInfo
 
   | RednCounts          -- ^ Label of place to keep Ticky-ticky  info for this Id
 
-  | ConEntry            -- ^ Constructor entry point
-  | ConInfoTable        -- ^ Corresponding info table
+  | ConEntry ConInfoTableLocation
+  -- ^ Constructor entry point, when `-fdistinct-info-tables` is enabled then
+  -- each usage of a constructor will be given a unique number and a fresh info
+  -- table will be created in the module where the constructor is used. The
+  -- argument is used to keep track of which info table a usage of a constructor
+  -- should use. When the argument is 'Nothing' then it uses the info table which
+  -- is defined in the module where the datatype is declared, this is the usual case.
+  -- When it is (Just (m, k)) it will use the kth info table defined in module m. The
+  -- point of this inefficiency is so that you can work out where allocations of data
+  -- constructors are coming from when you are debugging.
+
+  | ConInfoTable ConInfoTableLocation        -- ^ Corresponding info table
 
   | ClosureTable        -- ^ Table of closures for Enum tycons
 
@@ -463,6 +476,19 @@ data IdLabelInfo
 
   deriving (Eq, Ord)
 
+-- | Which module is the info table from, and which number was it.
+data ConInfoTableLocation = UsageSite Module Int
+                          | DefinitionSite
+                              deriving (Eq, Ord)
+
+instance Outputable ConInfoTableLocation where
+  ppr (UsageSite m n) = text "Loc(" <> ppr n <> text "):" <+> ppr m
+  ppr DefinitionSite = empty
+
+getConInfoTableLocation :: IdLabelInfo -> Maybe ConInfoTableLocation
+getConInfoTableLocation (ConInfoTable ci) = Just ci
+getConInfoTableLocation _ = Nothing
+
 instance Outputable IdLabelInfo where
   ppr Closure    = text "Closure"
   ppr InfoTable  = text "InfoTable"
@@ -473,10 +499,8 @@ instance Outputable IdLabelInfo where
   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 (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"
@@ -544,13 +568,15 @@ mkClosureLabel              :: Name -> CafInfo -> CLabel
 mkInfoTableLabel            :: Name -> CafInfo -> CLabel
 mkEntryLabel                :: Name -> CafInfo -> CLabel
 mkClosureTableLabel         :: Name -> CafInfo -> CLabel
-mkConInfoTableLabel         :: Name -> CafInfo -> CLabel
+mkConInfoTableLabel         :: Name -> ConInfoTableLocation -> CLabel
 mkBytesLabel                :: Name -> CLabel
 mkClosureLabel name         c     = IdLabel name c Closure
 mkInfoTableLabel name       c     = IdLabel name c InfoTable
 mkEntryLabel name           c     = IdLabel name c Entry
 mkClosureTableLabel name    c     = IdLabel name c ClosureTable
-mkConInfoTableLabel name    c     = IdLabel name c ConInfoTable
+-- Special case for the normal 'DefinitionSite' case so that the 'ConInfoTable' application can be floated to a CAF.
+mkConInfoTableLabel name DefinitionSite = IdLabel name NoCafRefs (ConInfoTable DefinitionSite)
+mkConInfoTableLabel name k = IdLabel name NoCafRefs (ConInfoTable k)
 mkBytesLabel name                 = IdLabel name NoCafRefs Bytes
 
 mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel
@@ -706,7 +732,7 @@ isStaticClosureLabel _lbl = False
 isSomeRODataLabel :: CLabel -> Bool
 -- info table defined in haskell (.hs)
 isSomeRODataLabel (IdLabel _ _ ClosureTable) = True
-isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True
+isSomeRODataLabel (IdLabel _ _ ConInfoTable {}) = True
 isSomeRODataLabel (IdLabel _ _ InfoTable) = True
 isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True
 isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True
@@ -718,13 +744,13 @@ isSomeRODataLabel _lbl = False
 isInfoTableLabel :: CLabel -> Bool
 isInfoTableLabel (IdLabel _ _ InfoTable)      = True
 isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True
-isInfoTableLabel (IdLabel _ _ ConInfoTable)   = True
+isInfoTableLabel (IdLabel _ _ ConInfoTable {})   = True
 isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True
 isInfoTableLabel _                            = False
 
 -- | Whether label is points to constructor info table
 isConInfoTableLabel :: CLabel -> Bool
-isConInfoTableLabel (IdLabel _ _ ConInfoTable)   = True
+isConInfoTableLabel (IdLabel _ _ ConInfoTable {})   = True
 isConInfoTableLabel _                            = False
 
 -- | Get the label size field from a ForeignLabel
@@ -827,7 +853,8 @@ toSlowEntryLbl platform lbl = case lbl of
 toEntryLbl :: Platform -> CLabel -> CLabel
 toEntryLbl platform lbl = case lbl of
    IdLabel n c LocalInfoTable    -> IdLabel n c LocalEntry
-   IdLabel n c ConInfoTable      -> IdLabel n c ConEntry
+   IdLabel n c (ConInfoTable k)  -> IdLabel n c (ConEntry k)
+
    IdLabel n _ BlockInfoTable    -> mkLocalBlockLabel (nameUnique n)
                    -- See Note [Proc-point local block entry-point].
    IdLabel n c _                 -> IdLabel n c Entry
@@ -838,7 +865,8 @@ toEntryLbl platform lbl = case lbl of
 toInfoLbl :: Platform -> CLabel -> CLabel
 toInfoLbl platform lbl = case lbl of
    IdLabel n c LocalEntry      -> IdLabel n c LocalInfoTable
-   IdLabel n c ConEntry        -> IdLabel n c ConInfoTable
+   IdLabel n c (ConEntry k)    -> IdLabel n c (ConInfoTable k)
+
    IdLabel n c _               -> IdLabel n c InfoTable
    CmmLabel m ext str CmmEntry -> CmmLabel m ext str CmmInfo
    CmmLabel m ext str CmmRet   -> CmmLabel m ext str CmmRetInfo
@@ -848,6 +876,10 @@ hasHaskellName :: CLabel -> Maybe Name
 hasHaskellName (IdLabel n _ _) = Just n
 hasHaskellName _               = Nothing
 
+hasIdLabelInfo :: CLabel -> Maybe IdLabelInfo
+hasIdLabelInfo (IdLabel _ _ l) = Just l
+hasIdLabelInfo _ = Nothing
+
 -- -----------------------------------------------------------------------------
 -- Does a CLabel's referent itself refer to a CAF?
 hasCAF :: CLabel -> Bool
@@ -1459,8 +1491,16 @@ ppIdFlavor x = pp_cSEP <> case x of
    LocalEntry       -> text "entry"
    Slow             -> text "slow"
    RednCounts       -> text "ct"
-   ConEntry         -> text "con_entry"
-   ConInfoTable     -> text "con_info"
+   ConEntry loc      ->
+      case loc of
+        DefinitionSite -> text "con_entry"
+        UsageSite m n ->
+          ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_entry"
+   ConInfoTable k   ->
+    case k of
+      DefinitionSite -> text "con_info"
+      UsageSite m n ->
+        ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_info"
    ClosureTable     -> text "closure_tbl"
    Bytes            -> text "bytes"
    BlockInfoTable   -> text "info"
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 2f9e3816ef..1bcf5bdfe9 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -545,7 +545,7 @@ coreToStgApp f args ticks = do
         res_ty = exprType (mkApps (Var f) args)
         app = case idDetails f of
                 DataConWorkId dc
-                  | saturated    -> StgConApp dc args'
+                  | saturated    -> StgConApp dc NoNumber args'
                                       (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))
 
                 -- Some primitive operator that might be implemented as a library call.
@@ -602,7 +602,7 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
         (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
         stg_arg = case arg'' of
                        StgApp v []        -> StgVarArg v
-                       StgConApp con [] _ -> StgVarArg (dataConWorkId con)
+                       StgConApp con _ [] _ -> StgVarArg (dataConWorkId con)
                        StgLit lit         -> StgLitArg lit
                        _                  -> pprPanic "coreToStgArgs" (ppr arg)
 
@@ -719,13 +719,13 @@ mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)
 
   -- After this point we know that `bndrs` is empty,
   -- so this is not a function binding
-  | StgConApp con args _ <- unticked_rhs
+  | StgConApp con mn args _ <- unticked_rhs
   , -- Dynamic StgConApps are updatable
     not (isDllConApp dflags this_mod con args)
   = -- CorePrep does this right, but just to make sure
     ASSERT2( not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)
            , ppr bndr $$ ppr con $$ ppr args)
-    ( StgRhsCon dontCareCCS con args, ccs )
+    ( StgRhsCon dontCareCCS con mn ticks args, ccs )
 
   -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
   | gopt Opt_AutoSccsOnIndividualCafs dflags
@@ -741,7 +741,7 @@ mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)
     , ccs )
 
   where
-    unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs
+    (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
 
     upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry
              | otherwise                         = Updatable
@@ -777,15 +777,15 @@ mkStgRhs bndr (PreStgRhs bndrs rhs)
                   ReEntrant -- ignored for LNE
                   [] rhs
 
-  | StgConApp con args _ <- unticked_rhs
-  = StgRhsCon currentCCS con args
+  | StgConApp con mn args _ <- unticked_rhs
+  = StgRhsCon currentCCS con mn ticks args
 
   | otherwise
   = StgRhsClosure noExtFieldSilent
                   currentCCS
                   upd_flag [] rhs
   where
-    unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs
+    (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
 
     upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry
              | otherwise                         = Updatable
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index f6b9e9738c..5e0c5f0c05 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -353,77 +353,3 @@ ipInitCode dflags this_mod ents
       <> 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 955b6fabd1..f15d0d4ba1 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -132,6 +132,7 @@ data GeneralFlag
    | Opt_FastLlvm                       -- hidden flag
    | Opt_NoTypeableBinds
 
+   | Opt_DistinctConstructorTables
    | Opt_InfoTableMap
 
    | Opt_WarnIsError                    -- -Werror; makes warnings fatal
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 98c46427e6..8237525fb7 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -2775,7 +2775,8 @@ dynamic_flags_deps = [
         -- Caller-CC
   , make_ord_flag defGhcFlag "fprof-callers"
          (HasArg setCallerCcFilters)
-
+  , make_ord_flag defGhcFlag "fdistinct-constructor-tables"
+      (NoArg (setGeneralFlag Opt_DistinctConstructorTables))
   , make_ord_flag defGhcFlag "finfo-table-map"
       (NoArg (setGeneralFlag Opt_InfoTableMap))
         ------ Compiler flags -----------------------------------------------
diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs
index b9e6782f77..bc266d20ba 100644
--- a/compiler/GHC/Stg/CSE.hs
+++ b/compiler/GHC/Stg/CSE.hs
@@ -292,8 +292,8 @@ stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs
 stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)
     = let body' = stgCseExpr (initEnv in_scope) body
       in  StgRhsClosure ext ccs upd args body'
-stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args)
-    = StgRhsCon ccs dataCon args
+stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args)
+    = StgRhsCon ccs dataCon mu ticks args
 
 ------------------------------
 -- The actual AST traversal --
@@ -326,11 +326,11 @@ stgCseExpr env (StgCase scrut bndr ty alts)
 
 -- A constructor application.
 -- To be removed by a variable use when found in the CSE environment
-stgCseExpr env (StgConApp dataCon args tys)
+stgCseExpr env (StgConApp dataCon n args tys)
     | Just bndr' <- envLookup dataCon args' env
     = StgApp bndr' []
     | otherwise
-    = StgConApp dataCon args' tys
+    = StgConApp dataCon n args' tys
   where args' = substArgs env args
 
 -- Let bindings
@@ -395,7 +395,7 @@ stgCsePairs env0 ((b,e):pairs)
 -- The RHS of a binding.
 -- If it is a constructor application, either short-cut it or extend the environment
 stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)
-stgCseRhs env bndr (StgRhsCon ccs dataCon args)
+stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args)
     | Just other_bndr <- envLookup dataCon args' env
     , not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers]
     = let env' = addSubst bndr other_bndr env
@@ -403,7 +403,7 @@ stgCseRhs env bndr (StgRhsCon ccs dataCon args)
     | otherwise
     = let env' = addDataCon bndr dataCon args' env
             -- see note [Case 1: CSEing allocated closures]
-          pair = (bndr, StgRhsCon ccs dataCon args')
+          pair = (bndr, StgRhsCon ccs dataCon mu ticks args')
       in (Just pair, env')
   where args' = substArgs env args
 
diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs
index e6e85f7db7..823334e2aa 100644
--- a/compiler/GHC/Stg/Debug.hs
+++ b/compiler/GHC/Stg/Debug.hs
@@ -16,7 +16,6 @@ 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
@@ -25,6 +24,8 @@ import Control.Monad.Trans.Class
 import GHC.Types.Unique.Map
 import GHC.Types.SrcLoc
 import Control.Applicative
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty(..))
 
 data SpanWithLabel = SpanWithLabel RealSrcSpan String
 
@@ -64,9 +65,9 @@ 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)
+collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args) = do
+  n' <- numberDataCon dc ticks
+  return (StgRhsCon cc dc n' ticks args)
 
 
 recordInfo :: Id -> StgExpr -> M ()
@@ -86,9 +87,9 @@ 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 (StgConApp dc _mn as tys) = do
+      n' <- numberDataCon dc []
+      return (StgConApp dc n' 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
@@ -129,7 +130,6 @@ 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)
@@ -138,3 +138,109 @@ recordStgIdPosition id best_span ss = do
       Just (SpanWithLabel rss d) ->
         lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, rss, d)})
 
+numberDataCon :: DataCon -> [Tickish Id] -> M ConstructorNumber
+-- Unboxed tuples and sums do not allocate so they
+-- have no info tables.
+numberDataCon dc _ | isUnboxedTupleDataCon dc = return NoNumber
+numberDataCon dc _ | isUnboxedSumDataCon dc = return NoNumber
+numberDataCon dc ts = do
+  dflags <- asks rDynFlags
+  if not (gopt Opt_DistinctConstructorTables dflags) then return NoNumber else do
+          env <- lift get
+          mcc <- asks rSpan
+          let mbest_span = selectTick ts <|> mcc
+          case mbest_span of
+            Nothing -> return NoNumber
+            Just (SpanWithLabel rss l) -> do
+              let best_span = (rss, l)
+              let dcMap' = alterUniqMap (maybe (Just ((0, best_span) :| [] ))
+                                  (\xs@((k, _):|_) -> Just ((k + 1, best_span) `NE.cons` xs))) (provDC env) dc
+              lift $ put (env { provDC = dcMap' })
+              let r = lookupUniqMap dcMap' dc
+              return $ case r of
+                Nothing -> NoNumber
+                Just res -> Numbered (fst (NE.head res))
+
+selectTick :: [Tickish Id] -> Maybe SpanWithLabel
+selectTick [] = Nothing
+selectTick (SourceNote rss d : ts ) = selectTick ts <|> Just (SpanWithLabel rss d)
+selectTick (_:ts) = selectTick ts
+
+{-
+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 GHC.Stg.Debug, 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 in an IORef, this
+is important as it's hard to predict beforehand what code generation will do
+and which ids will end up in the generated program.
+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
+`numberDataCon`.
+
+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 `collectExpr` 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/Stg/DepAnal.hs b/compiler/GHC/Stg/DepAnal.hs
index 9bf4249f6f..0e53ffcca1 100644
--- a/compiler/GHC/Stg/DepAnal.hs
+++ b/compiler/GHC/Stg/DepAnal.hs
@@ -62,7 +62,7 @@ annTopBindingsDeps this_mod bs = zip bs (map top_bind bs)
     rhs bounds (StgRhsClosure _ _ _ as e) =
       expr (extendVarSetList bounds as) e
 
-    rhs bounds (StgRhsCon _ _ as) =
+    rhs bounds (StgRhsCon _ _ _ _ as) =
       args bounds as
 
     var :: BVs -> Var -> FVs
@@ -87,7 +87,7 @@ annTopBindingsDeps this_mod bs = zip bs (map top_bind bs)
     expr _ StgLit{} =
       emptyVarSet
 
-    expr bounds (StgConApp _ as _) =
+    expr bounds (StgConApp _ _ as _) =
       args bounds as
     expr bounds (StgOpApp _ as _) =
       args bounds as
diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs
index bd699a1fe1..ce40307420 100644
--- a/compiler/GHC/Stg/FVs.hs
+++ b/compiler/GHC/Stg/FVs.hs
@@ -124,7 +124,7 @@ expr env = go
     go (StgApp occ as)
       = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ]))
     go (StgLit lit) = (StgLit lit, emptyDVarSet)
-    go (StgConApp dc as tys) = (StgConApp dc as tys, args env as)
+    go (StgConApp dc n as tys) = (StgConApp dc n as tys, args env as)
     go (StgOpApp op as ty) = (StgOpApp op as ty, args env as)
     go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)
       where
@@ -156,7 +156,7 @@ rhs env (StgRhsClosure _ ccs uf bndrs body)
     -- See Note [Tracking local binders]
     (body', body_fvs) = expr (addLocals bndrs env) body
     fvs = delDVarSetList body_fvs bndrs
-rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as)
+rhs env (StgRhsCon ccs dc mu ts as) = (StgRhsCon ccs dc mu ts as, args env as)
 
 alt :: Env -> StgAlt -> (CgStgAlt, DIdSet)
 alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)
diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs
index 8f2337120e..4e7b66f23d 100644
--- a/compiler/GHC/Stg/Lift.hs
+++ b/compiler/GHC/Stg/Lift.hs
@@ -199,9 +199,9 @@ liftRhs
   -- as lambda binders, discarding all free vars.
   -> LlStgRhs
   -> LiftM OutStgRhs
-liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args)
+liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args)
   = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs)
-    StgRhsCon ccs con <$> traverse liftArgs args
+    StgRhsCon ccs con mn ts <$> traverse liftArgs args
 liftRhs Nothing (StgRhsClosure _ ccs upd infos body) =
   -- This RHS wasn't lifted.
   withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
@@ -227,7 +227,7 @@ liftExpr (StgApp f args) = do
   fvs' <- formerFreeVars f
   let top_lvl_args = map StgVarArg fvs' ++ args'
   pure (StgApp f' top_lvl_args)
-liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys
+liftExpr (StgConApp con mn args tys) = StgConApp con mn <$> traverse liftArgs args <*> pure tys
 liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty
 liftExpr (StgCase scrut info ty alts) = do
   scrut' <- liftExpr scrut
diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs
index 314e010ead..884489e0f7 100644
--- a/compiler/GHC/Stg/Lift/Analysis.hs
+++ b/compiler/GHC/Stg/Lift/Analysis.hs
@@ -114,9 +114,10 @@ type instance BinderP      'LiftLams = BinderInfo
 type instance XRhsClosure  'LiftLams = DIdSet
 type instance XLet         'LiftLams = Skeleton
 type instance XLetNoEscape 'LiftLams = Skeleton
+type instance XConApp      'LiftLams = ConstructorNumber
 
 freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet
-freeVarsOfRhs (StgRhsCon _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]
+freeVarsOfRhs (StgRhsCon _ _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]
 freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs
 
 -- | Captures details of the syntax tree relevant to the cost model, such as
@@ -210,8 +211,8 @@ tagSkeletonTopBind bind = bind'
 tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
 tagSkeletonExpr (StgLit lit)
   = (NilSk, emptyVarSet, StgLit lit)
-tagSkeletonExpr (StgConApp con args tys)
-  = (NilSk, mkArgOccs args, StgConApp con args tys)
+tagSkeletonExpr (StgConApp con mn args tys)
+  = (NilSk, mkArgOccs args, StgConApp con mn args tys)
 tagSkeletonExpr (StgOpApp op args ty)
   = (NilSk, mkArgOccs args, StgOpApp op args ty)
 tagSkeletonExpr (StgApp f args)
@@ -314,8 +315,8 @@ tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs)
         bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs)
 
 tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)
-tagSkeletonRhs _ (StgRhsCon ccs dc args)
-  = (NilSk, mkArgOccs args, StgRhsCon ccs dc args)
+tagSkeletonRhs _ (StgRhsCon ccs dc mn ts args)
+  = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn ts args)
 tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body)
   = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body')
   where
diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs
index 4b99521066..e43bda363d 100644
--- a/compiler/GHC/Stg/Lift/Monad.hs
+++ b/compiler/GHC/Stg/Lift/Monad.hs
@@ -194,9 +194,9 @@ removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass
 removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body)
   | isCurrentCCS ccs
   = StgRhsClosure ext dontCareCCS upd bndrs body
-removeRhsCCCS (StgRhsCon ccs con args)
+removeRhsCCCS (StgRhsCon ccs con mu ts args)
   | isCurrentCCS ccs
-  = StgRhsCon dontCareCCS con args
+  = StgRhsCon dontCareCCS con mu ts args
 removeRhsCCCS rhs = rhs
 
 -- | The analysis monad consists of the following 'RWST' components:
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index 0ee7381fe0..bf52840f5c 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -150,7 +150,7 @@ checkNoCurrentCCS rhs = do
       StgRhsClosure _ ccs _ _ _
          | isCurrentCCS ccs
          -> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs')
-      StgRhsCon ccs _ _
+      StgRhsCon ccs _ _ _ _
          | isCurrentCCS ccs
          -> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs')
       _ -> return ()
@@ -165,7 +165,7 @@ lintStgRhs (StgRhsClosure _ _ _ binders expr)
       addInScopeVars binders $
         lintStgExpr expr
 
-lintStgRhs rhs@(StgRhsCon _ con args) = do
+lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do
     when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do
       opts <- getStgPprOpts
       addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
@@ -181,7 +181,7 @@ lintStgExpr (StgApp fun args) = do
     lintStgVar fun
     mapM_ lintStgArg args
 
-lintStgExpr app@(StgConApp con args _arg_tys) = do
+lintStgExpr app@(StgConApp con _n args _arg_tys) = do
     -- unboxed sums should vanish during unarise
     lf <- getLintFlags
     when (lf_unarised lf && isUnboxedSumDataCon con) $ do
diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs
index 0f806a3175..debe53201f 100644
--- a/compiler/GHC/Stg/Stats.hs
+++ b/compiler/GHC/Stg/Stats.hs
@@ -124,7 +124,7 @@ statBinding top (StgRec pairs)
 
 statRhs :: Bool -> (Id, StgRhs) -> StatEnv
 
-statRhs top (_, StgRhsCon _ _ _)
+statRhs top (_, StgRhsCon _ _ _ _ _)
   = countOne (ConstructorBinds top)
 
 statRhs top (_, StgRhsClosure _ _ u _ body)
@@ -148,7 +148,7 @@ statExpr :: StgExpr -> StatEnv
 
 statExpr (StgApp _ _)     = countOne Applications
 statExpr (StgLit _)       = countOne Literals
-statExpr (StgConApp _ _ _)= countOne ConstructorApps
+statExpr (StgConApp _ _ _ _)= countOne ConstructorApps
 statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
 statExpr (StgTick _ e)    = statExpr e
 
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs
index 25d01079df..185433100a 100644
--- a/compiler/GHC/Stg/Syntax.hs
+++ b/compiler/GHC/Stg/Syntax.hs
@@ -25,12 +25,14 @@ module GHC.Stg.Syntax (
         GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
         GenStgAlt, AltType(..),
 
-        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,
+        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, XConApp,
         NoExtFieldSilent, noExtFieldSilent,
         OutputablePass,
 
         UpdateFlag(..), isUpdatable,
 
+        ConstructorNumber(..),
+
         -- a set of synonyms for the vanilla parameterisation
         StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,
 
@@ -242,6 +244,7 @@ literals.
         -- StgConApp is vital for returning unboxed tuples or sums
         -- which can't be let-bound
   | StgConApp   DataCon
+                (XConApp pass)
                 [StgArg] -- Saturated
                 [Type]   -- See Note [Types in StgConApp] in GHC.Stg.Unarise
 
@@ -416,6 +419,8 @@ important):
                         -- from static closure.
         DataCon         -- Constructor. Never an unboxed tuple or sum, as those
                         -- are not allocated.
+        ConstructorNumber
+        [Tickish Id]
         [StgArg]        -- Args
 
 {-
@@ -478,6 +483,20 @@ type family XLet (pass :: StgPass)
 type instance XLet 'Vanilla = NoExtFieldSilent
 type instance XLet 'CodeGen = NoExtFieldSilent
 
+type family XConApp (pass :: StgPass)
+type instance XConApp 'Vanilla =  ConstructorNumber
+type instance XConApp 'CodeGen = ConstructorNumber
+
+-- | When `-fdistinct-constructor-tables` is turned on then
+-- each usage of a constructor is given an unique number and
+-- an info table is generated for each different constructor.
+data ConstructorNumber =
+      NoNumber | Numbered Int
+
+instance Outputable ConstructorNumber where
+  ppr NoNumber = empty
+  ppr (Numbered n) = text "#" <> ppr n
+
 type family XLetNoEscape (pass :: StgPass)
 type instance XLetNoEscape 'Vanilla = NoExtFieldSilent
 type instance XLetNoEscape 'CodeGen = NoExtFieldSilent
@@ -486,7 +505,7 @@ stgRhsArity :: StgRhs -> Int
 stgRhsArity (StgRhsClosure _ _ _ bndrs _)
   = ASSERT( all isId bndrs ) length bndrs
   -- The arity never includes type parameters, but they should have gone by now
-stgRhsArity (StgRhsCon _ _ _) = 0
+stgRhsArity (StgRhsCon _ _ _ _ _) = 0
 
 {-
 ************************************************************************
@@ -648,6 +667,7 @@ likes terminators instead...  Ditto for case alternatives.
 
 type OutputablePass pass =
   ( Outputable (XLet pass)
+  , Outputable (XConApp pass)
   , Outputable (XLetNoEscape pass)
   , Outputable (XRhsClosure pass)
   , OutputableBndr (BinderP pass)
@@ -713,7 +733,7 @@ pprStgExpr opts e = case e of
    StgLit lit           -> ppr lit
                            -- general case
    StgApp func args     -> hang (ppr func) 4 (interppSP args)
-   StgConApp con args _ -> hsep [ ppr con, brackets (interppSP args) ]
+   StgConApp con n args _ -> hsep [ ppr con, ppr n, brackets (interppSP args) ]
    StgOpApp op args _   -> hsep [ pprStgOp op, brackets (interppSP args)]
 
 -- special case: let v = <very specific thing>
@@ -816,5 +836,9 @@ pprStgRhs opts rhs = case rhs of
                     ])
               4 (pprStgExpr opts body)
 
-   StgRhsCon cc con args
-      -> hcat [ ppr cc, space, ppr con, text "! ", brackets (sep (map pprStgArg args))]
+   StgRhsCon cc con mid _ticks args
+      -> hcat [ ppr cc, space
+              , case mid of
+                  NoNumber -> empty
+                  Numbered n -> hcat [ppr n, space]
+              , ppr con, text "! ", brackets (sep (map pprStgArg args))]
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index 40dff5f33b..c9160ff72a 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -293,9 +293,9 @@ unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
        expr' <- unariseExpr rho' expr
        return (StgRhsClosure ext ccs update_flag args1 expr')
 
-unariseRhs rho (StgRhsCon ccs con args)
+unariseRhs rho (StgRhsCon ccs con mu ts args)
   = ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
-    return (StgRhsCon ccs con (unariseConArgs rho args))
+    return (StgRhsCon ccs con mu ts (unariseConArgs rho args))
 
 --------------------------------------------------------------------------------
 
@@ -325,13 +325,13 @@ unariseExpr rho e@(StgApp f args)
 unariseExpr _ (StgLit l)
   = return (StgLit l)
 
-unariseExpr rho (StgConApp dc args ty_args)
+unariseExpr rho (StgConApp dc n args ty_args)
   | Just args' <- unariseMulti_maybe rho dc args ty_args
   = return (mkTuple args')
 
   | otherwise
   , let args' = unariseConArgs rho args
-  = return (StgConApp dc args' (map stgArgType args'))
+  = return (StgConApp dc n args' (map stgArgType args'))
 
 unariseExpr rho (StgOpApp op args ty)
   = return (StgOpApp op (unariseFunArgs rho args) ty)
@@ -345,7 +345,7 @@ unariseExpr rho (StgCase scrut bndr alt_ty alts)
   -- Handle strict lets for tuples and sums:
   --   case (# a,b #) of r -> rhs
   -- and analogously for sums
-  | StgConApp dc args ty_args <- scrut
+  | StgConApp dc _n args ty_args <- scrut
   , Just args' <- unariseMulti_maybe rho dc args ty_args
   = elimCase rho args' bndr alt_ty alts
 
@@ -756,7 +756,7 @@ isUnboxedTupleBndr :: Id -> Bool
 isUnboxedTupleBndr = isUnboxedTupleType . idType
 
 mkTuple :: [StgArg] -> StgExpr
-mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)
+mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args (map stgArgType args)
 
 tagAltTy :: AltType
 tagAltTy = PrimAlt IntRep
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.
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index ca39b7b362..c4d2174d13 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -205,9 +205,9 @@ cgRhs :: Id
                                   -- (see above)
                )
 
-cgRhs id (StgRhsCon cc con args)
+cgRhs id (StgRhsCon cc con mn _ts args)
   = withNewTickyCounterCon (idName id) con $
-    buildDynCon id True cc con (assertNonVoidStgArgs args)
+    buildDynCon id mn True cc con (assertNonVoidStgArgs args)
       -- con args are always non-void,
       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
 
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index 5c9b904896..d73f09e59d 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -97,7 +97,6 @@ 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
@@ -906,8 +905,8 @@ getTyLitDescription l =
 --   CmmInfoTable-related things
 --------------------------------------
 
-mkDataConInfoTable :: Profile -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
-mkDataConInfoTable profile data_con is_static ptr_wds nonptr_wds
+mkDataConInfoTable :: Profile -> DataCon -> ConInfoTableLocation -> Bool -> Int -> Int -> CmmInfoTable
+mkDataConInfoTable profile data_con mn is_static ptr_wds nonptr_wds
  = CmmInfoTable { cit_lbl  = info_lbl
                 , cit_rep  = sm_rep
                 , cit_prof = prof
@@ -915,7 +914,7 @@ mkDataConInfoTable profile data_con is_static ptr_wds nonptr_wds
                 , cit_clo  = Nothing }
  where
    name = dataConName data_con
-   info_lbl = mkConInfoTableLabel name NoCafRefs
+   info_lbl = mkConInfoTableLabel name mn -- NoCAFRefs
    sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds cl_type
    cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)
                   -- We keep the *zero-indexed* tag in the srt_len field
diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs
index 18a8775cdd..95e975fd0a 100644
--- a/compiler/GHC/StgToCmm/DataCon.hs
+++ b/compiler/GHC/StgToCmm/DataCon.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE CPP #-}
 
 -----------------------------------------------------------------------------
@@ -62,9 +63,10 @@ import Data.Char
 cgTopRhsCon :: DynFlags
             -> Id               -- Name of thing bound to this RHS
             -> DataCon          -- Id
+            -> ConstructorNumber
             -> [NonVoid StgArg] -- Args
             -> (CgIdInfo, FCode ())
-cgTopRhsCon dflags id con args
+cgTopRhsCon dflags id con mn args
   | Just static_info <- precomputedStaticConInfo_maybe dflags id con args
   , let static_code | isInternalName name = pure ()
                     | otherwise           = gen_code
@@ -129,7 +131,7 @@ cgTopRhsCon dflags id con args
              -- we're not really going to emit an info table, so having
              -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields
              -- needs to poke around inside it.
-            info_tbl = mkDataConInfoTable profile con True ptr_wds nonptr_wds
+            info_tbl = mkDataConInfoTable profile con (addModuleLoc this_mod mn) True ptr_wds nonptr_wds
 
 
         ; payload <- mapM mk_payload (fix_padding nv_args_w_offsets)
@@ -138,8 +140,17 @@ cgTopRhsCon dflags id con args
                 --      TODO (osa): Why?
 
                 -- BUILD THE OBJECT
+                --
+            -- We're generating info tables, so we don't know and care about
+            -- what the actual arguments are. Using () here as the place holder.
+
         ; emitDataCon closure_label info_tbl dontCareCCS payload }
 
+addModuleLoc :: Module -> ConstructorNumber -> ConInfoTableLocation
+addModuleLoc this_mod mn = do
+  case mn of
+    NoNumber -> DefinitionSite
+    Numbered n -> UsageSite this_mod n
 
 ---------------------------------------------------------------
 --      Lay out and allocate non-top-level constructors
@@ -147,6 +158,7 @@ cgTopRhsCon dflags id con args
 
 buildDynCon :: Id                 -- Name of the thing to which this constr will
                                   -- be bound
+            -> ConstructorNumber
             -> Bool               -- is it genuinely bound to that name, or just
                                   -- for profiling?
             -> CostCentreStack    -- Where to grab cost centre from;
@@ -155,13 +167,14 @@ buildDynCon :: Id                 -- Name of the thing to which this constr will
             -> [NonVoid StgArg]   -- Its args
             -> FCode (CgIdInfo, FCode CmmAGraph)
                -- Return details about how to find it and initialization code
-buildDynCon binder actually_bound cc con args
+buildDynCon binder mn actually_bound cc con args
     = do dflags <- getDynFlags
-         buildDynCon' dflags binder actually_bound cc con args
+         buildDynCon' dflags binder mn actually_bound cc con args
 
 
 buildDynCon' :: DynFlags
-             -> Id -> Bool
+             -> Id -> ConstructorNumber
+             -> Bool
              -> CostCentreStack
              -> DataCon
              -> [NonVoid StgArg]
@@ -178,13 +191,13 @@ the addr modes of the args is that we may be in a "knot", and
 premature looking at the args will cause the compiler to black-hole!
 -}
 
-buildDynCon' dflags binder _ _cc con args
+buildDynCon' dflags binder _ _ _cc con args
   | Just cgInfo <- precomputedStaticConInfo_maybe dflags binder con args
   -- , pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True
   = return (cgInfo, return mkNop)
 
 -------- buildDynCon': the general case -----------
-buildDynCon' _ binder actually_bound ccs con args
+buildDynCon' _ binder mn actually_bound ccs con args
   = do  { (id_info, reg) <- rhsIdInfo binder lf_info
         ; return (id_info, gen_code reg)
         }
@@ -192,12 +205,13 @@ buildDynCon' _ binder actually_bound ccs con args
   lf_info = mkConLFInfo con
 
   gen_code reg
-    = do  { profile <- getProfile
+    = do  { modu <- getModuleName
+          ; profile <- getProfile
           ; let platform = profilePlatform profile
                 (tot_wds, ptr_wds, args_w_offsets)
-                  = mkVirtConstrOffsets profile (addArgReps args)
+                   = mkVirtConstrOffsets profile (addArgReps args)
                 nonptr_wds = tot_wds - ptr_wds
-                info_tbl = mkDataConInfoTable profile con False
+                info_tbl = mkDataConInfoTable profile con (addModuleLoc modu mn) False
                                 ptr_wds nonptr_wds
           ; let ticky_name | actually_bound = Just binder
                            | otherwise = Nothing
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 7427547bf4..0e0990b901 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -112,7 +112,7 @@ cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
 
 
 cgExpr (StgOpApp op args ty) = cgOpApp op args ty
-cgExpr (StgConApp con args _)= cgConApp con args
+cgExpr (StgConApp con mn args _) = cgConApp con mn args
 cgExpr (StgTick t e)         = cgTick t >> cgExpr e
 cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit
                                emitReturn [CmmLit cmm_lit]
@@ -187,9 +187,9 @@ cgLetNoEscapeRhsBody
     -> FCode (CgIdInfo, FCode ())
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)
   = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
-cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn _ts args)
   = cgLetNoEscapeClosure bndr local_cc cc []
-      (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $
+      (StgConApp con mn args (pprPanic "cgLetNoEscapeRhsBody" $
                            text "StgRhsCon doesn't have type args"))
         -- For a constructor RHS we want to generate a single chunk of
         -- code which can be jumped to from many places, which will
@@ -862,8 +862,8 @@ maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =
 --      Tail calls
 -----------------------------------------------------------------------------
 
-cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind
-cgConApp con stg_args
+cgConApp :: DataCon -> ConstructorNumber -> [StgArg] -> FCode ReturnKind
+cgConApp con mn stg_args
   | isUnboxedTupleDataCon con       -- Unboxed tuple: assign and return
   = do { arg_exprs <- getNonVoidArgAmodes stg_args
        ; tickyUnboxedTupleReturn (length arg_exprs)
@@ -871,7 +871,7 @@ cgConApp con stg_args
 
   | otherwise   --  Boxed constructors; allocate and return
   = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )
-    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False
+    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) mn False
                                      currentCCS con (assertNonVoidStgArgs stg_args)
                                      -- con args are always non-void,
                                      -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs
index 163f7a2a8a..fec12e16c7 100644
--- a/compiler/GHC/StgToCmm/Monad.hs
+++ b/compiler/GHC/StgToCmm/Monad.hs
@@ -93,7 +93,6 @@ import Control.Monad
 import Data.List (mapAccumL)
 
 
-
 --------------------------------------------------------
 -- The FCode monad and its types
 --
diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs
index bc10eaf4ea..8472711753 100644
--- a/compiler/GHC/StgToCmm/Utils.hs
+++ b/compiler/GHC/StgToCmm/Utils.hs
@@ -92,6 +92,10 @@ import Data.Ord
 import GHC.Types.Unique.Map
 import Data.Maybe
 import GHC.Driver.Ppr
+import qualified Data.List.NonEmpty as NE
+import GHC.Core.DataCon
+import GHC.Types.Unique.FM
+import GHC.Data.Maybe
 
 -------------------------------------------------------------------------
 --
@@ -294,7 +298,8 @@ emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
 emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
 
 emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
-emitDataCon lbl itbl ccs payload = emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload))
+emitDataCon lbl itbl ccs payload =
+  emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload))
 
 newStringCLit :: String -> FCode CmmLit
 -- Make a global definition for the string,
@@ -647,7 +652,7 @@ cmmInfoTableToInfoProvEnt this_mod cmit =
 -- | 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) =
+convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv) =
   map (\cmit ->
     let cl = cit_lbl cmit
         cn  = rtsClosureType (cit_rep cmit)
@@ -660,8 +665,15 @@ convertInfoProvMap dflags defns this_mod (InfoTableProvMap denv) =
                                 Just (ty, ss, l) -> Just (InfoProvEnt cl cn (tyString ty) this_mod (Just (ss, l)))
                                 Nothing -> Nothing
 
+        lookupDataConMap = do
+            UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation
+            -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do
+            (dc, ns) <- (hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique)
+            -- Lookup is linear but lists will be small (< 100)
+            return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (lookup n (NE.toList ns))
+
         -- 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
+    in fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns
diff --git a/compiler/GHC/Types/IPE.hs b/compiler/GHC/Types/IPE.hs
index 78c929c4db..2f4f0b35b4 100644
--- a/compiler/GHC/Types/IPE.hs
+++ b/compiler/GHC/Types/IPE.hs
@@ -1,13 +1,15 @@
-module GHC.Types.IPE(ClosureMap, InfoTableProvMap(..)
+module GHC.Types.IPE(DCMap, ClosureMap, InfoTableProvMap(..)
                     , emptyInfoTableProvMap) where
 
 import GHC.Prelude
 
 import GHC.Types.Name
 import GHC.Types.SrcLoc
+import GHC.Core.DataCon
 
 import GHC.Types.Unique.Map
 import GHC.Core.Type
+import Data.List.NonEmpty
 
 -- | A map from a 'Name' to the best approximate source position that
 -- name arose from.
@@ -17,8 +19,18 @@ type ClosureMap = UniqMap Name  -- The binding
                           -- (rendered type, source position, source note
                           -- label)
 
+-- | A map storing all the different uses of a specific data constructor and the
+-- approximate source position that usage arose from.
+-- The 'Int' is an incrementing identifier which distinguishes each usage
+-- of a constructor in a module. It is paired with the source position
+-- the constructor was used at, if possible and a string which names
+-- the source location. This is the same information as is the payload
+-- for the 'GHC.Core.SourceNote' constructor.
+type DCMap = UniqMap DataCon (NonEmpty (Int, (RealSrcSpan, String)))
+
 data InfoTableProvMap = InfoTableProvMap
-                          { provClosure :: ClosureMap }
+                          { provDC :: DCMap
+                          , provClosure :: ClosureMap }
 
 emptyInfoTableProvMap :: InfoTableProvMap
-emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap
+emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap