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
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
|
module GUI.Timeline.HEC (
renderHEC,
renderInstantHEC,
) where
import GUI.Timeline.Render.Constants
import Events.EventTree
import Events.EventDuration
import GUI.Types
import GUI.Timeline.CairoDrawing
import GUI.ViewerColours
import Graphics.Rendering.Cairo
import qualified GHC.RTS.Events as GHC
import GHC.RTS.Events hiding (Event, GCWork, GCIdle)
import Control.Monad
renderHEC :: ViewParameters
-> Timestamp -> Timestamp -> (DurationTree,EventTree)
-> Render ()
renderHEC params@ViewParameters{..} start end (dtree,etree) = do
renderDurations params start end dtree
when (scaleValue < detailThreshold) $
case etree of
EventTree ltime etime tree ->
renderEvents params ltime etime start end tree
renderInstantHEC :: ViewParameters -> Timestamp -> Timestamp
-> EventTree
-> Render ()
renderInstantHEC params@ViewParameters{..} start end
(EventTree ltime etime tree) =
renderEvents params ltime etime start end tree
detailThreshold :: Double
detailThreshold = 3
-------------------------------------------------------------------------------
-- hecView draws the trace for a single HEC
renderDurations :: ViewParameters
-> Timestamp -> Timestamp -> DurationTree
-> Render ()
renderDurations _ _ _ DurationTreeEmpty = return ()
renderDurations params@ViewParameters{..} startPos endPos (DurationTreeLeaf e)
| inView startPos endPos e = drawDuration params e
| otherwise = return ()
renderDurations params@ViewParameters{..} !startPos !endPos
(DurationSplit s splitTime e lhs rhs runAv gcAv)
| startPos < splitTime && endPos >= splitTime &&
(fromIntegral (e - s) / scaleValue) <= fromIntegral detail
= -- View spans both left and right sub-tree.
-- trace (printf "hecView (average): start:%d end:%d s:%d e:%d" startPos endPos s e) $
drawAverageDuration params s e runAv gcAv
| otherwise
= -- trace (printf "hecView: start:%d end:%d s:%d e:%d" startPos endPos s e) $
do when (startPos < splitTime) $
renderDurations params startPos endPos lhs
when (endPos >= splitTime) $
renderDurations params startPos endPos rhs
-------------------------------------------------------------------------------
renderEvents :: ViewParameters
-> Timestamp -- start time of this tree node
-> Timestamp -- end time of this tree node
-> Timestamp -> Timestamp -> EventNode
-> Render ()
renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos
(EventTreeLeaf es)
= sequence_ [ drawEvent params e
| e <- es, let t = time e, t >= startPos && t < endPos ]
renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos
(EventTreeOne ev)
| t >= startPos && t < endPos = drawEvent params ev
| otherwise = return ()
where t = time ev
renderEvents params@ViewParameters{..} !s !e !startPos !endPos
(EventSplit splitTime lhs rhs)
| startPos < splitTime && endPos >= splitTime &&
(fromIntegral (e - s) / scaleValue) <= fromIntegral detail
-- was: = drawTooManyEvents params s e
-- is: draw only the right hand side (let's say it overwrites LHS)
= renderEvents params splitTime e startPos endPos rhs
| otherwise
= do when (startPos < splitTime) $
renderEvents params s splitTime startPos endPos lhs
when (endPos >= splitTime) $
renderEvents params splitTime e startPos endPos rhs
-------------------------------------------------------------------------------
-- An event is in view if it is not outside the view.
inView :: Timestamp -> Timestamp -> EventDuration -> Bool
inView viewStart viewEnd event =
not (eStart > viewEnd || eEnd <= viewStart)
where
eStart = startTimeOf event
eEnd = endTimeOf event
-------------------------------------------------------------------------------
drawAverageDuration :: ViewParameters
-> Timestamp -> Timestamp -> Timestamp -> Timestamp
-> Render ()
drawAverageDuration ViewParameters{..} startTime endTime runAv gcAv = do
setSourceRGBAhex (if not bwMode then runningColour else black) 1.0
when (runAv > 0) $
draw_rectangle startTime hecBarOff -- x, y
(endTime - startTime) -- w
hecBarHeight
setSourceRGBAhex black 1.0
--move_to (oxs + startTime, 0)
--relMoveTo (4/scaleValue) 13
--unscaledText scaleValue (show nrEvents)
setSourceRGBAhex (if not bwMode then gcColour else black) gcRatio
draw_rectangle startTime -- x
(hecBarOff+hecBarHeight) -- y
(endTime - startTime) -- w
(hecBarHeight `div` 2) -- h
where
duration = endTime - startTime
-- runRatio :: Double
-- runRatio = (fromIntegral runAv) / (fromIntegral duration)
gcRatio :: Double
gcRatio = (fromIntegral gcAv) / (fromIntegral duration)
-------------------------------------------------------------------------------
unscaledText :: String -> Render ()
unscaledText text
= do m <- getMatrix
identityMatrix
showText text
setMatrix m
-------------------------------------------------------------------------------
textWidth :: Double -> String -> Render TextExtents
textWidth _scaleValue text
= do m <- getMatrix
identityMatrix
tExtent <- textExtents text
setMatrix m
return tExtent
-------------------------------------------------------------------------------
drawDuration :: ViewParameters -> EventDuration -> Render ()
drawDuration ViewParameters{..} (ThreadRun t s startTime endTime) = do
setSourceRGBAhex (if not bwMode then runningColour else black) 1.0
setLineWidth (1/scaleValue)
draw_rectangle_opt False
startTime -- x
hecBarOff -- y
(endTime - startTime) -- w
hecBarHeight -- h
-- Optionally label the bar with the threadID if there is room
tExtent <- textWidth scaleValue tStr
let tw = textExtentsWidth tExtent
th = textExtentsHeight tExtent
when (tw + 6 < fromIntegral rectWidth) $ do
setSourceRGBAhex labelTextColour 1.0
move_to (fromIntegral startTime + truncate (4*scaleValue),
hecBarOff + (hecBarHeight + round th) `quot` 2)
unscaledText tStr
-- Optionally write the reason for the thread being stopped
-- depending on the zoom value
labelAt labelsMode endTime $
show t ++ " " ++ showThreadStopStatus s
where
rectWidth = truncate (fromIntegral (endTime - startTime) / scaleValue) -- as pixels
tStr = show t
drawDuration ViewParameters{..} (GCStart startTime endTime)
= gcBar (if bwMode then black else gcStartColour) startTime endTime
drawDuration ViewParameters{..} (GCWork startTime endTime)
= gcBar (if bwMode then black else gcWorkColour) startTime endTime
drawDuration ViewParameters{..} (GCIdle startTime endTime)
= gcBar (if bwMode then black else gcIdleColour) startTime endTime
drawDuration ViewParameters{..} (GCEnd startTime endTime)
= gcBar (if bwMode then black else gcEndColour) startTime endTime
gcBar :: Color -> Timestamp -> Timestamp -> Render ()
gcBar col !startTime !endTime = do
setSourceRGBAhex col 1.0
draw_rectangle_opt False
startTime -- x
(hecBarOff+hecBarHeight) -- y
(endTime - startTime) -- w
(hecBarHeight `div` 2) -- h
labelAt :: Bool -> Timestamp -> String -> Render ()
labelAt labelsMode t str
| not labelsMode = return ()
| otherwise = do
setSourceRGB 0.0 0.0 0.0
move_to (t, hecBarOff+hecBarHeight+12)
save
identityMatrix
rotate (pi/4)
showText str
restore
drawEvent :: ViewParameters -> GHC.Event -> Render ()
drawEvent params@ViewParameters{..} event
= case spec event of
CreateThread{} -> renderInstantEvent params event createThreadColour
RequestSeqGC{} -> renderInstantEvent params event seqGCReqColour
RequestParGC{} -> renderInstantEvent params event parGCReqColour
MigrateThread{} -> renderInstantEvent params event migrateThreadColour
WakeupThread{} -> renderInstantEvent params event threadWakeupColour
Shutdown{} -> renderInstantEvent params event shutdownColour
SparkCreate{} -> renderInstantEvent params event createdConvertedColour
SparkDud{} -> renderInstantEvent params event fizzledDudsColour
SparkOverflow{} -> renderInstantEvent params event overflowedColour
SparkRun{} -> renderInstantEvent params event createdConvertedColour
SparkSteal{} -> renderInstantEvent params event createdConvertedColour
SparkFizzle{} -> renderInstantEvent params event fizzledDudsColour
SparkGC{} -> renderInstantEvent params event gcColour
UserMessage{} -> renderInstantEvent params event userMessageColour
RunThread{} -> return ()
StopThread{} -> return ()
StartGC{} -> return ()
_ -> return ()
renderInstantEvent :: ViewParameters -> GHC.Event -> Color -> Render ()
renderInstantEvent ViewParameters{..} event color = do
setSourceRGBAhex color 1.0
setLineWidth (3 * scaleValue)
let t = time event
draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4)
labelAt labelsMode t $ showEventInfo (spec event)
_drawTooManyEvents :: ViewParameters -> Timestamp -> Timestamp
-> Render ()
_drawTooManyEvents _params@ViewParameters{..} _start _end = do
return ()
-- setSourceRGBAhex grey 1.0
-- setLineWidth (3 * scaleValue)
-- draw_rectangle start (hecBarOff-4) (end - start) 4
-- draw_rectangle start (hecBarOff+hecBarHeight) (end - start) 4
-------------------------------------------------------------------------------
|
