{-# LANGUAGE MultiWayIf #-}

-----------------------------------------------------------------------------
--
-- Code generation for ticky-ticky profiling
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

{- OVERVIEW: ticky ticky profiling

Please see
https://gitlab.haskell.org/ghc/ghc/wikis/debugging/ticky-ticky and also
edit it and the rest of this comment to keep them up-to-date if you
change ticky-ticky. Thanks!

 *** All allocation ticky numbers are in bytes. ***

Some of the relevant source files:

       ***not necessarily an exhaustive list***

  * some codeGen/ modules import this one

  * this module imports GHC.Cmm.CLabel to manage labels

  * GHC.Cmm.Parser expands some macros using generators defined in
    this module

  * rts/include/stg/Ticky.h declares all of the global counters

  * rts/include/rts/Ticky.h declares the C data type for an
    STG-declaration's counters

  * some macros defined in rts/include/Cmm.h (and used within the RTS's
    CMM code) update the global ticky counters

  * at the end of execution rts/Ticky.c generates the final report
    +RTS -r<report-file> -RTS

The rts/Ticky.c function that generates the report includes an
STG-declaration's ticky counters if

  * that declaration was entered, or

  * it was allocated (if -ticky-allocd)

On either of those events, the counter is "registered" by adding it to
a linked list; cf the CMM generated by registerTickyCtr.

Ticky-ticky profiling has evolved over many years. Many of the
counters from its most sophisticated days are no longer
active/accurate. As the RTS has changed, sometimes the ticky code for
relevant counters was not accordingly updated. Unfortunately, neither
were the comments.

As of March 2013, there still exist deprecated code and comments in
the code generator as well as the RTS because:

  * I don't know what is out-of-date versus merely commented out for
    momentary convenience, and

  * someone else might know how to repair it!


Note [Ticky counters are static]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Currently GHC only supports static ticky events. That is -ticky emits
code containing labels containing counters which then get bumped at runtime.

There are currently only *static* ticky counters. Either we bump one of the
static counters included in the RTS. Or we emit StgEntCounter structures in
the object code and bump these.
-}

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, toArgRepOrV, 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)

-- Turgid imports for showTypeCategory
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
import GHC.Utils.Unique (anyOfUnique)

-----------------------------------------------------------------------------
--
-- Ticky-ticky profiling
--
-----------------------------------------------------------------------------

-- | Number of arguments for a ticky counter.
--
-- Ticky currently treats args to constructor allocations differently than those for functions/LNE bindings.
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 -- True <-> single entry
        [NonVoid Id] -- ^ FVs
        [NonVoid Id] -- ^ Args
    | TickyCon
        DataCon -- the allocated constructor
        ConstructorNumber
    | TickyThunk
        Bool -- True <-> updateable
        Bool -- True <-> standard thunk (AP or selector), has no entry counter
        [StgArg] -- ^ FVS, StgArg because for thunks these can also be literals.
    | TickyLNE
        [NonVoid Id] -- ^ Args

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
  b <- (StgToCmmConfig -> Bool) -> FCode Bool
isEnabled StgToCmmConfig -> Bool
stgToCmmTickyLNE
  if not b then code else withNewTickyCounter (TickyLNE args) nm 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 -- ^ static
  -> Bool -- ^ updateable
  -> Id
  -> [NonVoid Id] -- ^ Free vars
  -> 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
    has_ctr <- Bool -> FCode Bool
thunkHasCounter Bool
isStatic
    if not has_ctr
      then code
      else withNewTickyCounter (TickyThunk isUpdatable False (map StgVarArg $ coerce fvs)) name code

withNewTickyCounterStdThunk
  :: Bool -- ^ updateable
  -> Id
  -> [StgArg] -- ^ Free vars + function
  -> 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
    has_ctr <- Bool -> FCode Bool
thunkHasCounter Bool
False
    if not has_ctr
      then code
      else withNewTickyCounter (TickyThunk isUpdatable True fvs) name 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
    has_ctr <- Bool -> FCode Bool
thunkHasCounter Bool
False
    if not has_ctr
      then code
      else withNewTickyCounter (TickyCon datacon info) name code

-- args does not include the void arguments
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
  lbl <- TickyClosureType -> Id -> FCode CLabel
emitTickyCounter TickyClosureType
cloType Id
name
  setTickyCtrLabel lbl m

