1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
{-# 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 qualified GHC.JS.JStg.Syntax as JStg
import GHC.JS.Make
import GHC.JS.Ident
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 (local_CCs, singleton_CCSs) = do
mapM_ emitCostCentreDecl local_CCs
mapM_ emitCostCentreStackDecl singleton_CCSs
emitCostCentreDecl :: CostCentre -> G ()
emitCostCentreDecl cc = do
ccsLbl <- costCentreLbl cc
let is_caf = isCafCC cc
label = costCentreUserName cc
modl = moduleNameString $ moduleName $ cc_mod cc
loc = renderWithContext defaultSDocContext (ppr (costCentreSrcSpan cc))
js = JStg.DeclStat ccsLbl
(Just (JStg.UOpExpr JStg.NewOp (JStg.ApplExpr (JStg.var "h$CC")
[ toJExpr label
, toJExpr modl
, toJExpr loc
, toJExpr is_caf
])))
emitGlobal js
emitCostCentreStackDecl :: CostCentreStack -> G ()
emitCostCentreStackDecl ccs =
case maybeSingletonCCS ccs of
Just cc -> do
ccsLbl <- singletonCCSLbl cc
ccLbl <- costCentreLbl cc
let js =
JStg.DeclStat ccsLbl
(Just (JStg.UOpExpr JStg.NewOp
(JStg.ApplExpr (JStg.var "h$CCS") [null_, toJExpr ccLbl])))
emitGlobal js
Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
--------------------------------------------------------------------------------
-- Entering to cost-centres
enterCostCentreFun :: CostCentreStack -> JStg.JStgStat
enterCostCentreFun ccs
| isCurrentCCS ccs = JStg.ApplStat (JStg.var "h$enterFunCCS")
[jCurrentCCS, JStg.SelExpr r1 (global "cc")]
| otherwise = mempty -- top-level function, nothing to do
enterCostCentreThunk :: JStg.JStgStat
enterCostCentreThunk = JStg.ApplStat (JStg.var "h$enterThunkCCS") [JStg.SelExpr r1 (global "cc")]
setCC :: CostCentre -> Bool -> Bool -> G JStg.JStgStat
setCC cc _tick True = do
ccI@(identFS -> _ccLbl) <- costCentreLbl cc
addDependency $ OtherSymb (cc_mod cc)
(moduleGlobalSymbol $ cc_mod cc)
return $ jCurrentCCS |= JStg.ApplExpr (JStg.var "h$pushCostCentre") [ jCurrentCCS
, JStg.Var ccI
]
setCC _cc _tick _push = return mempty
pushRestoreCCS :: JStg.JStgStat
pushRestoreCCS = JStg.ApplStat (JStg.var "h$pushRestoreCCS") []
--------------------------------------------------------------------------------
-- Some cost-centre stacks to be used in generator
jCurrentCCS :: JStg.JStgExpr
jCurrentCCS = JStg.SelExpr (JStg.var "h$currentThread") (global "ccs")
jCafCCS :: JStg.JStgExpr
jCafCCS = JStg.var "h$CAF"
jSystemCCS :: JStg.JStgExpr
jSystemCCS = JStg.var "h$CCS_SYSTEM"
--------------------------------------------------------------------------------
-- Helpers for generating profiling related things
profiling :: G Bool
profiling = csProf <$> getSettings
ifProfiling :: Monoid m => m -> G m
ifProfiling m = do
prof <- profiling
return $ if prof then m else mempty
ifProfilingM :: Monoid m => G m -> G m
ifProfilingM m = do
prof <- 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 cfg e = if csProf cfg then e else mempty
--------------------------------------------------------------------------------
-- Generating cost-centre and cost-centre stack variables
costCentreLbl' :: CostCentre -> G String
costCentreLbl' cc = do
curModl <- State.gets gsModule
let lbl = renderWithContext defaultSDocContext
$ withPprStyle PprCode (ppr cc)
return . ("h$"++) . zEncodeString $
moduleNameColons (moduleName curModl) ++ "_" ++ if isCafCC cc then "CAF_ccs" else lbl
costCentreLbl :: CostCentre -> G Ident
costCentreLbl cc = global . mkFastString <$> costCentreLbl' cc
costCentreStackLbl' :: CostCentreStack -> G (Maybe String)
costCentreStackLbl' ccs = do
ifProfilingM f
where
f | isCurrentCCS ccs = return $ Just "h$currentThread.ccs"
| dontCareCCS == ccs = return $ Just "h$CCS_DONT_CARE"
| otherwise =
case maybeSingletonCCS ccs of
Just cc -> Just <$> singletonCCSLbl' cc
Nothing -> pure Nothing
costCentreStackLbl :: CostCentreStack -> G (Maybe Ident)
costCentreStackLbl ccs = fmap (global . mkFastString) <$> costCentreStackLbl' ccs
singletonCCSLbl' :: CostCentre -> G String
singletonCCSLbl' cc = do
curModl <- State.gets gsModule
ccLbl <- costCentreLbl' cc
let ccsLbl = ccLbl ++ "_ccs"
return . zEncodeString $ mconcat
[ moduleNameColons (moduleName curModl)
, "_"
, ccsLbl
]
singletonCCSLbl :: CostCentre -> G Ident
singletonCCSLbl cc = global . mkFastString <$> singletonCCSLbl' cc
ccsVarJ :: CostCentreStack -> G (Maybe JStg.JStgExpr)
ccsVarJ ccs = do
prof <- profiling
if prof
then fmap (JStg.ValExpr . JStg.JVar) <$> costCentreStackLbl ccs
else pure Nothing
|
