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.

11 files changed, 175 insertions, 44 deletions

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