emitTickyData :: Platform
              -> CLabel -- ^ lbl for the counter
              -> Arity -- ^ arity
              -> CmmLit -- ^ fun desc
              -> CmmLit -- ^ arg desc
              -> CmmLit -- ^ json desc
              -> CmmLit -- ^ info table lbl
              -> 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
    -- Must match layout of rts/include/rts/Ticky.h's StgEntCounter
    --
    -- krc: note that all the fields are I32 now; some were I16
    -- before, but the code generator wasn't handling that
    -- properly and it led to chaos, panic and disorder.
        [ Platform -> CmmLit
zeroCLit Platform
platform,               -- registered?
          Platform -> Int -> CmmLit
mkIntCLit Platform
platform Int
arity,   -- Arity
          Platform -> CmmLit
zeroCLit Platform
platform,               -- Heap allocated for this thing
          CmmLit
fun_desc,
          CmmLit
arg_desc,
          CmmLit
json_desc,
          CmmLit
info_tbl,
          Platform -> CmmLit
zeroCLit Platform
platform,          -- Entries into this thing
          Platform -> CmmLit
zeroCLit Platform
platform,          -- Heap allocated by this thing
          Platform -> CmmLit
zeroCLit Platform
platform           -- Link to next StgEntCounter
        ]


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
        { cfg    <- FCode StgToCmmConfig
getStgToCmmConfig
        ; parent <- getTickyCtrLabel
        ; mod_name <- getModuleName

          -- When printing the name of a thing in a ticky file, we
          -- want to give the module name even for *local* things.  We
          -- print just "x (M)" rather that "M.x" to distinguish them
          -- from the global kind by calling to @pprTickyName@
        ; let platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
              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
                            -- NB the default "top" ticky ctr does not
                            -- have a Haskell name
                          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
        ; this_mod <- getModuleName
        ; let t = case TickyClosureType
cloType of
                    TickyCon {} -> String
"C"
                    TickyFun {} -> String
"F"
                    TickyThunk {} -> String
"T"
                    TickyLNE {} -> String
"L"
        ; info_lbl <- case 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
                              -- IPE Maps have no entry for std thunks.
                              | Bool
otherwise
                              -> do
                                    lf_info <- Name -> FCode (Maybe CgIdInfo)
getCgInfo_maybe Name
name
                                    profile <- getProfile
                                    case 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
defaultSDocContext {sdocPprDebug = True}
        ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name
        ; arg_descr_lit <- newStringCLit $ tickyArgDesc cloType
        ; json_descr_lit <- newStringCLit $ tickyEntryDescJson ctx cloType
        ; emitTickyData platform ctr_lbl (tickyArgArity cloType) fun_descr_lit arg_descr_lit json_descr_lit info_lbl
        }

{- Note [TagSkip ticky counters]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
These counters keep track how often we execute code where we
would have performed a tag check if we hadn't run tag inference.

If we have some code of the form:
    case v[tagged] of ...
and we want to record how often we avoid a tag check on v
through tag inference we have to emit a new StgEntCounter for
each such case statement in order to record how often it's executed.

In theory we could emit one per *binding*. But then we
would have to either keep track of the bindings which
already have a StgEntCounter associated with them in the
code gen state or preallocate such a structure for each binding
in the code unconditionally (since ticky-code can call non-ticky code)

The first makes the compiler slower, even when ticky is not
used (a big no no). The later is fairly complex but increases code size
unconditionally. See also Note [Ticky counters are static].

So instead we emit a new StgEntCounter for each use site of a binding
where we infered a tag to be present. And increment the counter whenever
this use site is executed.

We use the fields as follows:

entry_count: Entries avoided.
str:       : Name of the id.

We use emitTickyCounterTag to emit the counter.

Unlike the closure counters each *use* site of v has it's own
counter. So there is no need to keep track of the closure/case we are
in.

We also have to pass a unique for the counter. An Id might be
scrutinized in more than one place, so the ID alone isn't enough
to distinguish between use sites.
-}

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 <- FCode Platform
getPlatform
        ; parent <- getTickyCtrLabel
        ; mod_name <- getModuleName

          -- When printing the name of a thing in a ticky file, we
          -- want to give the module name even for *local* things.  We
          -- print just "x (M)" rather that "M.x" to distinguish them
          -- from the global kind.
        ; let 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 -- parens (text "tagged")
                    p :: SDoc
p = case CLabel -> Maybe Name
hasHaskellName CLabel
parent of
                            -- NB the default "top" ticky ctr does not
                            -- have a Haskell name
                          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
        ; sdoc_context <- stgToCmmContext <$> getStgToCmmConfig
        ; fun_descr_lit <- newStringCLit $ renderWithContext sdoc_context ppr_for_ticky_name
        ; arg_descr_lit <- newStringCLit $ "infer"
        ; json_descr_lit <- newStringCLit $ "infer"
        ; emitTickyData platform ctr_lbl 0 fun_descr_lit arg_descr_lit json_descr_lit (zeroCLit platform)
        }
