{-# LANGUAGE OverloadedStrings #-}
module GHC.StgToJS.Profiling
( initCostCentres
, emitCostCentreDecl
, emitCostCentreStackDecl
, enterCostCentreFun
, enterCostCentreThunk
, setCC
, pushRestoreCCS
, jCurrentCCS
, jCafCCS
, jSystemCCS
, costCentreLbl
, costCentreStackLbl
, singletonCCSLbl
, ccsVarJ
, profiling
, ifProfiling
, ifProfilingM
, profStat
)
where
import GHC.Prelude
import GHC.JS.Syntax
import GHC.JS.Make
import GHC.StgToJS.Regs
import GHC.StgToJS.Types
import GHC.StgToJS.Symbols
import GHC.StgToJS.Monad
import GHC.Types.CostCentre
import GHC.Data.FastString
import GHC.Unit.Module
import GHC.Utils.Encoding
import GHC.Utils.Outputable
import GHC.Utils.Panic
import qualified Control.Monad.Trans.State.Strict as State
initCostCentres :: CollectedCCs -> G ()
initCostCentres :: CollectedCCs -> G ()
initCostCentres ([CostCentre]
local_CCs, [CostCentreStack]
singleton_CCSs) = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CostCentre -> G ()
emitCostCentreDecl [CostCentre]
local_CCs
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CostCentreStack -> G ()
emitCostCentreStackDecl [CostCentreStack]
singleton_CCSs
emitCostCentreDecl :: CostCentre -> G ()
emitCostCentreDecl :: CostCentre -> G ()
emitCostCentreDecl CostCentre
cc = do
Ident
ccsLbl <- CostCentre -> G Ident
costCentreLbl CostCentre
cc
let is_caf :: Bool
is_caf = CostCentre -> Bool
isCafCC CostCentre
cc
label :: [Char]
label = CostCentre -> [Char]
costCentreUserName CostCentre
cc
modl :: [Char]
modl = ModuleName -> [Char]
moduleNameString forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ CostCentre -> Module
cc_mod CostCentre
cc
loc :: [Char]
loc = SDocContext -> SDoc -> [Char]
renderWithContext SDocContext
defaultSDocContext (forall a. Outputable a => a -> SDoc
ppr (CostCentre -> SrcSpan
costCentreSrcSpan CostCentre
cc))
js :: JStat
js = Ident
ccsLbl Ident -> JExpr -> JStat
||= JUOp -> JExpr -> JExpr
UOpExpr JUOp
NewOp (JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$CC")
[ forall a. ToJExpr a => a -> JExpr
toJExpr [Char]
label
, forall a. ToJExpr a => a -> JExpr
toJExpr [Char]
modl
, forall a. ToJExpr a => a -> JExpr
toJExpr [Char]
loc
, forall a. ToJExpr a => a -> JExpr
toJExpr Bool
is_caf
])
JStat -> G ()
emitGlobal JStat
js
emitCostCentreStackDecl :: CostCentreStack -> G ()
emitCostCentreStackDecl :: CostCentreStack -> G ()
emitCostCentreStackDecl CostCentreStack
ccs =
case CostCentreStack -> Maybe CostCentre
maybeSingletonCCS CostCentreStack
ccs of
Just CostCentre
cc -> do
Ident
ccsLbl <- CostCentre -> G Ident
singletonCCSLbl CostCentre
cc
Ident
ccLbl <- CostCentre -> G Ident
costCentreLbl CostCentre
cc
let js :: JStat
js = Ident
ccsLbl Ident -> JExpr -> JStat
||= JUOp -> JExpr -> JExpr
UOpExpr JUOp
NewOp (JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$CCS") [JExpr
null_, forall a. ToJExpr a => a -> JExpr
toJExpr Ident
ccLbl])
JStat -> G ()
emitGlobal JStat
js
Maybe CostCentre
Nothing -> forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"emitCostCentreStackDecl" (forall a. Outputable a => a -> SDoc
ppr CostCentreStack
ccs)
enterCostCentreFun :: CostCentreStack -> JStat
enterCostCentreFun :: CostCentreStack -> JStat
enterCostCentreFun CostCentreStack
ccs
| CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs = JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
"h$enterFunCCS") [JExpr
jCurrentCCS, JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
"cc"]
| Bool
otherwise = forall a. Monoid a => a
mempty
enterCostCentreThunk :: JStat
enterCostCentreThunk :: JStat
enterCostCentreThunk = JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
"h$enterThunkCCS") [JExpr
r1 JExpr -> FastString -> JExpr
.^ FastString
"cc"]
setCC :: CostCentre -> Bool -> Bool -> G JStat
setCC :: CostCentre -> Bool -> Bool -> G JStat
setCC CostCentre
cc Bool
_tick Bool
True = do
ccI :: Ident
ccI@(TxtI FastString
_ccLbl) <- CostCentre -> G Ident
costCentreLbl CostCentre
cc
OtherSymb -> G ()
addDependency forall a b. (a -> b) -> a -> b
$ Module -> FastString -> OtherSymb
OtherSymb (CostCentre -> Module
cc_mod CostCentre
cc)
(Module -> FastString
moduleGlobalSymbol forall a b. (a -> b) -> a -> b
$ CostCentre -> Module
cc_mod CostCentre
cc)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ JExpr
jCurrentCCS JExpr -> JExpr -> JStat
|= JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$pushCostCentre") [JExpr
jCurrentCCS, forall a. ToJExpr a => a -> JExpr
toJExpr Ident
ccI]
setCC CostCentre
_cc Bool
_tick Bool
_push = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
pushRestoreCCS :: JStat
pushRestoreCCS :: JStat
pushRestoreCCS = JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
"h$pushRestoreCCS") []
jCurrentCCS :: JExpr
jCurrentCCS :: JExpr
jCurrentCCS = FastString -> JExpr
var FastString
"h$currentThread" JExpr -> FastString -> JExpr
.^ FastString
"ccs"
jCafCCS :: JExpr
jCafCCS :: JExpr
jCafCCS = FastString -> JExpr
var FastString
"h$CAF"
jSystemCCS :: JExpr
jSystemCCS :: JExpr
jSystemCCS = FastString -> JExpr
var FastString
"h$CCS_SYSTEM"
profiling :: G Bool
profiling :: G Bool
profiling = StgToJSConfig -> Bool
csProf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> G StgToJSConfig
getSettings
ifProfiling :: Monoid m => m -> G m
ifProfiling :: forall m. Monoid m => m -> G m
ifProfiling m
m = do
Bool
prof <- G Bool
profiling
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
prof then m
m else forall a. Monoid a => a
mempty
ifProfilingM :: Monoid m => G m -> G m
ifProfilingM :: forall m. Monoid m => G m -> G m
ifProfilingM G m
m = do
Bool
prof <- G Bool
profiling
if Bool
prof then G m
m else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
profStat :: StgToJSConfig -> JStat -> JStat
profStat :: StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
cfg JStat
e = if StgToJSConfig -> Bool
csProf StgToJSConfig
cfg then JStat
e else forall a. Monoid a => a
mempty
costCentreLbl' :: CostCentre -> G String
costCentreLbl' :: CostCentre -> G [Char]
costCentreLbl' CostCentre
cc = do
Module
curModl <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> Module
gsModule
let lbl :: [Char]
lbl = SDocContext -> SDoc -> [Char]
renderWithContext SDocContext
defaultSDocContext
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
PprCode (forall a. Outputable a => a -> SDoc
ppr CostCentre
cc)
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"h$"forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
zEncodeString forall a b. (a -> b) -> a -> b
$
ModuleName -> [Char]
moduleNameColons (forall unit. GenModule unit -> ModuleName
moduleName Module
curModl) forall a. [a] -> [a] -> [a]
++ [Char]
"_" forall a. [a] -> [a] -> [a]
++ if CostCentre -> Bool
isCafCC CostCentre
cc then [Char]
"CAF_ccs" else [Char]
lbl
costCentreLbl :: CostCentre -> G Ident
costCentreLbl :: CostCentre -> G Ident
costCentreLbl CostCentre
cc = FastString -> Ident
TxtI forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CostCentre -> G [Char]
costCentreLbl' CostCentre
cc
costCentreStackLbl' :: CostCentreStack -> G (Maybe String)
costCentreStackLbl' :: CostCentreStack -> G (Maybe [Char])
costCentreStackLbl' CostCentreStack
ccs = do
forall m. Monoid m => G m -> G m
ifProfilingM G (Maybe [Char])
f
where
f :: G (Maybe [Char])
f | CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Char]
"h$currentThread.ccs"
| CostCentreStack
dontCareCCS forall a. Eq a => a -> a -> Bool
== CostCentreStack
ccs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Char]
"h$CCS_DONT_CARE"
| Bool
otherwise =
case CostCentreStack -> Maybe CostCentre
maybeSingletonCCS CostCentreStack
ccs of
Just CostCentre
cc -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CostCentre -> G [Char]
singletonCCSLbl' CostCentre
cc
Maybe CostCentre
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
costCentreStackLbl :: CostCentreStack -> G (Maybe Ident)
costCentreStackLbl :: CostCentreStack -> G (Maybe Ident)
costCentreStackLbl CostCentreStack
ccs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FastString -> Ident
TxtI forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CostCentreStack -> G (Maybe [Char])
costCentreStackLbl' CostCentreStack
ccs
singletonCCSLbl' :: CostCentre -> G String
singletonCCSLbl' :: CostCentre -> G [Char]
singletonCCSLbl' CostCentre
cc = do
Module
curModl <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> Module
gsModule
[Char]
ccLbl <- CostCentre -> G [Char]
costCentreLbl' CostCentre
cc
let ccsLbl :: [Char]
ccsLbl = [Char]
ccLbl forall a. [a] -> [a] -> [a]
++ [Char]
"_ccs"
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
zEncodeString forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ ModuleName -> [Char]
moduleNameColons (forall unit. GenModule unit -> ModuleName
moduleName Module
curModl)
, [Char]
"_"
, [Char]
ccsLbl
]
singletonCCSLbl :: CostCentre -> G Ident
singletonCCSLbl :: CostCentre -> G Ident
singletonCCSLbl CostCentre
cc = FastString -> Ident
TxtI forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CostCentre -> G [Char]
singletonCCSLbl' CostCentre
cc
ccsVarJ :: CostCentreStack -> G (Maybe JExpr)
ccsVarJ :: CostCentreStack -> G (Maybe JExpr)
ccsVarJ CostCentreStack
ccs = do
Bool
prof <- G Bool
profiling
if Bool
prof
then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (JVal -> JExpr
ValExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CostCentreStack -> G (Maybe Ident)
costCentreStackLbl CostCentreStack
ccs
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing