{-# LANGUAGE TupleSections #-}
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) }
| 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
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
best_span = FastString -> GenStgExpr 'Vanilla -> Maybe SpanWithLabel
quickSourcePos FastString
thisFile GenStgExpr 'Vanilla
new_rhs
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' }
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
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
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