{-# 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.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.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 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
    GenStgRhs 'Vanilla
rhs' <- Id -> GenStgRhs 'Vanilla -> M (GenStgRhs 'Vanilla)
collectStgRhs Id
BinderP 'Vanilla
bndr GenStgRhs 'Vanilla
rhs
    GenStgBinding 'Vanilla
-> ReaderT R (State InfoTableProvMap) (GenStgBinding 'Vanilla)
forall a. a -> ReaderT R (State InfoTableProvMap) a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinderP 'Vanilla -> GenStgRhs 'Vanilla -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec BinderP 'Vanilla
bndr GenStgRhs 'Vanilla
rhs')
collectStgBind (StgRec [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
pairs) = do
    [(Id, GenStgRhs 'Vanilla)]
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
    GenStgBinding 'Vanilla
-> ReaderT R (State InfoTableProvMap) (GenStgBinding 'Vanilla)
forall a. a -> ReaderT R (State InfoTableProvMap) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(BinderP 'Vanilla, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec [(Id, GenStgRhs 'Vanilla)]
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
es)

collectStgRhs :: Id -> StgRhs -> M StgRhs
collectStgRhs :: Id -> GenStgRhs 'Vanilla -> M (GenStgRhs 'Vanilla)
collectStgRhs Id
bndr (StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
cc UpdateFlag
us [BinderP 'Vanilla]
bs GenStgExpr 'Vanilla
e Type
t) = do
  let
    name :: Name
name = Id -> Name
idName Id
bndr
    -- If the name has a span, use that initially as the source position in-case
    -- we don't get anything better.
    with_span :: M (GenStgExpr 'Vanilla) -> M (GenStgExpr 'Vanilla)
with_span = case Name -> SrcSpan
nameSrcSpan Name
name of
                  RealSrcSpan RealSrcSpan
pos Maybe BufSpan
_ -> IpeSourceLocation
-> M (GenStgExpr 'Vanilla) -> M (GenStgExpr 'Vanilla)
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 (GenStgExpr 'Vanilla) -> M (GenStgExpr 'Vanilla)
forall a. a -> a
id
  GenStgExpr 'Vanilla
e' <- M (GenStgExpr 'Vanilla) -> M (GenStgExpr 'Vanilla)
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
  Id -> GenStgExpr 'Vanilla -> M ()
recordInfo Id
bndr GenStgExpr 'Vanilla
e'
  GenStgRhs 'Vanilla -> M (GenStgRhs 'Vanilla)
forall a. a -> ReaderT R (State InfoTableProvMap) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgRhs 'Vanilla -> M (GenStgRhs 'Vanilla))
-> GenStgRhs 'Vanilla -> M (GenStgRhs 'Vanilla)
forall a b. (a -> b) -> a -> b
$ XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> Type
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> Type
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
cc UpdateFlag
us [BinderP 'Vanilla]
bs GenStgExpr 'Vanilla
e' Type
t
collectStgRhs Id
_bndr (StgRhsCon CostCentreStack
cc DataCon
dc ConstructorNumber
_mn [StgTickish]
ticks [StgArg]
args Type
typ) = do
  ConstructorNumber
n' <- DataCon -> [StgTickish] -> M ConstructorNumber
numberDataCon DataCon
dc [StgTickish]
ticks
  GenStgRhs 'Vanilla -> M (GenStgRhs 'Vanilla)
forall a. a -> ReaderT R (State InfoTableProvMap) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> Type
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> Type
-> GenStgRhs pass
StgRhsCon CostCentreStack
cc DataCon
dc ConstructorNumber
n' [StgTickish]
ticks [StgArg]
args Type
typ)


recordInfo :: Id -> StgExpr -> M ()
recordInfo :: Id -> GenStgExpr 'Vanilla -> M ()
recordInfo Id
bndr GenStgExpr 'Vanilla
new_rhs = do
  ModLocation
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
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 :: Maybe SpanWithLabel
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 :: Maybe SpanWithLabel
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))
  Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M ()
recordStgIdPosition Id
bndr Maybe SpanWithLabel
best_span Maybe SpanWithLabel
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 [Type]
tys) = do
      ConstructorNumber
n' <- DataCon -> [StgTickish] -> M ConstructorNumber
numberDataCon DataCon
dc []
      GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
