{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}

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.Syntax
import GHC.JS.JStg.Syntax (JStgExpr)
import qualified GHC.JS.JStg.Syntax as JStg
import GHC.JS.Make
import GHC.JS.Ident

import GHC.StgToJS.Monad
import GHC.StgToJS.Regs
import GHC.StgToJS.Symbols
import GHC.StgToJS.Types

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

--------------------------------------------------------------------------------
-- Symbols

hdCC :: JStgExpr
hdCC :: JStgExpr
hdCC = FastString -> JStgExpr
JStg.global FastString
"h$CC"

hdCCS :: JStgExpr
hdCCS :: JStgExpr
hdCCS = FastString -> JStgExpr
JStg.global FastString
"h$CCS"

hdEnterFunCCS :: JStgExpr
hdEnterFunCCS :: JStgExpr
hdEnterFunCCS = FastString -> JStgExpr
JStg.global FastString
"h$enterFunCCS"

cc :: Ident
cc :: Ident
cc = FastString -> Ident
name FastString
"cc"

ccs :: Ident
ccs :: Ident
ccs = FastString -> Ident
name FastString
"ccs"

hdPushCostCentre :: JStgExpr
hdPushCostCentre :: JStgExpr
hdPushCostCentre = FastString -> JStgExpr
JStg.global FastString
"h$pushCostCentre"

hdPushRestoreCCS :: JStgExpr
hdPushRestoreCCS :: JStgExpr
hdPushRestoreCCS = FastString -> JStgExpr
JStg.global FastString
"h$pushRestoreCCS"

hdEnterThunkCCS :: JStgExpr
hdEnterThunkCCS :: JStgExpr
hdEnterThunkCCS = FastString -> JStgExpr
JStg.global FastString
"h$enterThunkCCS"

--------------------------------------------------------------------------------
-- 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
  ccsLbl <- CostCentre -> G Ident
costCentreLbl CostCentre
cc
  let is_caf = CostCentre -> Bool
isCafCC CostCentre
cc
      label  = CostCentre -> [Char]
costCentreUserName CostCentre
cc
      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    = SDocContext -> SDoc -> [Char]
renderWithContext SDocContext
defaultSDocContext (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CostCentre -> SrcSpan
costCentreSrcSpan CostCentre
cc))
      js     = Ident -> Maybe JStgExpr -> JStgStat
JStg.DeclStat Ident
ccsLbl
        (JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just (UOp -> JStgExpr -> JStgExpr
JStg.UOpExpr UOp
JStg.NewOp (JStgExpr -> [JStgExpr] -> JStgExpr
JStg.ApplExpr JStgExpr
hdCC
                               [ [Char] -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr [Char]
label
                               , [Char] -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr [Char]
modl
                               , [Char] -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr [Char]
loc
                               , Bool -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Bool
is_caf
                               ])))
  emitGlobal js

emitCostCentreStackDecl :: CostCentreStack -> G ()
emitCostCentreStackDecl :: CostCentreStack -> G ()
emitCostCentreStackDecl CostCentreStack
ccs =
    case CostCentreStack -> Maybe CostCentre
maybeSingletonCCS CostCentreStack
ccs of
      Just CostCentre
cc -> do
        ccsLbl <- CostCentre -> G Ident
singletonCCSLbl CostCentre
cc
        ccLbl  <- costCentreLbl cc
        let js =
              Ident -> Maybe JStgExpr -> JStgStat
JStg.DeclStat Ident
ccsLbl
              (JStgExpr -> Maybe JStgExpr
forall a. a -> Maybe a
Just (UOp -> JStgExpr -> JStgExpr
JStg.UOpExpr UOp
JStg.NewOp
                     (JStgExpr -> [JStgExpr] -> JStgExpr
JStg.ApplExpr JStgExpr
hdCCS [JStgExpr
null_, Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
ccLbl])))
        emitGlobal 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 -> JStg.JStgStat
enterCostCentreFun :: CostCentreStack -> JStgStat
enterCostCentreFun CostCentreStack
ccs
  | CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs = JStgExpr -> [JStgExpr] -> JStgStat
