{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MultiWayIf #-}
module GHC.StgToCmm.Ticky (
withNewTickyCounterFun,
withNewTickyCounterLNE,
withNewTickyCounterThunk,
withNewTickyCounterStdThunk,
withNewTickyCounterCon,
emitTickyCounterTag,
tickyDynAlloc,
tickyAllocHeap,
tickyAllocPrim,
tickyAllocThunk,
tickyAllocPAP,
tickyHeapCheck,
tickyStackCheck,
tickyDirectCall,
tickyPushUpdateFrame,
tickyUpdateFrameOmitted,
tickyEnterDynCon,
tickyEnterFun,
tickyEnterThunk,
tickyEnterLNE,
tickyUpdateBhCaf,
tickyUnboxedTupleReturn,
tickyReturnOldCon, tickyReturnNewCon,
tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
tickySlowCall, tickySlowCallPat,
tickyTagged, tickyUntagged, tickyTagSkip
) where
import GHC.Prelude
import GHC.Platform
import GHC.Platform.Profile
import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString )
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Config
import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall )
import GHC.StgToCmm.Lit ( newStringCLit )
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
import GHC.Stg.Syntax
import GHC.Cmm.Expr
import GHC.Cmm.Graph
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Runtime.Heap.Layout
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.Basic
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Monad (whenM)
import GHC.Builtin.Names
import GHC.Tc.Utils.TcType
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Predicate
import Data.Maybe
import qualified Data.Char
import Control.Monad ( when, unless )
import GHC.Types.Id.Info
import GHC.StgToCmm.Env (getCgInfo_maybe)
import Data.Coerce (coerce)
import GHC.Utils.Json
tickyArgArity :: TickyClosureType -> Int
tickyArgArity :: TickyClosureType -> Int
tickyArgArity (TickyFun Bool
_ [NonVoid Id]
_fvs [NonVoid Id]
args) = [NonVoid Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NonVoid Id]
args
tickyArgArity (TickyLNE [NonVoid Id]
args) = [NonVoid Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NonVoid Id]
args
tickyArgArity (TickyCon{}) = Int
0
tickyArgArity (TickyThunk{}) = Int
0
tickyArgDesc :: TickyClosureType -> String
tickyArgDesc :: TickyClosureType -> String
tickyArgDesc TickyClosureType
arg_info =
case TickyClosureType
arg_info of
TickyFun Bool
_ [NonVoid Id]
_fvs [NonVoid Id]
args -> (NonVoid Id -> Char) -> [NonVoid Id] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Char
showTypeCategory (Type -> Char) -> (NonVoid Id -> Type) -> NonVoid Id -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType (Id -> Type) -> (NonVoid Id -> Id) -> NonVoid Id -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonVoid Id -> Id
forall a. NonVoid a -> a
fromNonVoid) [NonVoid Id]
args
TickyLNE [NonVoid Id]
args -> (NonVoid Id -> Char) -> [NonVoid Id] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Char
showTypeCategory (Type -> Char) -> (NonVoid Id -> Type) -> NonVoid Id -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType (Id -> Type) -> (NonVoid Id -> Id) -> NonVoid Id -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonVoid Id -> Id
forall a. NonVoid a -> a
fromNonVoid) [NonVoid Id]
args
TickyThunk{} -> String
""
TickyCon{} -> String
""
tickyFvDesc :: TickyClosureType -> String
tickyFvDesc :: TickyClosureType -> String
tickyFvDesc TickyClosureType
arg_info =
case TickyClosureType
arg_info of
TickyFun Bool
_ [NonVoid Id]
fvs [NonVoid Id]
_args -> (NonVoid Id -> Char) -> [NonVoid Id] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Char
showTypeCategory (Type -> Char) -> (NonVoid Id -> Type) -> NonVoid Id -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType (Id -> Type) -> (NonVoid Id -> Id) -> NonVoid Id -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonVoid Id -> Id
forall a. NonVoid a -> a
fromNonVoid) [NonVoid Id]
fvs
TickyLNE{} -> String
""
TickyThunk Bool
_ Bool
_ [StgArg]
fvs -> (StgArg -> Char) -> [StgArg] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Char
showTypeCategory (Type -> Char) -> (StgArg -> Type) -> StgArg -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> Type
stgArgType) [StgArg]
fvs
TickyCon{} -> String
""
instance ToJson TickyClosureType where
json :: TickyClosureType -> JsonDoc
json TickyClosureType
info = case TickyClosureType
info of
(TickyFun {}) -> String -> String -> String -> JsonDoc
mkInfo (TickyClosureType -> String
tickyFvDesc TickyClosureType
info) (TickyClosureType -> String
tickyArgDesc TickyClosureType
info) String
"fun"
(TickyLNE {}) -> String -> String -> String -> JsonDoc
mkInfo [] (TickyClosureType -> String
tickyArgDesc TickyClosureType
info) String
"lne"
(TickyThunk Bool
uf Bool
_ [StgArg]
_) -> String -> String -> String -> JsonDoc
mkInfo (TickyClosureType -> String
tickyFvDesc TickyClosureType
info) [] (String
"thk" String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
uf then String
"_u" else String
"")
(TickyCon{}) -> String -> String -> String -> JsonDoc
mkInfo [] [] String
"con"
where
mkInfo :: String -> String -> String -> JsonDoc
mkInfo :: String -> String -> String -> JsonDoc
mkInfo String
fvs String
args String
ty =
[(String, JsonDoc)] -> JsonDoc
JSObject
[(String
"type", String -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json String
"entCntr")
,(String
"subTy", String -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json String
ty)
,(String
"fvs_c", Int -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
fvs))
,(String
"fvs" , String -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json String
fvs)
,(String
"args", String -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json String
args)
]
tickyEntryDescJson :: (SDocContext -> TickyClosureType -> String)
tickyEntryDescJson :: SDocContext -> TickyClosureType -> String
tickyEntryDescJson SDocContext
ctxt = SDocContext -> SDoc -> String
renderWithContext SDocContext
ctxt (SDoc -> String)
-> (TickyClosureType -> SDoc) -> TickyClosureType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonDoc -> SDoc
renderJSON (JsonDoc -> SDoc)
-> (TickyClosureType -> JsonDoc) -> TickyClosureType -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TickyClosureType -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json
data TickyClosureType
= TickyFun
Bool
[NonVoid Id]
[NonVoid Id]
| TickyCon
DataCon
ConstructorNumber
| TickyThunk
Bool
Bool
[StgArg]
| TickyLNE
[NonVoid Id]
withNewTickyCounterFun :: Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterFun :: forall a.
Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterFun Bool
single_entry Id
f [NonVoid Id]
fvs [NonVoid Id]
args = TickyClosureType -> Id -> FCode a -> FCode a
forall a. TickyClosureType -> Id -> FCode a -> FCode a
withNewTickyCounter (Bool -> [NonVoid Id] -> [NonVoid Id] -> TickyClosureType
TickyFun Bool
single_entry [NonVoid Id]
fvs [NonVoid Id]
args) Id
f
withNewTickyCounterLNE :: Id -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterLNE :: forall a. Id -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterLNE Id
nm [NonVoid Id]
args FCode a
code = do
Bool
b <- (StgToCmmConfig -> Bool) -> FCode Bool
isEnabled StgToCmmConfig -> Bool
stgToCmmTickyLNE
if Bool -> Bool
not Bool
b then FCode a
code else TickyClosureType -> Id -> FCode a -> FCode a
forall a. TickyClosureType -> Id -> FCode a -> FCode a
withNewTickyCounter ([NonVoid Id] -> TickyClosureType
TickyLNE [NonVoid Id]
args) Id
nm FCode a
code
thunkHasCounter :: Bool -> FCode Bool
thunkHasCounter :: Bool -> FCode Bool
thunkHasCounter Bool
isStatic = (Bool -> Bool
not Bool
isStatic Bool -> Bool -> Bool
&&) (Bool -> Bool) -> FCode Bool -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgToCmmConfig -> Bool) -> FCode Bool
isEnabled StgToCmmConfig -> Bool
stgToCmmTickyDynThunk
withNewTickyCounterThunk
:: Bool
-> Bool
-> Id
-> [NonVoid Id]
-> FCode a
-> FCode a
withNewTickyCounterThunk :: forall a. Bool -> Bool -> Id -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterThunk Bool
isStatic Bool
isUpdatable Id
name [NonVoid Id]
fvs FCode a
code = do
Bool
has_ctr <- Bool -> FCode Bool
thunkHasCounter Bool
isStatic
if Bool -> Bool
not Bool
has_ctr
then FCode a
code
else TickyClosureType -> Id -> FCode a -> FCode a
forall a. TickyClosureType -> Id -> FCode a -> FCode a
withNewTickyCounter (Bool -> Bool -> [StgArg] -> TickyClosureType
TickyThunk Bool
isUpdatable Bool
False ((Id -> StgArg) -> [Id] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> StgArg
StgVarArg ([Id] -> [StgArg]) -> [Id] -> [StgArg]
forall a b. (a -> b) -> a -> b
$ [NonVoid Id] -> [Id]
forall a b. Coercible a b => a -> b
coerce [NonVoid Id]
fvs)) Id
name FCode a
code
withNewTickyCounterStdThunk
:: Bool
-> Id
-> [StgArg]
-> FCode a
-> FCode a
withNewTickyCounterStdThunk :: forall a. Bool -> Id -> [StgArg] -> FCode a -> FCode a
withNewTickyCounterStdThunk Bool
isUpdatable Id
name [StgArg]
fvs FCode a
code = do
Bool
has_ctr <- Bool -> FCode Bool
thunkHasCounter Bool
False
if Bool -> Bool
not Bool
has_ctr
then FCode a
code
else TickyClosureType -> Id -> FCode a -> FCode a
forall a. TickyClosureType -> Id -> FCode a -> FCode a
withNewTickyCounter (Bool -> Bool -> [StgArg] -> TickyClosureType
TickyThunk Bool
isUpdatable Bool
True [StgArg]
fvs) Id
name FCode a
code
withNewTickyCounterCon
:: Id
-> DataCon
-> ConstructorNumber
-> FCode a
-> FCode a
withNewTickyCounterCon :: forall a. Id -> DataCon -> ConstructorNumber -> FCode a -> FCode a
withNewTickyCounterCon Id
name DataCon
datacon ConstructorNumber
info FCode a
code = do
Bool
has_ctr <- Bool -> FCode Bool
thunkHasCounter Bool
False
if Bool -> Bool
not Bool
has_ctr
then FCode a
code
else TickyClosureType -> Id -> FCode a -> FCode a
forall a. TickyClosureType -> Id -> FCode a -> FCode a
withNewTickyCounter (DataCon -> ConstructorNumber -> TickyClosureType
TickyCon DataCon
datacon ConstructorNumber
info) Id
name FCode a
code
withNewTickyCounter :: TickyClosureType -> Id -> FCode a -> FCode a
withNewTickyCounter :: forall a. TickyClosureType -> Id -> FCode a -> FCode a
withNewTickyCounter TickyClosureType
cloType Id
name FCode a
m = do
CLabel
lbl <- TickyClosureType -> Id -> FCode CLabel
emitTickyCounter TickyClosureType
cloType Id
name
CLabel -> FCode a -> FCode a
forall a. CLabel -> FCode a -> FCode a
setTickyCtrLabel CLabel
lbl FCode a
m
emitTickyData :: Platform
-> CLabel
-> Arity
-> CmmLit
-> CmmLit
-> CmmLit
-> CmmLit
-> FCode ()
emitTickyData :: Platform
-> CLabel
-> Int
-> CmmLit
-> CmmLit
-> CmmLit
-> CmmLit
-> FCode ()
emitTickyData Platform
platform CLabel
ctr_lbl Int
arity CmmLit
fun_desc CmmLit
arg_desc CmmLit
json_desc CmmLit
info_tbl =
CLabel -> [CmmLit] -> FCode ()
emitDataLits CLabel
ctr_lbl
[ Platform -> CmmLit
zeroCLit Platform
platform,
Platform -> Int -> CmmLit
mkIntCLit Platform
platform Int
arity,
Platform -> CmmLit
zeroCLit Platform
platform,
CmmLit
fun_desc,
CmmLit
arg_desc,
CmmLit
json_desc,
CmmLit
info_tbl,
Platform -> CmmLit
zeroCLit Platform
platform,
Platform -> CmmLit
zeroCLit Platform
platform,
Platform -> CmmLit
zeroCLit Platform
platform
]
emitTickyCounter :: TickyClosureType -> Id -> FCode CLabel
emitTickyCounter :: TickyClosureType -> Id -> FCode CLabel
emitTickyCounter TickyClosureType
cloType Id
tickee
= let name :: Name
name = Id -> Name
idName Id
tickee in
let ctr_lbl :: CLabel
ctr_lbl = Name -> CLabel
mkRednCountsLabel Name
name in
(FCode () -> FCode CLabel -> FCode CLabel
forall a b. FCode a -> FCode b -> FCode b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CLabel -> FCode CLabel
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return CLabel
ctr_lbl) (FCode () -> FCode CLabel) -> FCode () -> FCode CLabel
forall a b. (a -> b) -> a -> b
$
FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
{ StgToCmmConfig
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
; CLabel
parent <- FCode CLabel
getTickyCtrLabel
; Module
mod_name <- FCode Module
getModuleName
; let platform :: Platform
platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
ppr_for_ticky_name :: SDoc
ppr_for_ticky_name :: SDoc
ppr_for_ticky_name =
let ext :: SDoc
ext = case TickyClosureType
cloType of
TickyFun Bool
single_entry [NonVoid Id]
_ [NonVoid Id]
_-> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
[String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fun"] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"se"|Bool
single_entry]
TickyCon DataCon
datacon ConstructorNumber
_cn -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"con:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon -> Name
dataConName DataCon
datacon))
TickyThunk Bool
upd Bool
std [StgArg]
_-> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
[String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"thk"] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"se"|Bool -> Bool
not Bool
upd] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"std"|Bool
std]
TickyLNE [NonVoid Id]
_ | Name -> Bool
isInternalName Name
name -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"LNE")
| Bool
otherwise -> String -> SDoc
forall a. HasCallStack => String -> a
panic String
"emitTickyCounter: how is this an external LNE?"
p :: SDoc
p = case CLabel -> Maybe Name
hasHaskellName CLabel
parent of
Just Name
pname -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> Unique
nameUnique Name
pname)
Maybe Name
_ -> SDoc
forall doc. IsOutput doc => doc
empty
in Module -> Name -> SDoc
pprTickyName Module
mod_name Name
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
ext SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
p
; Module
this_mod <- FCode Module
getModuleName
; let t :: String
t = case TickyClosureType
cloType of
TickyCon {} -> String
"C"
TickyFun {} -> String
"F"
TickyThunk {} -> String
"T"
TickyLNE {} -> String
"L"
; CmmLit
info_lbl <- case TickyClosureType
cloType of
TickyCon DataCon
dc ConstructorNumber
mn -> case ConstructorNumber
mn of
ConstructorNumber
NoNumber -> CmmLit -> FCode CmmLit
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmLit -> FCode CmmLit) -> CmmLit -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$! CLabel -> CmmLit
CmmLabel (CLabel -> CmmLit) -> CLabel -> CmmLit
forall a b. (a -> b) -> a -> b
$ Name -> ConInfoTableLocation -> CLabel
mkConInfoTableLabel (DataCon -> Name
dataConName DataCon
dc) ConInfoTableLocation
DefinitionSite
(Numbered Int
n) -> CmmLit -> FCode CmmLit
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmLit -> FCode CmmLit) -> CmmLit -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$! CLabel -> CmmLit
CmmLabel (CLabel -> CmmLit) -> CLabel -> CmmLit
forall a b. (a -> b) -> a -> b
$ Name -> ConInfoTableLocation -> CLabel
mkConInfoTableLabel (DataCon -> Name
dataConName DataCon
dc) (Module -> Int -> ConInfoTableLocation
UsageSite Module
this_mod Int
n)
TickyFun {} ->
CmmLit -> FCode CmmLit
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmLit -> FCode CmmLit) -> CmmLit -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$! CLabel -> CmmLit
CmmLabel (CLabel -> CmmLit) -> CLabel -> CmmLit
forall a b. (a -> b) -> a -> b
$ Name -> CafInfo -> CLabel
mkInfoTableLabel Name
name CafInfo
NoCafRefs
TickyThunk Bool
_ Bool
std_thunk [StgArg]
_fvs
| Bool -> Bool
not Bool
std_thunk
-> CmmLit -> FCode CmmLit
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmLit -> FCode CmmLit) -> CmmLit -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$! CLabel -> CmmLit
CmmLabel (CLabel -> CmmLit) -> CLabel -> CmmLit
forall a b. (a -> b) -> a -> b
$ Name -> CafInfo -> CLabel
mkInfoTableLabel Name
name CafInfo
NoCafRefs
| Bool
otherwise
-> do
Maybe CgIdInfo
lf_info <- Name -> FCode (Maybe CgIdInfo)
getCgInfo_maybe Name
name
Profile
profile <- FCode Profile
getProfile
case Maybe CgIdInfo
lf_info of
Just (CgIdInfo { cg_lf :: CgIdInfo -> LambdaFormInfo
cg_lf = LambdaFormInfo
cg_lf })
| LambdaFormInfo -> Bool
isLFThunk LambdaFormInfo
cg_lf
-> CmmLit -> FCode CmmLit
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmLit -> FCode CmmLit) -> CmmLit -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$! CLabel -> CmmLit
CmmLabel (CLabel -> CmmLit) -> CLabel -> CmmLit
forall a b. (a -> b) -> a -> b
$ Platform -> Id -> LambdaFormInfo -> CLabel
mkClosureInfoTableLabel (Profile -> Platform
profilePlatform Profile
profile) Id
tickee LambdaFormInfo
cg_lf
Maybe CgIdInfo
_ -> String
-> SDoc -> (CmmLit -> FCode CmmLit) -> CmmLit -> FCode CmmLit
forall a. String -> SDoc -> a -> a
pprTraceDebug String
"tickyThunkUnknown" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
t SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CLabel -> SDoc
pprDebugCLabel (Profile -> Platform
profilePlatform Profile
profile) (Name -> CafInfo -> CLabel
mkInfoTableLabel Name
name CafInfo
NoCafRefs))
CmmLit -> FCode CmmLit
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmLit -> FCode CmmLit) -> CmmLit -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$! Platform -> CmmLit
zeroCLit Platform
platform
TickyLNE {} -> CmmLit -> FCode CmmLit
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmLit -> FCode CmmLit) -> CmmLit -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$! Platform -> CmmLit
zeroCLit Platform
platform
; let ctx :: SDocContext
ctx = SDocContext
defaultSDocContext {sdocPprDebug = True}
; CmmLit
fun_descr_lit <- String -> FCode CmmLit
newStringCLit (String -> FCode CmmLit) -> String -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx SDoc
ppr_for_ticky_name
; CmmLit
arg_descr_lit <- String -> FCode CmmLit
newStringCLit (String -> FCode CmmLit) -> String -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$ TickyClosureType -> String
tickyArgDesc TickyClosureType
cloType
; CmmLit
json_descr_lit <- String -> FCode CmmLit
newStringCLit (String -> FCode CmmLit) -> String -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$ SDocContext -> TickyClosureType -> String
tickyEntryDescJson SDocContext
ctx TickyClosureType
cloType
; Platform
-> CLabel
-> Int
-> CmmLit
-> CmmLit
-> CmmLit
-> CmmLit
-> FCode ()
emitTickyData Platform
platform CLabel
ctr_lbl (TickyClosureType -> Int
tickyArgArity TickyClosureType
cloType) CmmLit
fun_descr_lit CmmLit
arg_descr_lit CmmLit
json_descr_lit CmmLit
info_lbl
}
emitTickyCounterTag :: Unique -> NonVoid Id -> FCode CLabel
emitTickyCounterTag :: Unique -> NonVoid Id -> FCode CLabel
emitTickyCounterTag Unique
unique (NonVoid Id
id) =
let name :: Name
name = Id -> Name
idName Id
id
ctr_lbl :: CLabel
ctr_lbl = Name -> Unique -> CLabel
mkTagHitLabel Name
name Unique
unique in
(FCode () -> FCode CLabel -> FCode CLabel
forall a b. FCode a -> FCode b -> FCode b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CLabel -> FCode CLabel
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return CLabel
ctr_lbl) (FCode () -> FCode CLabel) -> FCode () -> FCode CLabel
forall a b. (a -> b) -> a -> b
$
FCode () -> FCode ()
ifTickyTag (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
{ Platform
platform <- FCode Platform
getPlatform
; CLabel
parent <- FCode CLabel
getTickyCtrLabel
; Module
mod_name <- FCode Module
getModuleName
; let ppr_for_ticky_name :: SDoc
ppr_for_ticky_name :: SDoc
ppr_for_ticky_name =
let n :: SDoc
n = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
ext :: SDoc
ext = SDoc
forall doc. IsOutput doc => doc
empty
p :: SDoc
p = case CLabel -> Maybe Name
hasHaskellName CLabel
parent of
Just Name
pname -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SrcLoc
nameSrcLoc Name
pname) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
pprNameUnqualified Name
name
Maybe Name
_ -> SDoc
forall doc. IsOutput doc => doc
empty
in if Name -> Bool
isInternalName Name
name
then SDoc
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod_name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
ext SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
p
else SDoc
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
ext SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
p
; SDocContext
sdoc_context <- StgToCmmConfig -> SDocContext
stgToCmmContext (StgToCmmConfig -> SDocContext)
-> FCode StgToCmmConfig -> FCode SDocContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
; CmmLit
fun_descr_lit <- String -> FCode CmmLit
newStringCLit (String -> FCode CmmLit) -> String -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
sdoc_context SDoc
ppr_for_ticky_name
; CmmLit
arg_descr_lit <- String -> FCode CmmLit
newStringCLit (String -> FCode CmmLit) -> String -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$ String
"infer"
; CmmLit
json_descr_lit <- String -> FCode CmmLit
newStringCLit (String -> FCode CmmLit) -> String -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$ String
"infer"
; Platform
-> CLabel
-> Int
-> CmmLit
-> CmmLit
-> CmmLit
-> CmmLit
-> FCode ()
emitTickyData Platform
platform CLabel
ctr_lbl Int
0 CmmLit
fun_descr_lit CmmLit
arg_descr_lit CmmLit
json_descr_lit (Platform -> CmmLit
zeroCLit Platform
platform)
}
tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
tickyPushUpdateFrame :: FCode ()
tickyPushUpdateFrame = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"UPDF_PUSHED_ctr")
tickyUpdateFrameOmitted :: FCode ()
tickyUpdateFrameOmitted = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"UPDF_OMITTED_ctr")
tickyEnterDynCon :: FCode ()
tickyEnterDynCon :: FCode ()
tickyEnterDynCon = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"ENT_DYN_CON_ctr")
tickyEnterThunk :: ClosureInfo -> FCode ()
tickyEnterThunk :: ClosureInfo -> FCode ()
tickyEnterThunk ClosureInfo
cl_info
= FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
{ FastString -> FCode ()
bumpTickyCounter FastString
ctr
; Bool
has_ctr <- Bool -> FCode Bool
thunkHasCounter Bool
static
; Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
has_ctr (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
CLabel
ticky_ctr_lbl <- FCode CLabel
getTickyCtrLabel
CLabel -> FCode ()
registerTickyCtrAtEntryDyn CLabel
ticky_ctr_lbl
CLabel -> FCode ()
bumpTickyEntryCount CLabel
ticky_ctr_lbl }
where
updatable :: Bool
updatable = Bool -> Bool
not (ClosureInfo -> Bool
closureUpdReqd ClosureInfo
cl_info)
static :: Bool
static = ClosureInfo -> Bool
isStaticClosure ClosureInfo
cl_info
ctr :: FastString
ctr | Bool
static = if Bool
updatable then String -> FastString
fsLit String
"ENT_STATIC_THK_SINGLE_ctr"
else String -> FastString
fsLit String
"ENT_STATIC_THK_MANY_ctr"
| Bool
otherwise = if Bool
updatable then String -> FastString
fsLit String
"ENT_DYN_THK_SINGLE_ctr"
else String -> FastString
fsLit String
"ENT_DYN_THK_MANY_ctr"
tickyUpdateBhCaf :: ClosureInfo -> FCode ()
tickyUpdateBhCaf :: ClosureInfo -> FCode ()
tickyUpdateBhCaf ClosureInfo
cl_info
= FCode () -> FCode ()
ifTicky (FastString -> FCode ()
bumpTickyCounter FastString
ctr)
where
ctr :: FastString
ctr | ClosureInfo -> Bool
closureUpdReqd ClosureInfo
cl_info = (String -> FastString
fsLit String
"UPD_CAF_BH_SINGLE_ENTRY_ctr")
| Bool
otherwise = (String -> FastString
fsLit String
"UPD_CAF_BH_UPDATABLE_ctr")
tickyEnterFun :: ClosureInfo -> FCode ()
tickyEnterFun :: ClosureInfo -> FCode ()
tickyEnterFun ClosureInfo
cl_info = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
CLabel
ctr_lbl <- FCode CLabel
getTickyCtrLabel
if ClosureInfo -> Bool
isStaticClosure ClosureInfo
cl_info
then do FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"ENT_STATIC_FUN_DIRECT_ctr")
CLabel -> FCode ()
registerTickyCtr CLabel
ctr_lbl
else do FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"ENT_DYN_FUN_DIRECT_ctr")
CLabel -> FCode ()
registerTickyCtrAtEntryDyn CLabel
ctr_lbl
CLabel -> FCode ()
bumpTickyEntryCount CLabel
ctr_lbl
tickyEnterLNE :: FCode ()
tickyEnterLNE :: FCode ()
tickyEnterLNE = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"ENT_LNE_ctr")
FCode () -> FCode ()
ifTickyLNE (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
CLabel
ctr_lbl <- FCode CLabel
getTickyCtrLabel
CLabel -> FCode ()
registerTickyCtr CLabel
ctr_lbl
CLabel -> FCode ()
bumpTickyEntryCount CLabel
ctr_lbl
registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
registerTickyCtrAtEntryDyn CLabel
ctr_lbl = do
Bool
already_registered <- (StgToCmmConfig -> Bool) -> FCode Bool
isEnabled StgToCmmConfig -> Bool
stgToCmmTickyAllocd
Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
already_registered (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ CLabel -> FCode ()
registerTickyCtr CLabel
ctr_lbl
registerTickyCtr :: CLabel -> FCode ()
registerTickyCtr :: CLabel -> FCode ()
registerTickyCtr CLabel
ctr_lbl = do
Platform
platform <- FCode Platform
getPlatform
let constants :: PlatformConstants
constants = Platform -> PlatformConstants
platformConstants Platform
platform
word_width :: Width
word_width = Platform -> Width
wordWidth Platform
platform
registeredp :: CmmExpr
registeredp = CmmLit -> CmmExpr
CmmLit (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
ctr_lbl (PlatformConstants -> Int
pc_OFFSET_StgEntCounter_registeredp PlatformConstants
constants))
CmmAGraph
register_stmts <- FCode () -> FCode CmmAGraph
forall a. FCode a -> FCode CmmAGraph
getCode (FCode () -> FCode CmmAGraph) -> FCode () -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ do
LocalReg
old_head <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
bWord Platform
platform)
let ticky_entry_ctrs :: CmmExpr
ticky_entry_ctrs = CLabel -> CmmExpr
mkLblExpr (FastString -> CLabel
mkRtsCmmDataLabel (String -> FastString
fsLit String
"ticky_entry_ctrs"))
link :: CmmExpr
link = CmmLit -> CmmExpr
CmmLit (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
ctr_lbl (PlatformConstants -> Int
pc_OFFSET_StgEntCounter_link PlatformConstants
constants))
[LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
emitPrimCall [LocalReg
old_head] (Width -> CallishMachOp
MO_Xchg Width
word_width) [CmmExpr
ticky_entry_ctrs, CLabel -> CmmExpr
mkLblExpr CLabel
ctr_lbl]
CmmExpr -> CmmExpr -> FCode ()
emitStore CmmExpr
link (CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> CmmReg -> CmmExpr
forall a b. (a -> b) -> a -> b
$ LocalReg -> CmmReg
CmmLocal LocalReg
old_head)
CmmAGraph
cas_test <- FCode () -> FCode CmmAGraph
forall a. FCode a -> FCode CmmAGraph
getCode (FCode () -> FCode CmmAGraph) -> FCode () -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ do
LocalReg
old <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
bWord Platform
platform)
[LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
emitPrimCall [LocalReg
old] (Width -> CallishMachOp
MO_Cmpxchg Width
word_width)
[CmmExpr
registeredp, Platform -> CmmExpr
zeroExpr Platform
platform, Platform -> Int -> CmmExpr
mkIntExpr Platform
platform Int
1]
let locked :: CmmExpr
locked = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmEqWord Platform
platform (CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> CmmReg -> CmmExpr
forall a b. (a -> b) -> a -> b
$ LocalReg -> CmmReg
CmmLocal LocalReg
old) (Platform -> CmmExpr
zeroExpr Platform
platform)
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen CmmExpr
locked CmmAGraph
register_stmts
let test :: CmmExpr
test = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmEqWord Platform
platform (Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform CmmExpr
registeredp) (Platform -> CmmExpr
zeroExpr Platform
platform)
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen CmmExpr
test CmmAGraph
cas_test
tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
tickyReturnOldCon :: Int -> FCode ()
tickyReturnOldCon Int
arity
= FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do { FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"RET_OLD_ctr")
; FastString -> Int -> FCode ()
bumpHistogram (String -> FastString
fsLit String
"RET_OLD_hst") Int
arity }
tickyReturnNewCon :: Int -> FCode ()
tickyReturnNewCon Int
arity
= FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do { FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"RET_NEW_ctr")
; FastString -> Int -> FCode ()
bumpHistogram (String -> FastString
fsLit String
"RET_NEW_hst") Int
arity }
tickyUnboxedTupleReturn :: RepArity -> FCode ()
tickyUnboxedTupleReturn :: Int -> FCode ()
tickyUnboxedTupleReturn Int
arity
= FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do { FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"RET_UNBOXED_TUP_ctr")
; FastString -> Int -> FCode ()
bumpHistogram (String -> FastString
fsLit String
"RET_UNBOXED_TUP_hst") Int
arity }
tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
tickyDirectCall :: Int -> [StgArg] -> FCode ()
tickyDirectCall Int
arity [StgArg]
args
| [StgArg]
args [StgArg] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
arity = FCode ()
tickyKnownCallExact
| Bool
otherwise = do FCode ()
tickyKnownCallExtraArgs
[PrimRep] -> FCode ()
tickySlowCallPat ((StgArg -> PrimRep) -> [StgArg] -> [PrimRep]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> PrimRep
argPrimRep (Int -> [StgArg] -> [StgArg]
forall a. Int -> [a] -> [a]
drop Int
arity [StgArg]
args))
tickyKnownCallTooFewArgs :: FCode ()
tickyKnownCallTooFewArgs :: FCode ()
tickyKnownCallTooFewArgs = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"KNOWN_CALL_TOO_FEW_ARGS_ctr")
tickyKnownCallExact :: FCode ()
tickyKnownCallExact :: FCode ()
tickyKnownCallExact = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"KNOWN_CALL_ctr")
tickyKnownCallExtraArgs :: FCode ()
= FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"KNOWN_CALL_EXTRA_ARGS_ctr")
tickyUnknownCall :: FCode ()
tickyUnknownCall :: FCode ()
tickyUnknownCall = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"UNKNOWN_CALL_ctr")
tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
tickySlowCall LambdaFormInfo
_ [] = () -> FCode ()
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tickySlowCall LambdaFormInfo
lf_info [StgArg]
args = do
if LambdaFormInfo -> Bool
isKnownFun LambdaFormInfo
lf_info
then FCode ()
tickyKnownCallTooFewArgs
else FCode ()
tickyUnknownCall
[PrimRep] -> FCode ()
tickySlowCallPat ((StgArg -> PrimRep) -> [StgArg] -> [PrimRep]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> PrimRep
argPrimRep [StgArg]
args)
tickySlowCallPat :: [PrimRep] -> FCode ()
tickySlowCallPat :: [PrimRep] -> FCode ()
tickySlowCallPat [PrimRep]
args = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
Platform
platform <- Profile -> Platform
profilePlatform (Profile -> Platform) -> FCode Profile -> FCode Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode Profile
getProfile
let argReps :: [ArgRep]
argReps = (PrimRep -> ArgRep) -> [PrimRep] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform) [PrimRep]
args
(FastString
_, Int
n_matched) = [ArgRep] -> (FastString, Int)
slowCallPattern [ArgRep]
argReps
if Int
n_matched Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& [PrimRep]
args [PrimRep] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n_matched
then CLabel -> FCode ()
bumpTickyLbl (CLabel -> FCode ()) -> CLabel -> FCode ()
forall a b. (a -> b) -> a -> b
$ String -> CLabel
mkRtsSlowFastTickyCtrLabel (String -> CLabel) -> String -> CLabel
forall a b. (a -> b) -> a -> b
$ (ArgRep -> String) -> [ArgRep] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Data.Char.toLower (String -> String) -> (ArgRep -> String) -> ArgRep -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgRep -> String
argRepString) [ArgRep]
argReps
else FastString -> FCode ()
bumpTickyCounter (FastString -> FCode ()) -> FastString -> FCode ()
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit String
"VERY_SLOW_CALL_ctr"
tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
tickyDynAlloc Maybe Id
mb_id SMRep
rep LambdaFormInfo
lf = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
Profile
profile <- FCode Profile
getProfile
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
bytes :: Int
bytes = Platform -> Int
platformWordSizeInBytes Platform
platform Int -> Int -> Int
forall a. Num a => a -> a -> a
* Profile -> SMRep -> Int
heapClosureSizeW Profile
profile SMRep
rep
countGlobal :: FastString -> FastString -> FCode ()
countGlobal FastString
tot FastString
ctr = do
FastString -> Int -> FCode ()
bumpTickyCounterBy FastString
tot Int
bytes
FastString -> FCode ()
bumpTickyCounter FastString
ctr
countSpecific :: FCode ()
countSpecific = FCode () -> FCode ()
ifTickyAllocd (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ case Maybe Id
mb_id of
Maybe Id
Nothing -> () -> FCode ()
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Id
id -> do
let ctr_lbl :: CLabel
ctr_lbl = Name -> CLabel
mkRednCountsLabel (Id -> Name
idName Id
id)
CLabel -> FCode ()
registerTickyCtr CLabel
ctr_lbl
CLabel -> Int -> FCode ()
bumpTickyAllocd CLabel
ctr_lbl Int
bytes
if | SMRep -> Bool
isConRep SMRep
rep ->
FCode () -> FCode ()
ifTickyDynThunk FCode ()
countSpecific FCode () -> FCode () -> FCode ()
forall a b. FCode a -> FCode b -> FCode b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
FastString -> FastString -> FCode ()
countGlobal (String -> FastString
fsLit String
"ALLOC_CON_gds") (String -> FastString
fsLit String
"ALLOC_CON_ctr")
| SMRep -> Bool
isThunkRep SMRep
rep ->
FCode () -> FCode ()
ifTickyDynThunk FCode ()
countSpecific FCode () -> FCode () -> FCode ()
forall a b. FCode a -> FCode b -> FCode b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
if LambdaFormInfo -> Bool
lfUpdatable LambdaFormInfo
lf
then FastString -> FastString -> FCode ()
countGlobal (String -> FastString
fsLit String
"ALLOC_THK_gds") (String -> FastString
fsLit String
"ALLOC_UP_THK_ctr")
else FastString -> FastString -> FCode ()
countGlobal (String -> FastString
fsLit String
"ALLOC_THK_gds") (String -> FastString
fsLit String
"ALLOC_SE_THK_ctr")
| SMRep -> Bool
isFunRep SMRep
rep ->
FCode ()
countSpecific FCode () -> FCode () -> FCode ()
forall a b. FCode a -> FCode b -> FCode b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
FastString -> FastString -> FCode ()
countGlobal (String -> FastString
fsLit String
"ALLOC_FUN_gds") (String -> FastString
fsLit String
"ALLOC_FUN_ctr")
| Bool
otherwise -> String -> FCode ()
forall a. HasCallStack => String -> a
panic String
"How is this heap object not a con, thunk, or fun?"
tickyAllocHeap ::
Bool ->
VirtualHpOffset -> FCode ()
tickyAllocHeap :: Bool -> Int -> FCode ()
tickyAllocHeap Bool
genuine Int
hp
= FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
do { Platform
platform <- FCode Platform
getPlatform
; CLabel
ticky_ctr <- FCode CLabel
getTickyCtrLabel
; CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs ([CmmAGraph] -> CmmAGraph) -> [CmmAGraph] -> CmmAGraph
forall a b. (a -> b) -> a -> b
$
if Int
hp Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then []
else let !bytes :: Int
bytes = Platform -> Int
platformWordSizeInBytes Platform
platform Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
hp in [
CmmType -> CmmExpr -> Int -> CmmAGraph
addToMem (Platform -> CmmType
rEP_StgEntCounter_allocs Platform
platform)
(CmmLit -> CmmExpr
CmmLit (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
ticky_ctr (PlatformConstants -> Int
pc_OFFSET_StgEntCounter_allocs (Platform -> PlatformConstants
platformConstants Platform
platform))))
Int
bytes,
CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl (Platform -> CmmType
bWord Platform
platform)
(FastString -> CLabel
mkRtsCmmDataLabel (String -> FastString
fsLit String
"ALLOC_HEAP_tot"))
Int
bytes,
if Bool -> Bool
not Bool
genuine then CmmAGraph
mkNop
else CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl (Platform -> CmmType
bWord Platform
platform)
(FastString -> CLabel
mkRtsCmmDataLabel (String -> FastString
fsLit String
"ALLOC_HEAP_ctr"))
Int
1
]}
tickyAllocPrim :: CmmExpr
-> CmmExpr
-> CmmExpr -> FCode ()
tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
tickyAllocPrim CmmExpr
_hdr CmmExpr
_goods CmmExpr
_slop = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"ALLOC_PRIM_ctr")
FastString -> CmmExpr -> FCode ()
bumpTickyCounterByE (String -> FastString
fsLit String
"ALLOC_PRIM_adm") CmmExpr
_hdr
FastString -> CmmExpr -> FCode ()
bumpTickyCounterByE (String -> FastString
fsLit String
"ALLOC_PRIM_gds") CmmExpr
_goods
FastString -> CmmExpr -> FCode ()
bumpTickyCounterByE (String -> FastString
fsLit String
"ALLOC_PRIM_slp") CmmExpr
_slop
tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
tickyAllocThunk CmmExpr
_goods CmmExpr
_slop = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"ALLOC_UP_THK_ctr")
FastString -> CmmExpr -> FCode ()
bumpTickyCounterByE (String -> FastString
fsLit String
"ALLOC_THK_gds") CmmExpr
_goods
FastString -> CmmExpr -> FCode ()
bumpTickyCounterByE (String -> FastString
fsLit String
"ALLOC_THK_slp") CmmExpr
_slop
tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
tickyAllocPAP CmmExpr
_goods CmmExpr
_slop = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"ALLOC_PAP_ctr")
FastString -> CmmExpr -> FCode ()
bumpTickyCounterByE (String -> FastString
fsLit String
"ALLOC_PAP_gds") CmmExpr
_goods
FastString -> CmmExpr -> FCode ()
bumpTickyCounterByE (String -> FastString
fsLit String
"ALLOC_PAP_slp") CmmExpr
_slop
tickyHeapCheck :: FCode ()
tickyHeapCheck :: FCode ()
tickyHeapCheck = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"HEAP_CHK_ctr")
tickyStackCheck :: FCode ()
tickyStackCheck :: FCode ()
tickyStackCheck = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"STK_CHK_ctr")
tickyTagged :: FCode ()
tickyTagged :: FCode ()
tickyTagged = FCode () -> FCode ()
ifTickyTag (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"TAG_TAGGED_pred")
tickyUntagged :: CmmExpr -> FCode ()
tickyUntagged :: CmmExpr -> FCode ()
tickyUntagged CmmExpr
e = do
FCode () -> FCode ()
ifTickyTag (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"TAG_UNTAGGED_pred")
FCode () -> FCode ()
ifTickyTag (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> CmmExpr -> FCode ()
bumpTickyCounterByE (String -> FastString
fsLit String
"TAG_UNTAGGED_miss") CmmExpr
e
tickyTagSkip :: Unique -> Id -> FCode ()
tickyTagSkip :: Unique -> Id -> FCode ()
tickyTagSkip Unique
unique Id
id = FCode () -> FCode ()
ifTickyTag (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
let ctr_lbl :: CLabel
ctr_lbl = Name -> Unique -> CLabel
mkTagHitLabel (Id -> Name
idName Id
id) Unique
unique
CLabel -> FCode ()
registerTickyCtr CLabel
ctr_lbl
CLabel -> FCode ()
bumpTickyTagSkip CLabel
ctr_lbl
isEnabled :: (StgToCmmConfig -> Bool) -> FCode Bool
isEnabled :: (StgToCmmConfig -> Bool) -> FCode Bool
isEnabled = ((StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool)
-> FCode StgToCmmConfig -> (StgToCmmConfig -> Bool) -> FCode Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall a b. (a -> b) -> FCode a -> FCode b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FCode StgToCmmConfig
getStgToCmmConfig
runIfFlag :: (StgToCmmConfig -> Bool) -> FCode () -> FCode ()
runIfFlag :: (StgToCmmConfig -> Bool) -> FCode () -> FCode ()
runIfFlag StgToCmmConfig -> Bool
f = FCode Bool -> FCode () -> FCode ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (StgToCmmConfig -> Bool
f (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig)
ifTicky :: FCode () -> FCode ()
ifTicky :: FCode () -> FCode ()
ifTicky = (StgToCmmConfig -> Bool) -> FCode () -> FCode ()
runIfFlag StgToCmmConfig -> Bool
stgToCmmDoTicky
ifTickyTag :: FCode () -> FCode ()
ifTickyTag :: FCode () -> FCode ()
ifTickyTag = (StgToCmmConfig -> Bool) -> FCode () -> FCode ()
runIfFlag StgToCmmConfig -> Bool
stgToCmmTickyTag
ifTickyAllocd :: FCode () -> FCode ()
ifTickyAllocd :: FCode () -> FCode ()
ifTickyAllocd = (StgToCmmConfig -> Bool) -> FCode () -> FCode ()
runIfFlag StgToCmmConfig -> Bool
stgToCmmTickyAllocd
ifTickyLNE :: FCode () -> FCode ()
ifTickyLNE :: FCode () -> FCode ()
ifTickyLNE = (StgToCmmConfig -> Bool) -> FCode () -> FCode ()
runIfFlag StgToCmmConfig -> Bool
stgToCmmTickyLNE
ifTickyDynThunk :: FCode () -> FCode ()
ifTickyDynThunk :: FCode () -> FCode ()
ifTickyDynThunk = (StgToCmmConfig -> Bool) -> FCode () -> FCode ()
runIfFlag StgToCmmConfig -> Bool
stgToCmmTickyDynThunk
bumpTickyCounter :: FastString -> FCode ()
bumpTickyCounter :: FastString -> FCode ()
bumpTickyCounter = CLabel -> FCode ()
bumpTickyLbl (CLabel -> FCode ())
-> (FastString -> CLabel) -> FastString -> FCode ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> CLabel
mkRtsCmmDataLabel
bumpTickyCounterBy :: FastString -> Int -> FCode ()
bumpTickyCounterBy :: FastString -> Int -> FCode ()
bumpTickyCounterBy = CLabel -> Int -> FCode ()
bumpTickyLblBy (CLabel -> Int -> FCode ())
-> (FastString -> CLabel) -> FastString -> Int -> FCode ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> CLabel
mkRtsCmmDataLabel
bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
bumpTickyCounterByE FastString
lbl = CLabel -> CmmExpr -> FCode ()
bumpTickyLblByE (FastString -> CLabel
mkRtsCmmDataLabel FastString
lbl)
bumpTickyEntryCount :: CLabel -> FCode ()
bumpTickyEntryCount :: CLabel -> FCode ()
bumpTickyEntryCount CLabel
lbl = do
Platform
platform <- FCode Platform
getPlatform
CmmLit -> FCode ()
bumpTickyLit (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
lbl (PlatformConstants -> Int
pc_OFFSET_StgEntCounter_entry_count (Platform -> PlatformConstants
platformConstants Platform
platform)))
bumpTickyAllocd :: CLabel -> Int -> FCode ()
bumpTickyAllocd :: CLabel -> Int -> FCode ()
bumpTickyAllocd CLabel
lbl Int
bytes = do
Platform
platform <- FCode Platform
getPlatform
CmmLit -> Int -> FCode ()
bumpTickyLitBy (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
lbl (PlatformConstants -> Int
pc_OFFSET_StgEntCounter_entry_count (Platform -> PlatformConstants
platformConstants Platform
platform))) Int
bytes
bumpTickyTagSkip :: CLabel -> FCode ()
bumpTickyTagSkip :: CLabel -> FCode ()
bumpTickyTagSkip CLabel
lbl = do
Platform
platform <- FCode Platform
getPlatform
CmmLit -> Int -> FCode ()
bumpTickyLitBy (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
lbl (PlatformConstants -> Int
pc_OFFSET_StgEntCounter_entry_count (Platform -> PlatformConstants
platformConstants Platform
platform))) Int
1
bumpTickyLbl :: CLabel -> FCode ()
bumpTickyLbl :: CLabel -> FCode ()
bumpTickyLbl CLabel
lhs = CmmLit -> Int -> FCode ()
bumpTickyLitBy (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
lhs Int
0) Int
1
bumpTickyLblBy :: CLabel -> Int -> FCode ()
bumpTickyLblBy :: CLabel -> Int -> FCode ()
bumpTickyLblBy CLabel
lhs = CmmLit -> Int -> FCode ()
bumpTickyLitBy (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
lhs Int
0)
bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()
bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()
bumpTickyLblByE CLabel
lhs = CmmLit -> CmmExpr -> FCode ()
bumpTickyLitByE (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
lhs Int
0)
bumpTickyLit :: CmmLit -> FCode ()
bumpTickyLit :: CmmLit -> FCode ()
bumpTickyLit CmmLit
lhs = CmmLit -> Int -> FCode ()
bumpTickyLitBy CmmLit
lhs Int
1
bumpTickyLitBy :: CmmLit -> Int -> FCode ()
bumpTickyLitBy :: CmmLit -> Int -> FCode ()
bumpTickyLitBy CmmLit
lhs Int
n = do
Platform
platform <- FCode Platform
getPlatform
CmmAGraph -> FCode ()
emit (CmmType -> CmmExpr -> Int -> CmmAGraph
addToMem (Platform -> CmmType
bWord Platform
platform) (CmmLit -> CmmExpr
CmmLit CmmLit
lhs) Int
n)
bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
bumpTickyLitByE CmmLit
lhs CmmExpr
e = do
Platform
platform <- FCode Platform
getPlatform
CmmAGraph -> FCode ()
emit (CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
addToMemE (Platform -> CmmType
bWord Platform
platform) (CmmLit -> CmmExpr
CmmLit CmmLit
lhs) CmmExpr
e)
bumpHistogram :: FastString -> Int -> FCode ()
bumpHistogram :: FastString -> Int -> FCode ()
bumpHistogram FastString
lbl Int
n = do
Platform
platform <- FCode Platform
getPlatform
let offset :: Int
offset = Int
n Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` (PlatformConstants -> Int
pc_TICKY_BIN_COUNT (Platform -> PlatformConstants
platformConstants Platform
platform) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
CmmAGraph -> FCode ()
emit (CmmType -> CmmExpr -> Int -> CmmAGraph
addToMem (Platform -> CmmType
bWord Platform
platform)
(Platform -> Width -> CmmExpr -> CmmExpr -> CmmExpr
cmmIndexExpr Platform
platform
(Platform -> Width
wordWidth Platform
platform)
(CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (FastString -> CLabel
mkRtsCmmDataLabel FastString
lbl)))
(CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset) (Platform -> Width
wordWidth Platform
platform))))
Int
1)
showTypeCategory :: Type -> Char
showTypeCategory :: Type -> Char
showTypeCategory Type
ty
| Type -> Bool
isDictTy Type
ty = Char
'+'
| Bool
otherwise = case HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty of
Maybe (TyCon, [Type])
Nothing -> Char
'.'
Just (TyCon
tycon, [Type]
_) ->
let anyOf :: [Unique] -> Bool
anyOf [Unique]
us = TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tycon Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique]
us in
case () of
()
_ | [Unique] -> Bool
anyOf [Unique
fUNTyConKey] -> Char
'>'
| [Unique] -> Bool
anyOf [Unique
charTyConKey] -> Char
'C'
| [Unique] -> Bool
anyOf [Unique
charPrimTyConKey] -> Char
'c'
| [Unique] -> Bool
anyOf [Unique
doubleTyConKey] -> Char
'D'
| [Unique] -> Bool
anyOf [Unique
doublePrimTyConKey] -> Char
'd'
| [Unique] -> Bool
anyOf [Unique
floatTyConKey] -> Char
'F'
| [Unique] -> Bool
anyOf [Unique
floatPrimTyConKey] -> Char
'f'
| [Unique] -> Bool
anyOf [Unique
intTyConKey, Unique
int8TyConKey, Unique
int16TyConKey, Unique
int32TyConKey, Unique
int64TyConKey] -> Char
'I'
| [Unique] -> Bool
anyOf [Unique
intPrimTyConKey, Unique
int8PrimTyConKey, Unique
int16PrimTyConKey, Unique
int32PrimTyConKey, Unique
int64PrimTyConKey] -> Char
'i'
| [Unique] -> Bool
anyOf [Unique
wordTyConKey, Unique
word8TyConKey, Unique
word16TyConKey, Unique
word32TyConKey, Unique
word64TyConKey] -> Char
'W'
| [Unique] -> Bool
anyOf [Unique
wordPrimTyConKey, Unique
word8PrimTyConKey, Unique
word16PrimTyConKey, Unique
word32PrimTyConKey, Unique
word64PrimTyConKey] -> Char
'w'
| [Unique] -> Bool
anyOf [Unique
listTyConKey] -> Char
'L'
| TyCon -> Bool
isUnboxedTupleTyCon TyCon
tycon -> Char
't'
| TyCon -> Bool
isTupleTyCon TyCon
tycon -> Char
'T'
| TyCon -> Bool
isPrimTyCon TyCon
tycon -> Char
'P'
| TyCon -> Bool
isEnumerationTyCon TyCon
tycon -> Char
'E'
| Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isJust (TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tycon) -> Char
'S'
| Bool
otherwise -> Char
'M'