forall a. a -> ReaderT R (State InfoTableProvMap) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
n' [StgArg]
as [Type]
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
        GenStgBinding 'Vanilla
bind' <- GenStgBinding 'Vanilla
-> ReaderT R (State InfoTableProvMap) (GenStgBinding 'Vanilla)
collectStgBind GenStgBinding 'Vanilla
bind
        GenStgExpr 'Vanilla
body' <- GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
go GenStgExpr 'Vanilla
body
        GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
forall a. a -> ReaderT R (State InfoTableProvMap) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
ext GenStgBinding 'Vanilla
bind' GenStgExpr 'Vanilla
body')
    go (StgLetNoEscape XLetNoEscape 'Vanilla
ext GenStgBinding 'Vanilla
bind GenStgExpr 'Vanilla
body) = do
        GenStgBinding 'Vanilla
bind' <- GenStgBinding 'Vanilla
-> ReaderT R (State InfoTableProvMap) (GenStgBinding 'Vanilla)
collectStgBind GenStgBinding 'Vanilla
bind
        GenStgExpr 'Vanilla
body' <- GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
go GenStgExpr 'Vanilla
body
        GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
forall a. a -> ReaderT R (State InfoTableProvMap) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLetNoEscape 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'Vanilla
ext GenStgBinding 'Vanilla
bind' GenStgExpr 'Vanilla
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
       GenStgExpr 'Vanilla
e' <- M (GenStgExpr 'Vanilla) -> M (GenStgExpr 'Vanilla)
k (GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
go GenStgExpr 'Vanilla
e)
       GenStgExpr 'Vanilla -> M (GenStgExpr 'Vanilla)
forall a. a -> ReaderT R (State InfoTableProvMap) a
forall (m :: * -> *) a. Monad m => a -> m a
return (StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
tick GenStgExpr 'Vanilla
e')

collectAlt :: StgAlt -> M StgAlt
collectAlt :: GenStgAlt 'Vanilla
-> ReaderT R (State InfoTableProvMap) (GenStgAlt 'Vanilla)
collectAlt GenStgAlt 'Vanilla
alt = do GenStgExpr 'Vanilla
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
                    GenStgAlt 'Vanilla
-> ReaderT R (State InfoTableProvMap) (GenStgAlt 'Vanilla)
forall a. a -> ReaderT R (State InfoTableProvMap) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgAlt 'Vanilla
 -> ReaderT R (State InfoTableProvMap) (GenStgAlt 'Vanilla))
-> GenStgAlt 'Vanilla
-> ReaderT R (State InfoTableProvMap) (GenStgAlt 'Vanilla)
forall a b. (a -> b) -> a -> b
$! GenStgAlt 'Vanilla
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
  StgDebugOpts
opts <- (R -> StgDebugOpts)
-> ReaderT R (State InfoTableProvMap) StgDebugOpts
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks R -> StgDebugOpts
rOpts
  Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StgDebugOpts -> Bool
stgDebug_infoTableMap StgDebugOpts
opts) (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe SpanWithLabel
cc <- (R -> Maybe SpanWithLabel)
-> ReaderT R (State InfoTableProvMap) (Maybe SpanWithLabel)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks R -> Maybe SpanWithLabel
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 :: Maybe IpeSourceLocation
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)
    State InfoTableProvMap () -> M ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT R m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State InfoTableProvMap () -> M ())
-> State InfoTableProvMap () -> M ()
forall a b. (a -> b) -> a -> b
$ (InfoTableProvMap -> InfoTableProvMap) -> State InfoTableProvMap ()
forall s. (s -> s) -> State s ()
modify (\InfoTableProvMap
env -> InfoTableProvMap
env { provClosure = addToUniqMap (provClosure env) (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
  StgDebugOpts
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 Bool -> Bool
not (StgDebugOpts -> Bool
stgDebug_distinctConstructorTables StgDebugOpts
opts) then ConstructorNumber -> M ConstructorNumber
forall a. a -> ReaderT R (State InfoTableProvMap) a
forall (m :: * -> *) a. Monad m => a -> m a
return ConstructorNumber
NoNumber else do
    InfoTableProvMap
env <- State InfoTableProvMap InfoTableProvMap
-> ReaderT R (State InfoTableProvMap) InfoTableProvMap
forall (m :: * -> *) a. Monad m => m a -> ReaderT R m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift State InfoTableProvMap InfoTableProvMap
forall s. State s s
get
    Maybe SpanWithLabel
mcc <- (R -> Maybe SpanWithLabel)
-> ReaderT R (State InfoTableProvMap) (Maybe SpanWithLabel)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks R -> Maybe SpanWithLabel
rSpan
    let !mbest_span :: Maybe IpeSourceLocation
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' :: UniqMap DataCon (NonEmpty (Int, Maybe IpeSourceLocation))
dcMap' = (Maybe (NonEmpty (Int, Maybe IpeSourceLocation))
 -> Maybe (NonEmpty (Int, Maybe IpeSourceLocation)))
-> UniqMap DataCon (NonEmpty (Int, Maybe IpeSourceLocation))
-> DataCon
-> UniqMap DataCon (NonEmpty (Int, Maybe IpeSourceLocation))
forall k a.
Uniquable k =>
(Maybe a -> Maybe a) -> UniqMap k a -> k -> UniqMap k a
alterUniqMap (Maybe (NonEmpty (Int, Maybe IpeSourceLocation))
-> (NonEmpty (Int, Maybe IpeSourceLocation)
    -> Maybe (NonEmpty (Int, Maybe IpeSourceLocation)))
-> Maybe (NonEmpty (Int, Maybe IpeSourceLocation))
-> Maybe (NonEmpty (Int, Maybe IpeSourceLocation))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NonEmpty (Int, Maybe IpeSourceLocation)
-> Maybe (NonEmpty (Int, Maybe IpeSourceLocation))
forall a. a -> Maybe a
Just ((Int
0, Maybe IpeSourceLocation
mbest_span) (Int, Maybe IpeSourceLocation)
-> [(Int, Maybe IpeSourceLocation)]
-> NonEmpty (Int, Maybe IpeSourceLocation)
forall a. a -> [a] -> NonEmpty a
:| [] ))
                        (\xs :: NonEmpty (Int, Maybe IpeSourceLocation)
xs@((Int
k, Maybe IpeSourceLocation
_):|[(Int, Maybe IpeSourceLocation)]
_) -> NonEmpty (Int, Maybe IpeSourceLocation)
-> Maybe (NonEmpty (Int, Maybe IpeSourceLocation))
forall a. a -> Maybe a
Just (NonEmpty (Int, Maybe IpeSourceLocation)
 -> Maybe (NonEmpty (Int, Maybe IpeSourceLocation)))
-> NonEmpty (Int, Maybe IpeSourceLocation)
-> Maybe (NonEmpty (Int, Maybe IpeSourceLocation))
forall a b. (a -> b) -> a -> b
$! ((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
-> UniqMap DataCon (NonEmpty (Int, Maybe IpeSourceLocation))
provDC InfoTableProvMap
env) DataCon
dc
    State InfoTableProvMap () -> M ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT R m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State InfoTableProvMap () -> M ())
-> State InfoTableProvMap () -> M ()
forall a b. (a -> b) -> a -> b
$ InfoTableProvMap -> State InfoTableProvMap ()
forall s. s -> State s ()
put (InfoTableProvMap
env { provDC = dcMap' })
    let r :: Maybe (NonEmpty (Int, Maybe IpeSourceLocation))
r = UniqMap DataCon (NonEmpty (Int, Maybe IpeSourceLocation))
-> DataCon -> Maybe (NonEmpty (Int, Maybe IpeSourceLocation))
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap DataCon (NonEmpty (Int, Maybe IpeSourceLocation))
dcMap' DataCon
dc
    ConstructorNumber -> M ConstructorNumber
forall a. a -> ReaderT R (State InfoTableProvMap) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorNumber -> M ConstructorNumber)
-> ConstructorNumber -> M ConstructorNumber
forall a b. (a -> b) -> a -> b
$ case Maybe (NonEmpty (Int, Maybe IpeSourceLocation))
r of
      Maybe (NonEmpty (Int, Maybe IpeSourceLocation))
Nothing -> ConstructorNumber
NoNumber
      Just 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 contiunation 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-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.

-}