{-# LANGUAGE OverloadedStrings #-}

module GHC.StgToJS.Profiling
  ( initCostCentres
  , emitCostCentreDecl
  , emitCostCentreStackDecl
  , enterCostCentreFun
  , enterCostCentreThunk
  , setCC
  , pushRestoreCCS
  , jCurrentCCS
  , jCafCCS
  , jSystemCCS
  , costCentreLbl
  , costCentreStackLbl
  , singletonCCSLbl
  , ccsVarJ
  -- * Predicates
  , profiling
  , ifProfiling
  , ifProfilingM
  -- * helpers
  , profStat
  )
where

import GHC.Prelude

import GHC.JS.Unsat.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

--------------------------------------------------------------------------------
-- Initialization

initCostCentres :: CollectedCCs -> G ()
initCostCentres :: CollectedCCs -> G ()
initCostCentres ([CostCentre]
local_CCs, [CostCentreStack]
singleton_CCSs) = do
    (CostCentre -> G ()) -> [CostCentre] -> G ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CostCentre -> G ()
emitCostCentreDecl [CostCentre]
local_CCs
    (CostCentreStack -> G ()) -> [CostCentreStack] -> G ()
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 (ModuleName -> [Char]) -> ModuleName -> [Char]
forall a b. (a -> b) -> a -> b
$ GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (GenModule Unit -> ModuleName) -> GenModule Unit -> ModuleName
forall a b. (a -> b) -> a -> b
$ CostCentre -> GenModule Unit
cc_mod CostCentre
cc
      loc :: [Char]
loc    = SDocContext -> SDoc -> [Char]
renderWithContext SDocContext
defaultSDocContext (SrcSpan -> SDoc
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")
                                                  [ [Char] -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [Char]
label
                                                  , [Char] -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [Char]
modl
                                                  , [Char] -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [Char]
loc
                                                  , Bool -> JExpr
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_, Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
ccLbl])
        JStat -> G ()
emitGlobal JStat
js
      Maybe CostCentre
Nothing -> [Char] -> SDoc -> G ()
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"emitCostCentreStackDecl" (CostCentreStack -> SDoc
forall a. Outputable a => a -> SDoc
ppr CostCentreStack
ccs)

--------------------------------------------------------------------------------
-- Entering to cost-centres

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 = JStat
forall a. Monoid a => a
mempty -- top-level function, nothing to do

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 (OtherSymb -> G ()) -> OtherSymb -> G ()
forall a b. (a -> b) -> a -> b
$ GenModule Unit -> FastString -> OtherSymb
OtherSymb (CostCentre -> GenModule Unit
cc_mod CostCentre
cc)
                            (GenModule Unit -> FastString
moduleGlobalSymbol (GenModule Unit -> FastString) -> GenModule Unit -> FastString
forall a b. (a -> b) -> a -> b
$ CostCentre -> GenModule Unit
cc_mod CostCentre
cc)
  JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ JExpr
jCurrentCCS JExpr -> JExpr -> JStat
|= JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$pushCostCentre") [JExpr
jCurrentCCS, Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
ccI]
setCC CostCentre
_cc Bool
_tick Bool
_push = JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStat
forall a. Monoid a => a
mempty

pushRestoreCCS :: JStat
pushRestoreCCS :: JStat
pushRestoreCCS = JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
"h$pushRestoreCCS") []

--------------------------------------------------------------------------------
-- Some cost-centre stacks to be used in generator

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"
--------------------------------------------------------------------------------
-- Helpers for generating profiling related things

profiling :: G Bool
profiling :: G Bool
profiling = StgToJSConfig -> Bool
csProf (StgToJSConfig -> Bool)
-> StateT GenState IO StgToJSConfig -> G Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO 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
    m -> G m
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (m -> G m) -> m -> G m
forall a b. (a -> b) -> a -> b
$ if Bool
prof then m
m else m
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 m -> G m
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return m
forall a. Monoid a => a
mempty

-- | If profiling is enabled, then use input JStat, else ignore
profStat :: StgToJSConfig -> JStat -> JStat
profStat :: StgToJSConfig -> JStat -> JStat
profStat StgToJSConfig
cfg JStat
e = if StgToJSConfig -> Bool
csProf StgToJSConfig
cfg then JStat
e else JStat
forall a. Monoid a => a
mempty
--------------------------------------------------------------------------------
-- Generating cost-centre and cost-centre stack variables