JStg.ApplStat JStgExpr
hdEnterFunCCS [JStgExpr
jCurrentCCS, JStgExpr -> Ident -> JStgExpr
JStg.SelExpr JStgExpr
r1 Ident
cc]
  | Bool
otherwise = JStgStat
forall a. Monoid a => a
mempty -- top-level function, nothing to do

enterCostCentreThunk :: JStg.JStgStat
enterCostCentreThunk :: JStgStat
enterCostCentreThunk = JStgExpr -> [JStgExpr] -> JStgStat
JStg.ApplStat JStgExpr
hdEnterThunkCCS [JStgExpr -> Ident -> JStgExpr
JStg.SelExpr JStgExpr
r1 Ident
cc]

setCC :: CostCentre -> Bool -> Bool -> G JStg.JStgStat
setCC :: CostCentre -> Bool -> Bool -> G JStgStat
setCC CostCentre
cc Bool
_tick Bool
True = do
  ccI@(identFS -> _ccLbl) <- CostCentre -> G Ident
costCentreLbl CostCentre
cc
  addDependency $ OtherSymb (cc_mod cc)
                            (moduleGlobalSymbol $ cc_mod cc)
  return $ jCurrentCCS |= JStg.ApplExpr hdPushCostCentre [ jCurrentCCS
                                                         , JStg.Var ccI
                                                         ]
setCC CostCentre
_cc Bool
_tick Bool
_push = JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
forall a. Monoid a => a
mempty

pushRestoreCCS :: JStg.JStgStat
pushRestoreCCS :: JStgStat
pushRestoreCCS = JStgExpr -> [JStgExpr] -> JStgStat
JStg.ApplStat JStgExpr
hdPushRestoreCCS []

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

jCurrentCCS :: JStg.JStgExpr
jCurrentCCS :: JStgExpr
jCurrentCCS = JStgExpr -> Ident -> JStgExpr
JStg.SelExpr JStgExpr
hdCurrentThread Ident
ccs

jCafCCS :: JStg.JStgExpr
jCafCCS :: JStgExpr
jCafCCS = FastString -> JStgExpr
JStg.global FastString
"h$CAF"

jSystemCCS :: JStg.JStgExpr
jSystemCCS :: JStgExpr
jSystemCCS = FastString -> JStgExpr
JStg.global 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
    prof <- G Bool
profiling
    return $ if prof then m else mempty

ifProfilingM :: Monoid m => G m -> G m
ifProfilingM :: forall m. Monoid m => G m -> G m
ifProfilingM G m
m = do
    prof <- G Bool
profiling
    if prof then m else return mempty

-- | If profiling is enabled, then use input JStgStat, else ignore
profStat :: StgToJSConfig -> JStg.JStgStat -> JStg.JStgStat
profStat :: StgToJSConfig -> JStgStat -> JStgStat
profStat StgToJSConfig
cfg JStgStat
e = if StgToJSConfig -> Bool
csProf StgToJSConfig
cfg then JStgStat
e else JStgStat
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
  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 = 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)
  return . ("h$"++) . zEncodeString $
    moduleNameColons (moduleName curModl) ++ "_" ++ if isCafCC cc then "CAF_ccs" else lbl

costCentreLbl :: CostCentre -> G Ident
costCentreLbl :: CostCentre -> G Ident
costCentreLbl CostCentre
cc = FastString -> Ident
name (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
name (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
    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
    ccLbl   <- costCentreLbl' cc
    let ccsLbl = [Char]
ccLbl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_ccs"
    return . zEncodeString $ mconcat
              [ moduleNameColons (moduleName curModl)
              , "_"
              , ccsLbl
              ]

singletonCCSLbl :: CostCentre -> G Ident
singletonCCSLbl :: CostCentre -> G Ident
singletonCCSLbl CostCentre
cc = FastString -> Ident
name (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 JStg.JStgExpr)
ccsVarJ :: CostCentreStack -> G (Maybe JStgExpr)
ccsVarJ CostCentreStack
ccs = do
  prof <- G Bool
profiling
  if prof
    then fmap (JStg.ValExpr . JStg.JVar) <$> costCentreStackLbl ccs
    else pure Nothing