threadscope-0.2.8: GUI/Timeline/HEC.hs
module GUI.Timeline.HEC (
renderHEC,
renderInstantHEC,
) where
import GUI.Timeline.Render.Constants
import Events.EventDuration
import Events.EventTree
import GUI.Timeline.CairoDrawing
import GUI.Types
import GUI.ViewerColours
import Graphics.Rendering.Cairo
import GHC.RTS.Events hiding (Event, GCIdle, GCWork)
import qualified GHC.RTS.Events as GHC
import Control.Monad
import qualified Data.IntMap as IM
import Data.Maybe
renderHEC :: ViewParameters -> Timestamp -> Timestamp
-> IM.IntMap String -> (DurationTree,EventTree)
-> Render ()
renderHEC params@ViewParameters{..} start end perfNames (dtree,etree) = do
renderDurations params start end dtree
when (scaleValue < detailThreshold) $
case etree of
EventTree ltime etime tree -> do
renderEvents params ltime etime start end (fromIntegral detail)
perfNames tree
return ()
renderInstantHEC :: ViewParameters -> Timestamp -> Timestamp
-> IM.IntMap String -> EventTree
-> Render ()
renderInstantHEC params@ViewParameters{..} start end
perfNames (EventTree ltime etime tree) = do
let instantDetail = 1
renderEvents params ltime etime start end instantDetail perfNames tree
return ()
detailThreshold :: Double
detailThreshold = 3
-------------------------------------------------------------------------------
-- 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 "renderDurations (average): start:%d end:%d s:%d e:%d" startPos endPos s e) $
drawAverageDuration params s e runAv gcAv
| otherwise
= -- trace (printf "renderDurations: 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 -> Double
-> IM.IntMap String -> EventNode
-> Render Bool
renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos ewidth
perfNames (EventTreeLeaf es)
= let within = [ e | e <- es, let t = evTime e, t >= startPos && t < endPos ]
untilTrue _ [] = return False
untilTrue f (x : xs) = do
b <- f x
if b then return b else untilTrue f xs
in untilTrue (drawEvent params ewidth perfNames) within
renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos ewidth
perfNames (EventTreeOne ev)
| t >= startPos && t < endPos = drawEvent params ewidth perfNames ev
| otherwise = return False
where t = evTime ev
renderEvents params@ViewParameters{..} !s !e !startPos !endPos ewidth
perfNames (EventSplit splitTime lhs rhs)
| startPos < splitTime && endPos >= splitTime &&
(fromIntegral (e - s) / scaleValue) <= ewidth
= do drawnLhs <-
renderEvents params s splitTime startPos endPos ewidth perfNames lhs
if not drawnLhs
then
renderEvents params splitTime e startPos endPos ewidth perfNames rhs
else return True
| otherwise
= do drawnLhs <-
if startPos < splitTime
then
renderEvents params s splitTime startPos endPos ewidth perfNames lhs
else return False
drawnRhs <-
if endPos >= splitTime
then
renderEvents params splitTime e startPos endPos ewidth perfNames rhs
else return False
return $ drawnLhs || drawnRhs
-------------------------------------------------------------------------------
-- 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 -> Double -> IM.IntMap String -> GHC.Event
-> Render Bool
drawEvent params@ViewParameters{..} ewidth perfNames event =
let renderI = renderInstantEvent params perfNames event ewidth
in case evSpec event of
CreateThread{} -> renderI createThreadColour
RequestSeqGC{} -> renderI seqGCReqColour
RequestParGC{} -> renderI parGCReqColour
MigrateThread{} -> renderI migrateThreadColour
WakeupThread{} -> renderI threadWakeupColour
Shutdown{} -> renderI shutdownColour
SparkCreate{} -> renderI createdConvertedColour
SparkDud{} -> renderI fizzledDudsColour
SparkOverflow{} -> renderI overflowedColour
SparkRun{} -> renderI createdConvertedColour
SparkSteal{} -> renderI createdConvertedColour
SparkFizzle{} -> renderI fizzledDudsColour
SparkGC{} -> renderI gcColour
UserMessage{} -> renderI userMessageColour
PerfCounter{} -> renderI createdConvertedColour
PerfTracepoint{} -> renderI shutdownColour
PerfName{} -> return False
RunThread{} -> return False
StopThread{} -> return False
StartGC{} -> return False
_ -> return False
renderInstantEvent :: ViewParameters -> IM.IntMap String -> GHC.Event
-> Double -> Color
-> Render Bool
renderInstantEvent ViewParameters{..} perfNames event ewidth color = do
setSourceRGBAhex color 1.0
setLineWidth (ewidth * scaleValue)
let t = evTime event
draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4)
let numToLabel PerfCounter{perfNum, period} | period == 0 =
IM.lookup (fromIntegral perfNum) perfNames
numToLabel PerfCounter{perfNum, period} =
fmap (++ " <" ++ show (period + 1) ++ " times>") $
IM.lookup (fromIntegral perfNum) perfNames
numToLabel PerfTracepoint{perfNum} =
fmap ("tracepoint: " ++) $ IM.lookup (fromIntegral perfNum) perfNames
numToLabel _ = Nothing
showLabel espec = fromMaybe (showEventInfo espec) (numToLabel espec)
labelAt labelsMode t $ showLabel (evSpec event)
return True
-------------------------------------------------------------------------------