-- -----------------------------------------------------------------------------
-- Ticky stack frames

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")

-- -----------------------------------------------------------------------------
-- Ticky entries

-- NB the name-specific entries are only available for names that have
-- dedicated Cmm code. As far as I know, this just rules out
-- constructor thunks. For them, there is no CMM code block to put the
-- bump of name-specific ticky counter into. On the other hand, we can
-- still track allocation their allocation.

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
    ; has_ctr <- Bool -> FCode Bool
thunkHasCounter Bool
static
    ; when has_ctr $ do
      ticky_ctr_lbl <- getTickyCtrLabel
      registerTickyCtrAtEntryDyn ticky_ctr_lbl
      bumpTickyEntryCount 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
  ctr_lbl <- FCode CLabel
getTickyCtrLabel

  if isStaticClosure cl_info
    then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")
            registerTickyCtr ctr_lbl
    else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")
            registerTickyCtrAtEntryDyn ctr_lbl

  bumpTickyEntryCount 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
    ctr_lbl <- FCode CLabel
getTickyCtrLabel
    registerTickyCtr ctr_lbl
    bumpTickyEntryCount ctr_lbl

-- needn't register a counter upon entry if
--
-- 1) it's for a dynamic closure, and
--
-- 2) -ticky-allocd is on
--
-- since the counter was registered already upon being alloc'd
registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
registerTickyCtrAtEntryDyn CLabel
ctr_lbl = do
  already_registered <- (StgToCmmConfig -> Bool) -> FCode Bool
isEnabled StgToCmmConfig -> Bool
stgToCmmTickyAllocd
  unless already_registered $ registerTickyCtr ctr_lbl

-- | Register a ticky counter.
--
-- It's important that this does not race with other entries of the same
-- closure, lest the ticky_entry_ctrs list may become cyclic. However, we also
-- need to make sure that this is reasonably efficient. Consequently, we first
-- perform a normal load of the counter's "registered" flag to check whether
-- registration is necessary. If so, then we do a compare-and-swap to lock the
-- counter for registration and use an atomic-exchange to add the counter to the list.
--
-- @
-- if ( f_ct.registeredp == 0 ) {
--    if (cas(f_ct.registeredp, 0, 1) == 0) {
--        old_head = xchg(ticky_entry_ctrs,  f_ct);
--        f_ct.link = old_head;
--    }
-- }
-- @
registerTickyCtr :: CLabel -> FCode ()
registerTickyCtr :: CLabel -> FCode ()
registerTickyCtr CLabel
ctr_lbl = do
  platform <- FCode Platform
getPlatform
  let constants = Platform -> PlatformConstants
platformConstants Platform
platform
      word_width = Platform -> Width
wordWidth Platform
platform
      registeredp = CmmLit -> CmmExpr
CmmLit (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
ctr_lbl (PlatformConstants -> Int
pc_OFFSET_StgEntCounter_registeredp PlatformConstants
constants))

  register_stmts <- getCode $ do
    old_head <- newTemp (bWord platform)
    let ticky_entry_ctrs = CLabel -> CmmExpr
mkLblExpr (FastString -> CLabel
mkRtsCmmDataLabel (String -> FastString
fsLit String
"ticky_entry_ctrs"))
        link = CmmLit -> CmmExpr
CmmLit (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
ctr_lbl (PlatformConstants -> Int
pc_OFFSET_StgEntCounter_link PlatformConstants
constants))
    emitPrimCall [old_head] (MO_Xchg word_width) [ticky_entry_ctrs, mkLblExpr ctr_lbl]
    emitStore link (CmmReg $ CmmLocal old_head)

  cas_test <- getCode $ do
    old <- newTemp (bWord platform)
    emitPrimCall [old] (MO_Cmpxchg word_width)
        [registeredp, zeroExpr platform, mkIntExpr platform 1]
    let 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)
    emit =<< mkCmmIfThen locked register_stmts

  let test = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmEqWord Platform
platform (Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform CmmExpr
registeredp) (Platform -> CmmExpr
zeroExpr Platform
platform)
  emit =<< mkCmmIfThen test 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 }

-- -----------------------------------------------------------------------------
-- Ticky calls

-- Ticks at a *call site*:
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
                   [StgArg] -> FCode ()
