    {-# LANGUAGE TupleSections #-}

    -- This module contains functions which implement
    -- the -finfo-table-map and -fdistinct-constructor-tables flags
    module GHC.Stg.Debug
      ( StgDebugOpts(..)
      , collectDebugInformation
      ) where

    import GHC.Prelude

    import GHC.Stg.Syntax

    import GHC.Types.Unique.DFM
    import GHC.Types.Id
    import GHC.Types.Tickish
    import GHC.Core.DataCon
    import GHC.Types.IPE
    import GHC.Unit.Module
    import GHC.Types.Name   ( getName, getOccName, occNameFS, nameSrcSpan)
    import GHC.Data.FastString

    import Control.Monad (when)
    import Control.Monad.Trans.Reader
    import GHC.Utils.Monad.State.Strict
    import Control.Monad.Trans.Class
    import GHC.Types.SrcLoc
    import Control.Applicative
    import qualified Data.List.NonEmpty as NE
    import Data.List.NonEmpty (NonEmpty(..))

    data SpanWithLabel = SpanWithLabel RealSrcSpan LexicalFastString

    data StgDebugOpts = StgDebugOpts
      { StgDebugOpts -> Bool
    stgDebug_infoTableMap              :: !Bool
      , StgDebugOpts -> Bool
    stgDebug_distinctConstructorTables :: !Bool
      }

    data R = R { R -> StgDebugOpts
    rOpts :: StgDebugOpts, R -> ModLocation
    rModLocation :: ModLocation, R -> Maybe SpanWithLabel
    rSpan :: Maybe SpanWithLabel }

    type M a = ReaderT R (State InfoTableProvMap) a

    withSpan :: IpeSourceLocation -> M a -> M a
    withSpan :: forall a. IpeSourceLocation -> M a -> M a
    withSpan (RealSrcSpan
    new_s, LexicalFastString
    new_l) M a
    act = (R -> R) -> M a -> M a
    forall r (m :: * -> *) a.
    (r -> r) -> ReaderT r m a -> ReaderT r m a
    local R -> R
    maybe_replace M a
    act
      where
        maybe_replace :: R -> R
    maybe_replace r :: R
    r@R{ rModLocation :: R -> ModLocation
    rModLocation = ModLocation
    cur_mod, rSpan :: R -> Maybe SpanWithLabel
    rSpan = Just (SpanWithLabel RealSrcSpan
    old_s LexicalFastString
    _old_l) }
          -- prefer spans from the current module
          | String -> Maybe String
    forall a. a -> Maybe a
    Just (FastString -> String
    unpackFS (FastString -> String) -> FastString -> String
    forall a b. (a -> b) -> a -> b
    $ RealSrcSpan -> FastString
    srcSpanFile RealSrcSpan
    old_s) Maybe String -> Maybe String -> Bool
    forall a. Eq a => a -> a -> Bool
    == ModLocation -> Maybe String
    ml_hs_file ModLocation
    cur_mod
          , String -> Maybe String
    forall a. a -> Maybe a
    Just (FastString -> String
    unpackFS (FastString -> String) -> FastString -> String
    forall a b. (a -> b) -> a -> b
    $ RealSrcSpan -> FastString
    srcSpanFile RealSrcSpan
    new_s) Maybe String -> Maybe String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ModLocation -> Maybe String
    ml_hs_file ModLocation
    cur_mod
          = R
    r
        maybe_replace R
    r
          = R
    r { rSpan = Just (SpanWithLabel new_s new_l) }

    collectDebugInformation :: StgDebugOpts -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)
    collectDebugInformation :: StgDebugOpts
    -> ModLocation
    -> [StgTopBinding]
    -> ([StgTopBinding], InfoTableProvMap)
    collectDebugInformation StgDebugOpts
    opts ModLocation
    ml [StgTopBinding]
    bs =
        State InfoTableProvMap [StgTopBinding]
    -> InfoTableProvMap -> ([StgTopBinding], InfoTableProvMap)
    forall s a. State s a -> s -> (a, s)
    runState (ReaderT R (State InfoTableProvMap) [StgTopBinding]
    -> R -> State InfoTableProvMap [StgTopBinding]
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
    runReaderT ((StgTopBinding -> ReaderT R (State InfoTableProvMap) StgTopBinding)
    -> [StgTopBinding]
    -> ReaderT R (State InfoTableProvMap) [StgTopBinding]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM StgTopBinding -> ReaderT R (State InfoTableProvMap) StgTopBinding
    collectTop [StgTopBinding]
    bs) (StgDebugOpts -> ModLocation -> Maybe SpanWithLabel -> R
    R StgDebugOpts
    opts ModLocation
    ml Maybe SpanWithLabel
    forall a. Maybe a
    Nothing)) InfoTableProvMap
    emptyInfoTableProvMap

    collectTop :: StgTopBinding -> M StgTopBinding
    collectTop :: StgTopBinding -> ReaderT R (State InfoTableProvMap) StgTopBinding
    collectTop (StgTopLifted GenStgBinding 'Vanilla
    t) = GenStgBinding 'Vanilla -> StgTopBinding
    forall (pass :: StgPass).
    GenStgBinding pass -> GenStgTopBinding pass
    StgTopLifted (GenStgBinding 'Vanilla -> StgTopBinding)
    -> ReaderT R (State InfoTableProvMap) (GenStgBinding 'Vanilla)
    -> ReaderT R (State InfoTableProvMap) StgTopBinding
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GenStgBinding 'Vanilla
    -> ReaderT R (State InfoTableProvMap) (GenStgBinding 'Vanilla)
    collectStgBind GenStgBinding 'Vanilla
    t
    collectTop StgTopBinding
    tb = StgTopBinding -> ReaderT R (State InfoTableProvMap) StgTopBinding
    forall a. a -> ReaderT R (State InfoTableProvMap) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return StgTopBinding
    tb

    collectStgBind :: StgBinding -> M StgBinding
    collectStgBind :: GenStgBinding 'Vanilla
    -> ReaderT R (State InfoTableProvMap) (GenStgBinding 'Vanilla)
    collectStgBind  (StgNonRec BinderP 'Vanilla
    bndr GenStgRhs 'Vanilla
    rhs) = do
        rhs' <- Id -> GenStgRhs 'Vanilla -> M (GenStgRhs 'Vanilla)
    collectStgRhs Id
    BinderP 'Vanilla
    bndr GenStgRhs 'Vanilla
    rhs
        return (StgNonRec bndr rhs')
    collectStgBind (StgRec [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
    pairs) = do
        es <- ((Id, GenStgRhs 'Vanilla)
     -> ReaderT R (State InfoTableProvMap) (Id, GenStgRhs 'Vanilla))
    -> [(Id, GenStgRhs 'Vanilla)]
    -> ReaderT R (State InfoTableProvMap) [(Id, GenStgRhs 'Vanilla)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (\(Id
    b, GenStgRhs 'Vanilla
    e) -> (Id
    b,) (GenStgRhs 'Vanilla -> (Id, GenStgRhs 'Vanilla))
    -> M (GenStgRhs 'Vanilla)
    -> ReaderT R (State InfoTableProvMap) (Id, GenStgRhs 'Vanilla)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Id -> GenStgRhs 'Vanilla -> M (GenStgRhs 'Vanilla)
    collectStgRhs Id
    b GenStgRhs 'Vanilla
    e) [(Id, GenStgRhs 'Vanilla)]
    [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
    pairs
        return (StgRec es)

    collectStgRhs :: Id -> StgRhs -> M StgRhs
    collectStgRhs :: Id -> GenStgRhs 'Vanilla -> M (GenStgRhs 'Vanilla)
    collectStgRhs Id
    bndr GenStgRhs 'Vanilla
    rhs =
        case GenStgRhs 'Vanilla
    rhs of
          StgRhsClosure XRhsClosure 'Vanilla
    ext CostCentreStack
    cc UpdateFlag
    us [BinderP 'Vanilla]
    bs GenStgExpr 'Vanilla
    e Type
    t -> do
            e' <- M (GenStgExpr 'Vanilla) -> M (GenStgExpr 'Vanilla)
    forall a. M a -> M a
    with_span (M (GenStgExpr 'Vanilla) -> M (GenStgExpr 'Vanilla))
    -> M (GenStgExpr 'Vanilla) -> M (GenStgExpr 'Vanilla)
    forall a b. (a -> b) -> a -> b
    $ GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    collectExpr GenStgExpr 'Vanilla
    e
            recordInfo bndr e'
            return $ StgRhsClosure ext cc us bs e' t
          StgRhsCon CostCentreStack
    cc DataCon
    dc ConstructorNumber
    _mn [StgTickish]
    ticks [StgArg]
    args Type
    typ -> do
            n' <- M ConstructorNumber -> M ConstructorNumber
    forall a. M a -> M a
    with_span (M ConstructorNumber -> M ConstructorNumber)
    -> M ConstructorNumber -> M ConstructorNumber
    forall a b. (a -> b) -> a -> b
    $ DataCon -> [StgTickish] -> M ConstructorNumber
    numberDataCon DataCon
    dc [StgTickish]
    ticks
            return (StgRhsCon cc dc n' ticks args typ)
      where
        -- If the binder name has a span, use that initially as the source position
        -- in case we don't get anything better
        with_span :: M a -> M a
        with_span :: forall a. M a -> M a
    with_span =
          let name :: Name
    name = Id -> Name
    idName Id
    bndr in
          case Name -> SrcSpan
    nameSrcSpan Name
    name of
            RealSrcSpan RealSrcSpan
    pos Maybe BufSpan
    _ ->
              IpeSourceLocation -> M a -> M a
    forall a. IpeSourceLocation -> M a -> M a
    withSpan (RealSrcSpan
    pos, FastString -> LexicalFastString
    LexicalFastString (FastString -> LexicalFastString)
    -> FastString -> LexicalFastString
    forall a b. (a -> b) -> a -> b
    $ OccName -> FastString
    occNameFS (Name -> OccName
    forall a. NamedThing a => a -> OccName
    getOccName Name
    name))
            SrcSpan
    _ -> M a -> M a
    forall a. a -> a
    id

    recordInfo :: Id -> StgExpr -> M ()
    recordInfo :: Id -> GenStgExpr 'Vanilla -> M ()
    recordInfo Id
    bndr GenStgExpr 'Vanilla
    new_rhs = do
      modLoc <- (R -> ModLocation)
    -> ReaderT R (State InfoTableProvMap) ModLocation
    forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
    asks R -> ModLocation
    rModLocation
      let
        thisFile = FastString -> (String -> FastString) -> Maybe String -> FastString
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe FastString
    nilFS String -> FastString
    mkFastString (Maybe String -> FastString) -> Maybe String -> FastString
    forall a b. (a -> b) -> a -> b
    $ ModLocation -> Maybe String
    ml_hs_file ModLocation
    modLoc
        -- A span from the ticks surrounding the new_rhs
        best_span = FastString -> GenStgExpr 'Vanilla -> Maybe SpanWithLabel
    quickSourcePos FastString
    thisFile GenStgExpr 'Vanilla
    new_rhs
        -- A back-up span if the bndr had a source position, many do not (think internally generated ids)
        bndr_span = (\RealSrcSpan
    s -> RealSrcSpan -> LexicalFastString -> SpanWithLabel
    SpanWithLabel RealSrcSpan
    s (FastString -> LexicalFastString
    LexicalFastString (FastString -> LexicalFastString)
    -> FastString -> LexicalFastString
    forall a b. (a -> b) -> a -> b
    $ OccName -> FastString
    occNameFS (Id -> OccName
    forall a. NamedThing a => a -> OccName
    getOccName Id
    bndr)))
                      (RealSrcSpan -> SpanWithLabel)
    -> Maybe RealSrcSpan -> Maybe SpanWithLabel
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> SrcSpan -> Maybe RealSrcSpan
    srcSpanToRealSrcSpan (Name -> SrcSpan
    nameSrcSpan (Id -> Name
    forall a. NamedThing a => a -> Name
    getName Id
    bndr))
      recordStgIdPosition bndr best_span bndr_span

    collectExpr :: StgExpr -> M StgExpr
    collectExpr :: GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    collectExpr = GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    go
      where
        go :: GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    go (StgApp Id
    occ [StgArg]
    as) = GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    forall a. a -> ReaderT R (State InfoTableProvMap) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla))
    -> GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    forall a b. (a -> b) -> a -> b
    $ Id -> [StgArg] -> GenStgExpr 'Vanilla
    forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
    StgApp Id
    occ [StgArg]
    as
        go (StgLit Literal
    lit) = GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    forall a. a -> ReaderT R (State InfoTableProvMap) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla))
    -> GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    forall a b. (a -> b) -> a -> b
    $ Literal -> GenStgExpr 'Vanilla
    forall (pass :: StgPass). Literal -> GenStgExpr pass
    StgLit Literal
    lit
        go (StgConApp DataCon
    dc ConstructorNumber
    _mn [StgArg]
    as [[PrimRep]]
    tys) = do
          n' <- DataCon -> [StgTickish] -> M ConstructorNumber
    numberDataCon DataCon
    dc []
          return (StgConApp dc n' as tys)
        go (StgOpApp StgOp
    op [StgArg]
    as Type
    ty) = GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    forall a. a -> ReaderT R (State InfoTableProvMap) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (StgOp -> [StgArg] -> Type -> GenStgExpr 'Vanilla
    forall (pass :: StgPass).
    StgOp -> [StgArg] -> Type -> GenStgExpr pass
    StgOpApp StgOp
    op [StgArg]
    as Type
    ty)
        go (StgCase GenStgExpr 'Vanilla
    scrut BinderP 'Vanilla
    bndr AltType
    ty [GenStgAlt 'Vanilla]
    alts) =
          GenStgExpr 'Vanilla
    -> Id -> AltType -> [GenStgAlt 'Vanilla] -> GenStgExpr 'Vanilla
    GenStgExpr 'Vanilla
    -> BinderP 'Vanilla
    -> AltType
    -> [GenStgAlt 'Vanilla]
    -> GenStgExpr 'Vanilla
    forall (pass :: StgPass).
    GenStgExpr pass
    -> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
    StgCase (GenStgExpr 'Vanilla
     -> Id -> AltType -> [GenStgAlt 'Vanilla] -> GenStgExpr 'Vanilla)
    -> M (GenStgExpr 'Vanilla)
    -> ReaderT
         R
         (State InfoTableProvMap)
         (Id -> AltType -> [GenStgAlt 'Vanilla] -> GenStgExpr 'Vanilla)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    collectExpr GenStgExpr 'Vanilla
    scrut ReaderT
      R
      (State InfoTableProvMap)
      (Id -> AltType -> [GenStgAlt 'Vanilla] -> GenStgExpr 'Vanilla)
    -> ReaderT R (State InfoTableProvMap) Id
    -> ReaderT
         R
         (State InfoTableProvMap)
         (AltType -> [GenStgAlt 'Vanilla] -> GenStgExpr 'Vanilla)
    forall a b.
    ReaderT R (State InfoTableProvMap) (a -> b)
    -> ReaderT R (State InfoTableProvMap) a
    -> ReaderT R (State InfoTableProvMap) b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Id -> ReaderT R (State InfoTableProvMap) Id
    forall a. a -> ReaderT R (State InfoTableProvMap) a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Id
    BinderP 'Vanilla
    bndr ReaderT
      R
      (State InfoTableProvMap)
      (AltType -> [GenStgAlt 'Vanilla] -> GenStgExpr 'Vanilla)
    -> ReaderT R (State InfoTableProvMap) AltType
    -> ReaderT
         R
         (State InfoTableProvMap)
         ([GenStgAlt 'Vanilla] -> GenStgExpr 'Vanilla)
    forall a b.
    ReaderT R (State InfoTableProvMap) (a -> b)
    -> ReaderT R (State InfoTableProvMap) a
    -> ReaderT R (State InfoTableProvMap) b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> AltType -> ReaderT R (State InfoTableProvMap) AltType
    forall a. a -> ReaderT R (State InfoTableProvMap) a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure AltType
    ty ReaderT
      R
      (State InfoTableProvMap)
      ([GenStgAlt 'Vanilla] -> GenStgExpr 'Vanilla)
    -> ReaderT R (State InfoTableProvMap) [GenStgAlt 'Vanilla]
    -> M (GenStgExpr 'Vanilla)
    forall a b.
    ReaderT R (State InfoTableProvMap) (a -> b)
    -> ReaderT R (State InfoTableProvMap) a
    -> ReaderT R (State InfoTableProvMap) b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> (GenStgAlt 'Vanilla
     -> ReaderT R (State InfoTableProvMap) (GenStgAlt 'Vanilla))
    -> [GenStgAlt 'Vanilla]
    -> ReaderT R (State InfoTableProvMap) [GenStgAlt 'Vanilla]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM GenStgAlt 'Vanilla
    -> ReaderT R (State InfoTableProvMap) (GenStgAlt 'Vanilla)
    collectAlt [GenStgAlt 'Vanilla]
    alts
        go (StgLet XLet 'Vanilla
    ext GenStgBinding 'Vanilla
    bind GenStgExpr 'Vanilla
    body) = do
            bind' <- GenStgBinding 'Vanilla
    -> ReaderT R (State InfoTableProvMap) (GenStgBinding 'Vanilla)
    collectStgBind GenStgBinding 'Vanilla
    bind
            body' <- go body
            return (StgLet ext bind' body')
        go (StgLetNoEscape XLetNoEscape 'Vanilla
    ext GenStgBinding 'Vanilla
    bind GenStgExpr 'Vanilla
    body) = do
            bind' <- GenStgBinding 'Vanilla
    -> ReaderT R (State InfoTableProvMap) (GenStgBinding 'Vanilla)
    collectStgBind GenStgBinding 'Vanilla
    bind
            body' <- go body
            return (StgLetNoEscape ext bind' body')

        go (StgTick StgTickish
    tick GenStgExpr 'Vanilla
    e) = do
           let k :: M (GenStgExpr 'Vanilla) -> M (GenStgExpr 'Vanilla)
    k = case StgTickish
    tick of
                    SourceNote RealSrcSpan
    ss LexicalFastString
    fp -> IpeSourceLocation
    -> M (GenStgExpr 'Vanilla) -> M (GenStgExpr 'Vanilla)
    forall a. IpeSourceLocation -> M a -> M a
    withSpan (RealSrcSpan
    ss, LexicalFastString
    fp)
                    StgTickish
    _ -> M (GenStgExpr 'Vanilla) -> M (GenStgExpr 'Vanilla)
    forall a. a -> a
    id
           e' <- M (GenStgExpr 'Vanilla) -> M (GenStgExpr 'Vanilla)
    k (GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    go GenStgExpr 'Vanilla
    e)
           return (StgTick tick e')

    collectAlt :: StgAlt -> M StgAlt
    collectAlt :: GenStgAlt 'Vanilla
    -> ReaderT R (State InfoTableProvMap) (GenStgAlt 'Vanilla)
    collectAlt GenStgAlt 'Vanilla
    alt = do e' <- GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    collectExpr (GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla))
    -> GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
    forall a b. (a -> b) -> a -> b
    $ GenStgAlt 'Vanilla -> GenStgExpr 'Vanilla
    forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
    alt_rhs GenStgAlt 'Vanilla
    alt
                        return $! alt { alt_rhs = e' }

    -- | Try to find the best source position surrounding a 'StgExpr'. The
    -- heuristic strips ticks from the current expression until it finds one which
    -- is from the module currently being compiled. This is the same method that
    -- the DWARF information uses to give locations to info tables.
    --
    -- It is usually a better alternative than using the 'RealSrcSpan' which is carefully
    -- propagated downwards by 'withSpan'. It's "quick" because it works only using immediate context rather
    -- than looking at the parent context like 'withSpan'
    quickSourcePos :: FastString -> StgExpr -> Maybe SpanWithLabel
    quickSourcePos :: FastString -> GenStgExpr 'Vanilla -> Maybe SpanWithLabel
    quickSourcePos FastString
    cur_mod (StgTick (SourceNote RealSrcSpan
    ss LexicalFastString
    m) GenStgExpr 'Vanilla
    e)
      | RealSrcSpan -> FastString
    srcSpanFile RealSrcSpan
    ss FastString -> FastString -> Bool
    forall a. Eq a => a -> a -> Bool
    == FastString
    cur_mod = SpanWithLabel -> Maybe SpanWithLabel
    forall a. a -> Maybe a
    Just (RealSrcSpan -> LexicalFastString -> SpanWithLabel
    SpanWithLabel RealSrcSpan
    ss LexicalFastString
    m)
      | Bool
    otherwise = FastString -> GenStgExpr 'Vanilla -> Maybe SpanWithLabel
    quickSourcePos FastString
    cur_mod GenStgExpr 'Vanilla
    e
    quickSourcePos FastString
    _ GenStgExpr 'Vanilla
    _ = Maybe SpanWithLabel
    forall a. Maybe a
    Nothing

    recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M ()
    recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M ()
    recordStgIdPosition Id
    id Maybe SpanWithLabel
    best_span Maybe SpanWithLabel
    ss = do
      opts <- (R -> StgDebugOpts)
    -> ReaderT R (State InfoTableProvMap) StgDebugOpts
    forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
    asks R -> StgDebugOpts
    rOpts
      when (stgDebug_infoTableMap opts) $ do
        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)
        let mbspan = (\(SpanWithLabel RealSrcSpan
    rss LexicalFastString
    d) -> (RealSrcSpan
    rss, LexicalFastString
    d)) (SpanWithLabel -> IpeSourceLocation)
    -> Maybe SpanWithLabel -> Maybe IpeSourceLocation
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Maybe SpanWithLabel
    best_span Maybe SpanWithLabel -> Maybe SpanWithLabel -> Maybe SpanWithLabel
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Maybe SpanWithLabel
    cc Maybe SpanWithLabel -> Maybe SpanWithLabel -> Maybe SpanWithLabel
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Maybe SpanWithLabel
    ss)
        lift $ modify (\InfoTableProvMap
    env -> InfoTableProvMap
    env { provClosure = addToUDFM (provClosure env) (idName id) (idName id, (idType id, mbspan)) })

    numberDataCon :: DataCon -> [StgTickish] -> M ConstructorNumber
    -- Unboxed tuples and sums do not allocate so they
    -- have no info tables.
    numberDataCon :: DataCon -> [StgTickish] -> M ConstructorNumber
    numberDataCon DataCon
    dc [StgTickish]
    _ | DataCon -> Bool
    isUnboxedTupleDataCon DataCon
    dc = ConstructorNumber -> M ConstructorNumber
    forall a. a -> ReaderT R (State InfoTableProvMap) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ConstructorNumber
    NoNumber
    numberDataCon DataCon
    dc [StgTickish]
    _ | DataCon -> Bool
    isUnboxedSumDataCon DataCon
    dc = ConstructorNumber -> M ConstructorNumber
    forall a. a -> ReaderT R (State InfoTableProvMap) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ConstructorNumber
    NoNumber
    numberDataCon DataCon
    dc [StgTickish]
    ts = do
      opts <- (R -> StgDebugOpts)
    -> ReaderT R (State InfoTableProvMap) StgDebugOpts
    forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
    asks R -> StgDebugOpts
    rOpts
      if not (stgDebug_distinctConstructorTables opts) then return NoNumber else do
        env <- lift get
        mcc <- asks rSpan
        let !mbest_span = (\(SpanWithLabel RealSrcSpan
    rss LexicalFastString
    l) -> (RealSrcSpan
    rss, LexicalFastString
    l)) (SpanWithLabel -> IpeSourceLocation)
    -> Maybe SpanWithLabel -> Maybe IpeSourceLocation
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ([StgTickish] -> Maybe SpanWithLabel
    selectTick [StgTickish]
    ts Maybe SpanWithLabel -> Maybe SpanWithLabel -> Maybe SpanWithLabel
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Maybe SpanWithLabel
    mcc)
        let !dcMap' = (Maybe (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
     -> Maybe (DataCon, NonEmpty (Int, Maybe IpeSourceLocation)))
    -> UniqDFM
         DataCon (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    -> DataCon
    -> UniqDFM
         DataCon (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    forall key elt.
    Uniquable key =>
    (Maybe elt -> Maybe elt)
    -> UniqDFM key elt -> key -> UniqDFM key elt
    alterUDFM (Maybe (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    -> ((DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
        -> Maybe (DataCon, NonEmpty (Int, Maybe IpeSourceLocation)))
    -> Maybe (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    -> Maybe (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe ((DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    -> Maybe (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    forall a. a -> Maybe a
    Just (DataCon
    dc, (Int
    0, Maybe IpeSourceLocation
    mbest_span) (Int, Maybe IpeSourceLocation)
    -> [(Int, Maybe IpeSourceLocation)]
    -> NonEmpty (Int, Maybe IpeSourceLocation)
    forall a. a -> [a] -> NonEmpty a
    :| [] ))
                            (\(DataCon
    _dc, xs :: NonEmpty (Int, Maybe IpeSourceLocation)
    xs@((Int
    k, Maybe IpeSourceLocation
    _):|[(Int, Maybe IpeSourceLocation)]
    _)) -> (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    -> Maybe (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    forall a. a -> Maybe a
    Just ((DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
     -> Maybe (DataCon, NonEmpty (Int, Maybe IpeSourceLocation)))
    -> (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    -> Maybe (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    forall a b. (a -> b) -> a -> b
    $! (DataCon
    dc, (Int
    k Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1, Maybe IpeSourceLocation
    mbest_span) (Int, Maybe IpeSourceLocation)
    -> NonEmpty (Int, Maybe IpeSourceLocation)
    -> NonEmpty (Int, Maybe IpeSourceLocation)
    forall a. a -> NonEmpty a -> NonEmpty a
    `NE.cons` NonEmpty (Int, Maybe IpeSourceLocation)
    xs))) (InfoTableProvMap
    -> UniqDFM
         DataCon (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    provDC InfoTableProvMap
    env) DataCon
    dc
        lift $ put (env { provDC = dcMap' })
        let r = UniqDFM DataCon (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    -> DataCon
    -> Maybe (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    forall key elt.
    Uniquable key =>
    UniqDFM key elt -> key -> Maybe elt
    lookupUDFM UniqDFM DataCon (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    dcMap' DataCon
    dc
        return $ case r of
          Maybe (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
    Nothing -> ConstructorNumber
    NoNumber
          Just (DataCon
    _, NonEmpty (Int, Maybe IpeSourceLocation)
    res) -> Int -> ConstructorNumber
    Numbered ((Int, Maybe IpeSourceLocation) -> Int
    forall a b. (a, b) -> a
    fst (NonEmpty (Int, Maybe IpeSourceLocation)
    -> (Int, Maybe IpeSourceLocation)
    forall a. NonEmpty a -> a
    NE.head NonEmpty (Int, Maybe IpeSourceLocation)
    res))

    selectTick :: [StgTickish] -> Maybe SpanWithLabel
    selectTick :: [StgTickish] -> Maybe SpanWithLabel
    selectTick [] = Maybe SpanWithLabel
    forall a. Maybe a
    Nothing
    selectTick (SourceNote RealSrcSpan
    rss LexicalFastString
    d : [StgTickish]
    ts ) = [StgTickish] -> Maybe SpanWithLabel
    selectTick [StgTickish]
    ts Maybe SpanWithLabel -> Maybe SpanWithLabel -> Maybe SpanWithLabel
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> SpanWithLabel -> Maybe SpanWithLabel
    forall a. a -> Maybe a
    Just (RealSrcSpan -> LexicalFastString -> SpanWithLabel
    SpanWithLabel RealSrcSpan
    rss LexicalFastString
    d)
    selectTick (StgTickish
    _:[StgTickish]
    ts) = [StgTickish] -> Maybe SpanWithLabel
    selectTick [StgTickish]
    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.

    The info table map is also used to generate stacktraces.
    See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]
    for details.

    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 GHC.Driver.GenerateCgIPEStub, the actually used info tables are collected after the
       Cmm pipeline. 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. Additionally, info tables of
       return frames (used to create stacktraces) are generated in the Cmm pipeline and aren't
       available before.
    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.
    3. Stack represented info tables (return frames) to an approximated source location
       of the call that pushed a continuation on the stacks.

    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.

    -- GenerateCgIPEStub

    The info tables which are actually used in the generated program are collected after
    the Cmm pipeline. `initInfoTableProv` is used to create a CStub, that initializes the
    map in C code.

    This step has to be done after the Cmm pipeline to make sure that all info tables are
    really used and, even more importantly, return frame info tables are generated by the
    pipeline.

    -- 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 usage of a data constructor was
    contributing primarily to the allocation in a program. Using the `-fdistinct-constructor-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.

    -}