costCentreLbl' :: CostCentre -> G String
costCentreLbl' :: CostCentre -> G [Char]
costCentreLbl' CostCentre
cc = do
  GenModule Unit
curModl <- (GenState -> GenModule Unit) -> StateT GenState IO (GenModule Unit)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> GenModule Unit
gsModule
  let lbl :: [Char]
lbl = SDocContext -> SDoc -> [Char]
renderWithContext SDocContext
defaultSDocContext
              (SDoc -> [Char]) -> SDoc -> [Char]
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
PprCode (CostCentre -> SDoc
forall a. Outputable a => a -> SDoc
ppr CostCentre
cc)
  [Char] -> G [Char]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> G [Char]) -> ([Char] -> [Char]) -> [Char] -> G [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"h$"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
zEncodeString ([Char] -> G [Char]) -> [Char] -> G [Char]
forall a b. (a -> b) -> a -> b
$
    ModuleName -> [Char]
moduleNameColons (GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
curModl) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_" [Char] -> [Char] -> [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 (FastString -> Ident) -> ([Char] -> FastString) -> [Char] -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString ([Char] -> Ident) -> G [Char] -> G Ident
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
  G (Maybe [Char]) -> G (Maybe [Char])
forall m. Monoid m => G m -> G m
ifProfilingM G (Maybe [Char])
f
  where
    f :: G (Maybe [Char])
f | CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs   = Maybe [Char] -> G (Maybe [Char])
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> G (Maybe [Char]))
-> Maybe [Char] -> G (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"h$currentThread.ccs"
      | CostCentreStack
dontCareCCS CostCentreStack -> CostCentreStack -> Bool
forall a. Eq a => a -> a -> Bool
== CostCentreStack
ccs = Maybe [Char] -> G (Maybe [Char])
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> G (Maybe [Char]))
-> Maybe [Char] -> G (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"h$CCS_DONT_CARE"
      | Bool
otherwise          =
          case CostCentreStack -> Maybe CostCentre
maybeSingletonCCS CostCentreStack
ccs of
            Just CostCentre
cc -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> G [Char] -> G (Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CostCentre -> G [Char]
singletonCCSLbl' CostCentre
cc
            Maybe CostCentre
Nothing -> Maybe [Char] -> G (Maybe [Char])
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing

costCentreStackLbl :: CostCentreStack -> G (Maybe Ident)
costCentreStackLbl :: CostCentreStack -> G (Maybe Ident)
costCentreStackLbl CostCentreStack
ccs = ([Char] -> Ident) -> Maybe [Char] -> Maybe Ident
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FastString -> Ident
TxtI (FastString -> Ident) -> ([Char] -> FastString) -> [Char] -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString) (Maybe [Char] -> Maybe Ident)
-> G (Maybe [Char]) -> G (Maybe Ident)
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
    GenModule Unit
curModl <- (GenState -> GenModule Unit) -> StateT GenState IO (GenModule Unit)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> GenModule Unit
gsModule
    [Char]
ccLbl   <- CostCentre -> G [Char]
costCentreLbl' CostCentre
cc
    let ccsLbl :: [Char]
ccsLbl = [Char]
ccLbl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_ccs"
    [Char] -> G [Char]
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> G [Char]) -> ([Char] -> [Char]) -> [Char] -> G [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
zEncodeString ([Char] -> G [Char]) -> [Char] -> G [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat
              [ ModuleName -> [Char]
moduleNameColons (GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
curModl)
              , [Char]
"_"
              , [Char]
ccsLbl
              ]

singletonCCSLbl :: CostCentre -> G Ident
singletonCCSLbl :: CostCentre -> G Ident
singletonCCSLbl CostCentre
cc = FastString -> Ident
TxtI (FastString -> Ident) -> ([Char] -> FastString) -> [Char] -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString ([Char] -> Ident) -> G [Char] -> G Ident
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 (Ident -> JExpr) -> Maybe Ident -> Maybe JExpr
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (JVal -> JExpr
ValExpr (JVal -> JExpr) -> (Ident -> JVal) -> Ident -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar) (Maybe Ident -> Maybe JExpr) -> G (Maybe Ident) -> G (Maybe JExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CostCentreStack -> G (Maybe Ident)
costCentreStackLbl CostCentreStack
ccs
    else Maybe JExpr -> G (Maybe JExpr)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe JExpr
forall a. Maybe a
Nothing