tickySlowCallPat (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 ()
tickyKnownCallExtraArgs :: FCode ()
tickyKnownCallExtraArgs  = 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")

-- Tick for the call pattern at slow call site (i.e. in addition to
-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
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
 -- see Note [Ticky for slow calls]
 if LambdaFormInfo -> Bool
isKnownFun LambdaFormInfo
lf_info
   then FCode ()
tickyKnownCallTooFewArgs
   else FCode ()
tickyUnknownCall
 [StgArg] -> FCode ()
tickySlowCallPat [StgArg]
args

tickySlowCallPat :: [StgArg] -> FCode ()
tickySlowCallPat :: [StgArg] -> FCode ()
tickySlowCallPat [StgArg]
args = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
  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 = (StgArg -> ArgRep) -> [StgArg] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimOrVoidRep -> ArgRep
toArgRepOrV Platform
platform (PrimOrVoidRep -> ArgRep)
-> (StgArg -> PrimOrVoidRep) -> StgArg -> ArgRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> PrimOrVoidRep
stgArgRep1) [StgArg]
args
      (_, n_matched) = slowCallPattern argReps
  if n_matched > 0 && args `lengthIs` n_matched
     then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps
     else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"

{-

Note [Ticky for slow calls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Terminology is unfortunately a bit mixed up for these calls. codeGen
uses "slow call" to refer to unknown calls and under-saturated known
calls.

Nowadays, though (ie as of the eval/apply paper), the significantly
slower calls are actually just a subset of these: the ones with no
built-in argument pattern (cf GHC.StgToCmm.ArgRep.slowCallPattern)

So for ticky profiling, we split slow calls into
"SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and
VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very
bad for both space and time).

-}

-- -----------------------------------------------------------------------------
-- Ticky allocation

tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
-- Called when doing a dynamic heap allocation; the LambdaFormInfo
-- used to distinguish between closure types
--
-- TODO what else to count while we're here?
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 <- FCode Profile
getProfile
  let platform = Profile -> Platform
profilePlatform Profile
profile
      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
tot FastString
ctr = do
        FastString -> Int -> FCode ()
bumpTickyCounterBy FastString
tot Int
bytes
        FastString -> FCode ()
bumpTickyCounter   FastString
ctr
      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

  -- TODO are we still tracking "good stuff" (_gds) versus
  -- administrative (_adm) versus slop (_slp)? I'm going with all _gds
  -- for now, since I don't currently know neither if we do nor how to
  -- distinguish. NSF Mar 2013

  if | isConRep rep   ->
         ifTickyDynThunk countSpecific >>
         countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")
     | isThunkRep rep ->
         ifTickyDynThunk countSpecific >>
         if lfUpdatable lf
         then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")
         else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")
     | isFunRep   rep ->
         countSpecific >>
         countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")
     | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"



tickyAllocHeap ::
  Bool -> -- is this a genuine allocation? As opposed to
          -- GHC.StgToCmm.Layout.adjustHpBackwards
  VirtualHpOffset -> FCode ()
-- Called when doing a heap check [TICK_ALLOC_HEAP]
-- Must be lazy in the amount of allocation!
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 <- FCode Platform
getPlatform
        ; ticky_ctr <- getTickyCtrLabel
        ; emit $ catAGraphs $
            -- only test hp from within the emit so that the monadic
            -- computation itself is not strict in hp (cf knot in
            -- GHC.StgToCmm.Monad.getHeapUsage)
          if hp == 0 then []
          else let !bytes = Platform -> Int
platformWordSizeInBytes Platform
platform Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
hp in [
            -- Bump the allocation total in the closure's StgEntCounter
            addToMem (rEP_StgEntCounter_allocs platform)
                     (CmmLit (cmmLabelOffB ticky_ctr (pc_OFFSET_StgEntCounter_allocs (platformConstants platform))))
                     bytes,
            -- Bump the global allocation total ALLOC_HEAP_tot
            addToMemLbl (bWord platform)
                        (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_tot"))
                        bytes,
            -- Bump the global allocation counter ALLOC_HEAP_ctr
            if not genuine then mkNop
            else addToMemLbl (bWord platform)
                             (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_ctr"))
                             1
            ]}


--------------------------------------------------------------------------------
-- these three are only called from GHC.Cmm.Parser (ie ultimately from the RTS)

-- the units are bytes

tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes
               -> CmmExpr  -- ^ size of the payload, in bytes
               -> 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
    -- TODO is it ever called with a Single-Entry thunk?
  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")

-- -----------------------------------------------------------------------------
-- Ticky for tag inference characterisation

-- | Predicted a pointer would be tagged correctly (GHC will crash if not so no miss case)
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")

-- | Pass a boolean expr indicating if tag was present.
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

-- | Called when for `case v of ...` we can avoid entering v based on
-- tag inference information.
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

-- -----------------------------------------------------------------------------
-- Ticky utils

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 <- FCode Platform
getPlatform
  bumpTickyLit (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform)))

bumpTickyAllocd :: CLabel -> Int -> FCode ()
bumpTickyAllocd :: CLabel -> Int -> FCode ()
bumpTickyAllocd CLabel
lbl Int
bytes = do
  platform <- FCode Platform
getPlatform
  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes

bumpTickyTagSkip :: CLabel -> FCode ()
bumpTickyTagSkip :: CLabel -> FCode ()
bumpTickyTagSkip CLabel
lbl = do
  platform <- FCode Platform
getPlatform
  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) 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 = CmmExpr -> Int -> FCode ()
emitAddToMem (CmmLit -> CmmExpr
CmmLit CmmLit
lhs) Int
n

bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
bumpTickyLitByE CmmLit
lhs CmmExpr
e = CmmExpr -> CmmExpr -> FCode ()
emitAddToMemE (CmmLit -> CmmExpr
CmmLit CmmLit
lhs) CmmExpr
e

bumpHistogram :: FastString -> Int -> FCode ()
bumpHistogram :: FastString -> Int -> FCode ()
bumpHistogram FastString
lbl Int
n = do
    platform <- FCode Platform
getPlatform
    let 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)
    let addr =
           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)))
    emitAddToMem addr 1

emitAddToMem :: CmmExpr -> Int -> FCode ()
emitAddToMem :: CmmExpr -> Int -> FCode ()
emitAddToMem CmmExpr
lhs Int
n = do
  platform <- FCode Platform
getPlatform
  emitAddToMemE lhs (mkIntExpr platform n)

emitAddToMemE :: CmmExpr -> CmmExpr -> FCode ()
emitAddToMemE :: CmmExpr -> CmmExpr -> FCode ()
emitAddToMemE CmmExpr
lhs CmmExpr
n = do
  platform <- FCode Platform
getPlatform
  val <- newTemp (bWord platform)
  emitAtomicRead MemOrderRelaxed val lhs
  let val' = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExpr Platform
platform (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
val)) CmmExpr
n
  emitAtomicWrite MemOrderRelaxed lhs val'

------------------------------------------------------------------
-- Showing the "type category" for ticky-ticky profiling

showTypeCategory :: Type -> Char
  {-
        +           dictionary

        >           function

        {C,I,F,D,W} char, int, float, double, word
        {c,i,f,d,w} unboxed ditto

        T           tuple

        P           other primitive type
        p           unboxed ditto

        L           list
        E           enumeration type
        S           other single-constructor type
        M           other multi-constructor data-con type

        .           other type

        -           reserved for others to mark as "uninteresting"

  Accurate as of Mar 2013, but I eliminated the Array category instead
  of updating it, for simplicity. It's in P/p, I think --NSF

    -}
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]
_) ->
    case () of
      ()
_ | TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tycon [Unique
fUNTyConKey] -> Char
'>'
        | TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tycon [Unique
charTyConKey] -> Char
'C'
        | TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tycon [Unique
charPrimTyConKey] -> Char
'c'
        | TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tycon [Unique
doubleTyConKey] -> Char
'D'
        | TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tycon [Unique
doublePrimTyConKey] -> Char
'd'
        | TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tycon [Unique
floatTyConKey] -> Char
'F'
        | TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tycon [Unique
floatPrimTyConKey] -> Char
'f'
        | TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tycon [Unique
intTyConKey, Unique
int8TyConKey, Unique
int16TyConKey, Unique
int32TyConKey, Unique
int64TyConKey] -> Char
'I'
        | TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tycon [Unique
intPrimTyConKey, Unique
int8PrimTyConKey, Unique
int16PrimTyConKey, Unique
int32PrimTyConKey, Unique
int64PrimTyConKey] -> Char
'i'
        | TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tycon [Unique
wordTyConKey, Unique
word8TyConKey, Unique
word16TyConKey, Unique
word32TyConKey, Unique
word64TyConKey] -> Char
'W'
        | TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tycon [Unique
wordPrimTyConKey, Unique
word8PrimTyConKey, Unique
word16PrimTyConKey, Unique
word32PrimTyConKey, Unique
word64PrimTyConKey] -> Char
'w'
        | TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tycon [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' -- oh, well...