threadscope-0.2.2/ 0000755 0000000 0000000 00000000000 12044651254 012205 5 ustar 00 0000000 0000000 threadscope-0.2.2/threadscope.ui 0000644 0000000 0000000 00000316752 12044651254 015063 0 ustar 00 0000000 0000000
threadscope-0.2.2/Setup.hs 0000644 0000000 0000000 00000000055 12044651254 013641 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain threadscope-0.2.2/LICENSE 0000644 0000000 0000000 00000003127 12044651254 013215 0 ustar 00 0000000 0000000 The Glasgow Haskell Compiler License
Copyright 2002-2012, The University Court of the University of Glasgow
and others. All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
- Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
- Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
- Neither name of the University nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.
threadscope-0.2.2/threadscope.cabal 0000644 0000000 0000000 00000007535 12044651254 015504 0 ustar 00 0000000 0000000 Name: threadscope
Version: 0.2.2
Category: Development, Profiling, Trace
Synopsis: A graphical tool for profiling parallel Haskell programs.
Description: ThreadScope is a graphical viewer for thread profile
information generated by the Glasgow Haskell compiler
(GHC).
.
The Threadscope program allows us to debug the parallel
performance of Haskell programs. Using Threadscope we can
check to see that work is well balanced across the
available processors and spot performance issues relating
to garbage collection or poor load balancing.
License: BSD3
License-file: LICENSE
Copyright: 2009-2010 Satnam Singh,
2009-2011 Simon Marlow,
2009 Donnie Jones,
2011-2012 Duncan Coutts,
2011-2012 Mikolaj Konarski,
2011 Nicolas Wu,
2011 Eric Kow
Author: Satnam Singh ,
Simon Marlow ,
Donnie Jones ,
Duncan Coutts ,
Mikolaj Konarski ,
Nicolas Wu ,
Eric Kow
Maintainer: Simon Marlow
Homepage: http://www.haskell.org/haskellwiki/ThreadScope
Bug-reports: http://trac.haskell.org/ThreadScope/
Build-Type: Simple
Cabal-version: >= 1.6
Data-files: threadscope.ui, threadscope.png
source-repository head
type: darcs
location: http://code.haskell.org/ThreadScope/
Executable threadscope
Main-is: Main.hs
Build-Depends: base >= 4.0 && < 5,
gtk >= 0.12, cairo, glib, pango,
binary, array, mtl, filepath,
ghc-events >= 0.4.2,
containers >= 0.2 && < 0.6,
deepseq >= 1.1,
time >= 1.1
Extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards
Other-Modules: Events.HECs,
Events.EventDuration,
Events.EventTree,
Events.ReadEvents,
Events.SparkStats,
Events.SparkTree,
Events.TestEvents,
GUI.Main,
GUI.MainWindow,
GUI.EventsView,
GUI.Dialogs,
GUI.SaveAs,
GUI.Timeline,
GUI.Histogram,
GUI.TraceView,
GUI.BookmarkView,
GUI.KeyView,
GUI.StartupInfoView,
GUI.SummaryView,
GUI.Types,
GUI.ConcurrencyControl,
GUI.ProgressView,
GUI.ViewerColours,
GUI.Timeline.Activity,
GUI.Timeline.CairoDrawing,
GUI.Timeline.HEC,
GUI.Timeline.Motion,
GUI.Timeline.Render,
GUI.Timeline.Sparks,
GUI.Timeline.Ticks,
GUI.Timeline.Types,
GUI.Timeline.Render.Constants,
GUI.GtkExtras
ghc-options: -Wall -fwarn-tabs
-fno-warn-type-defaults -fno-warn-name-shadowing
-fno-warn-unused-do-bind
-- Note: we do not want to use -threaded with gtk2hs.
if impl(ghc < 6.12)
-- GHC before 6.12 gave spurious warnings for RecordWildCards
ghc-options: -fno-warn-unused-matches
if !os(windows)
build-depends: unix >= 2.3 && < 2.7
threadscope-0.2.2/threadscope.png 0000644 0000000 0000000 00000012356 12044651254 015223 0 ustar 00 0000000 0000000 ‰PNG
IHDR Ù :¡ß— pHYs .# .#x¥?v tEXtSoftware Adobe ImageReadyqÉe< {IDATxÚì]=råÆ ²˜8"|:€‹PèˆØÔ:±¹«`Áªr.ð;94X¾ žN€9´1Tc9¾Ÿùéééyû¦ê%î#ù½žþ¾î ÌL q çq ^Ç…íþù ¹™¿äðJ•— Óüàk/_ÿúë?_¸|èûµ‚=›_ |]F¯|•ØŸ9MÚŒÿNÁ/”¯B±û àß2Â~«`OûË1*¯ûæ‹#Ùl¤ûùKµrJ!
×ÊW(ÃsJì…áJ§íæWJ,À9ì‰áw`÷§@Ø¥ —ðJ
\ŠE#?'±ðB2 Wc1Á»†ü=5•Ñ€\…0ìRaK*¡ mWÑÊvŒ€ý™»Ìj×1Ïüxr$m‘ tm´Ò§ºÂ$·‘KgÈ ðì¤ ÁI±G¶ßzÄþ lŸ ÿê°¿œÉ£×Þ¨6ì{OéUg‘ž˜FµÛYA :¤èu(ª>œuÆÿRô:$ÐÕŒý1j’ÁZ" ²^ø€L°Þ³8¨Êšc
Ö{È ö9kŽI´ÿOP{QŒ2¢]0 *ш †J4b‚¡˜`Ñíò@
F=J¨A0œ4!ÆžAz‡Q+eÄØ¥z°kýXð›¶â ™â¤¡Fíh°. Á–‘»ˆül {â"0gu@¿é\E‚2’5TU¦k‹‰¾è¤ªHÜX`¿ 줋HÜÛÎY`ì ø.o’AšX2À”
Õ) %#·:é'‘58ˆÀ)ì%×´Qd5#\•ádW "°î œôŽAV#Be€ýZø]ª7Î$Ø’ Ò•‚®Ä0ª–ÌìZEŒÝÍ/ßwÃ’dÌÔÈh²agAÊ {¡‰á=ÜH–‚M±Å„£À‘’¬`h¬LS•8b×Å-v˜›,R»Ó’ <Ò³£ž±Ÿö|šU$Ã,ºåî3Ç>¢¦·È5Á@…Ýà=!°'ŽŠ‰}ß¡´=)É°B¾Ü°ùÇùõ5|ȉÀXXØ[éX3öo ªHŽzs$ÝJÈ•öDà=Èl¿léúZúb=•q#FªØ©ç|༆ÁŽ9!öQî™\ö Â91¬T(õŒý5m[ζÉÏ û?GÏرðWêÙ6ð¡– {”‘¬^6m:Oö‘gNØ› Ø7H“{ƾï”yí;RÍ3îÙØ‹]$sMY¦;¸{Ïø1Ò>bìé٠Dcd€•d> îQ0 ‚=ö}¶äò™1f¿1Wª7ˆó8ˆ†ë‘ª©în’Ío~ÇÜ&²ˆ}Žt>ÓXRC|IDºÞuˆV¹ÜÇ5ÕÕ&Ù¥çÏ:zvÔ°5GrÒ\9cõ8ÿÍÉY¥í_ÔcCÝþ4ÿÞ °§žý†<’aÔc» cY=#ÀþYä‚óJ#wEG»>Ädžº°ë“ H•s6$CÊ]û]§Uá{£ç‰r6æ#6=wìÈÔ±ó‰d‘`8R/8
›ýt\° ÿ«¶ƒGì"v®—ç¸ÖduOG•ùõ&Rì2åòvùÎzcñCF«‡@~ã-ÕÅXÕ½2œ$yσϮbPÔ“Ã.ë²Ù™"6ýo djֻݙdú)ÙSUj5°oEøëά°/µlÄ™
G»¿öLãúœŒ›ÁZƒ;Ô¹a
útÂÿó4Ó¡E|ˆv=Gì\IÖ0›ìÚ ?3›lìXGG0Åmã㳉Û#[’1›ìÖb§wÍm¢#¸ÚÐo8 Ü'ìl·UA{¡Ð…øò¬GXL6‘(-®äखÇX8`ïUqã¾w1´ÁJ‡~VRÉÆ)·mwL¨áB®Ö
¶=Ü€˜!/¯Ö~ËšdPÌ–ôÉ»$g(õêºb–2‰×{H ýF^Ñò›b ÙKM´£u+ˆDNL´A l‘ȉ‰¶\ô³EÀÿ! ÑvöÖ¾‘ Ânž-L&vªnžè-[ »y.{A¶=U7Ïrß"S4$ƒùlüîq:`÷ÝøÝgãô¥§˜¯Ûv{á±q:즯=a û^qˆŠdÊ„7ÈêÔƒmð¸ÝMÆ}iŠìïnãG)l5ÔP¾±/m—1E®üÅ!:’¢Z娮=é™û
(«K‡™°?c_ZOI‘K ÈÕ@ôÝã¿îGpZaðˆ!Z’ ¶€W®Y·ôP{½Æ~½ÂžhKbï\V>‘#Û‚=Õ V)sGM®=‘ì:„[°·¦Ø£'Ùž'Àp‰b A ±,'>o=Q:„vL
±K¦ˆÂë‹óýˆ«kßrE^m ZŒÏã<ÎÃw$ûå«?Ý(Ê›®Uàݯÿa«3ök%âe«Ô@ÌØYG¾ÿÝJ}ùfü[ÆØo»'ëÈ7cß|Ñ$›
d’‹‹%—¯Ð“k’‹Pèv¡' ͤþ —:"´Ø ™ÔŸ“â3O_ÉÀH®«JŸVf¨ vƱª$'½¡Žp±\WRÀþ@já¾’ÚþíI’ "W#po‚•D{ ˜ä[Àž#þZ9á•ï aóñL°¢ˆl3~ Ï«Ø"ÛE€I^«ká+ªÍø¿þŽœL€ýÙvŸ»[8ëž°ûÞÝB"rÞIëÑž5leñ“íYÃNÁ µm °ËZí2vÒ}š1í"0Á¼`èD#$:Ñ Ñ. •h†F´ C#Z ‚EC´]çɦŠœœHîâ¤e [6àh.NêÊ‚lg‹}Ù¥ŸÀž žWÙí&¬"–ñHƒÕÅvHc'ŽQ(”“ª"aÛÃa[S•à»¼I¦¬$† •²“ÁÈI;é«HÀ²µ©@|'Â÷OKlæ "pÅÀo—,ˆ*’IC¥LpÕ†-IY0Á^™L6¼·f‚½°8.©ZÊ„ìGIÆeä†“Í {bˆ§dl Q,;9É èM˜a+5'ú†Q3ÂÎÔ1
ƒÚŒöÄeÇw$+
@¡™vqÄžê¬4Â{RŽ¶G~ Gìt$SvGs‰f*R
ž£¨Æ\Sþ!Õ}§M²R )Ï1äÞ{°?x¬k|ŽÌsMæ›H·» »œù ™.Úæݺ#ÙcÄk’ÒÈg_Øb4×L° XEÄÀ>xÄ~£oìä$Ã…á÷±œ%ìzßsŽGnùš˜Û~:Qìä$Ãpâ5®£XM`, üæ÷°m‹½^G3˜ ßQ{¹N
•Û£IýúÊ'äÒÎ lî^å©×åx*ð.Z 4þÝõï°ûe…š(
£œLùgü5Ø¢D·cQ+ÃØ+([rwÀ”ÉGÍ1TUàŸ î5°c¢ø' zÇ7Y é(±Ëzx&Æßq½w¥^§¨É:Áth‹-v G| ¯ôHïኜd\Õið…©£Nšjí \ÇŽdà¨CÄÆjÏØQǨyí™d¦ #Ác¤Øµ1A÷“1Rì†"ÑÚ4G¹$dÿÛD+“Í)íê
¯2ç䨓! v$³ù!’!žÂšhÓèÄéV&S;6Œ¢™Q?¨;¹¤í. ² p¸CmVšî¼‡ÈÑ0qÒgCì[&"1X6}¬dA“‹
©·U• ÔȶKc 8"Œ¶Ù |æС´Ä¾a9µ_&%D„PD\þ6D„"ª.]=·ŽN *“(]ZbAª>k];’^„@
Mjb'Ei2÷
vœôû
ò¾D™â~ä7ÿ´ÇldŠûë/ ² rs*’±‹'¤^Tmˆ] [String] -> IO ()
handleArgs flags args
| flagHelp flags = printHelp
| flagVersion flags = printVersion
| otherwise = do
initialTrace <- case (args, flagTest flags) of
([filename], Nothing) -> return (Just (Left filename))
([], Just tracename) -> return (Just (Right tracename))
([], Nothing) -> return Nothing
_ -> printUsage >> exitFailure
runGUI initialTrace
where
printVersion = putStrLn ("ThreadScope version " ++ showVersion version)
printUsage = putStrLn usageHeader
usageHeader = "Usage: threadscope [eventlog]\n" ++
" or: threadscope [FLAGS]"
helpHeader = usageHeader ++ "\n\nFlags: "
printHelp = putStrLn (usageInfo helpHeader flagDescrs
++ "\nFor more details see http://www.haskell.org/haskellwiki/ThreadScope_Tour\n")
-------------------------------------------------------------------------------
data Flags = Flags {
flagTest :: Maybe FilePath,
flagVersion :: Bool,
flagHelp :: Bool
}
defaultFlags :: Flags
defaultFlags = Flags Nothing False False
flagDescrs :: [OptDescr (Flags -> Flags)]
flagDescrs =
[ Option ['h'] ["help"]
(NoArg (\flags -> flags { flagHelp = True }))
"Show this help text"
, Option ['v'] ["version"]
(NoArg (\flags -> flags { flagVersion = True }))
"Program version"
, Option ['t'] ["test"]
(ReqArg (\name flags -> flags { flagTest = Just name }) "NAME")
"Load a named internal test (see Events/TestEvents.hs)"
]
parseArgs :: [String] -> IO (Flags, [String])
parseArgs args
| flagHelp flags = return (flags, args')
| not (null errs) = printErrors errs
| otherwise = return (flags, args')
where
(flags0, args', errs) = getOpt Permute flagDescrs args
flags = foldr (flip (.)) id flags0 defaultFlags
printErrors errs = do
putStrLn $ concat errs ++ "Try --help."
exitFailure
threadscope-0.2.2/Events/ 0000755 0000000 0000000 00000000000 12044651254 013451 5 ustar 00 0000000 0000000 threadscope-0.2.2/Events/SparkStats.hs 0000644 0000000 0000000 00000010326 12044651254 016106 0 ustar 00 0000000 0000000 module Events.SparkStats
( SparkStats(..)
, initial, create, rescale, aggregate, agEx
) where
import Data.Word (Word64)
-- | Sparks change state. Each state transition process has a duration.
-- Spark statistics, for a given duration, record the spark transition rate
-- (the number of sparks that enter a given state within the interval)
-- and the absolute mean, maximal and minimal number of sparks
-- in the spark pool within the duration.
data SparkStats =
SparkStats { rateCreated, rateDud, rateOverflowed,
rateConverted, rateFizzled, rateGCd,
meanPool, maxPool, minPool :: {-# UNPACK #-}!Double }
deriving (Show, Eq)
-- | Initial, default value of spark stats, at the start of runtime,
-- before any spark activity is recorded.
initial :: SparkStats
initial = SparkStats 0 0 0 0 0 0 0 0 0
-- | Create spark stats for a duration, given absolute
-- numbers of sparks in all categories at the start and end of the duration.
-- The units for spark transitions (first 6 counters) is [spark/duration]:
-- the fact that intervals may have different lenghts is ignored here.
-- The units for the pool stats are just [spark].
-- The values in the second counter have to be greater or equal
-- to the values in the first counter, except for the spark pool size.
-- For pool size, we take into account only the first sample,
-- to visualize more detail at high zoom levels, at the cost
-- of a slight shift of the graph. Mathematically, this corresponds
-- to taking the initial durations as centered around samples,
-- but to have the same tree for rates and pool sizes, we then have
-- to shift the durations by half interval size to the right
-- (which would be neglectable if the interval was small and even).
create :: (Word64, Word64, Word64, Word64, Word64, Word64, Word64)
-> (Word64, Word64, Word64, Word64, Word64, Word64, Word64)
-> SparkStats
create (crt1, dud1, ovf1, cnv1, fiz1, gcd1, remaining1)
(crt2, dud2, ovf2, cnv2, fiz2, gcd2, _remaining2) =
let (crt, dud, ovf, cnv, fiz, gcd) =
(fromIntegral $ crt2 - crt1,
fromIntegral $ dud2 - dud1,
fromIntegral $ ovf2 - ovf1,
fromIntegral $ cnv2 - cnv1,
fromIntegral $ fiz2 - fiz1,
fromIntegral $ gcd2 - gcd1)
p = fromIntegral remaining1
in SparkStats crt dud ovf cnv fiz gcd p p p
-- | Reduce a list of spark stats; spark pool stats are overwritten.
foldStats :: (Double -> Double -> Double)
-> Double -> Double -> Double
-> [SparkStats] -> SparkStats
foldStats f meanP maxP minP l
= SparkStats
(foldr f 0 (map rateCreated l))
(foldr f 0 (map rateDud l))
(foldr f 0 (map rateOverflowed l))
(foldr f 0 (map rateConverted l))
(foldr f 0 (map rateFizzled l))
(foldr f 0 (map rateGCd l))
meanP maxP minP
-- | Rescale the spark transition stats, e.g., to change their units.
rescale :: Double -> SparkStats -> SparkStats
rescale scale s =
let f w _ = scale * w
in foldStats f (meanPool s) (maxPool s) (minPool s) [s]
-- | Derive spark stats for an interval from a list of spark stats,
-- in reverse chronological order, of consecutive subintervals
-- that sum up to the original interval.
aggregate :: [SparkStats] -> SparkStats
aggregate [] = error "aggregate"
aggregate [s] = s -- optimization
aggregate l =
let meanP = sum (map meanPool l) / fromIntegral (length l) -- TODO: inaccurate
maxP = maximum (map maxPool l)
minP = minimum (map minPool l)
in foldStats (+) meanP maxP minP l
-- | Extrapolate spark stats from previous data.
-- Absolute pools size values extrapolate by staying constant,
-- rates of change of spark status extrapolate by dropping to 0
-- (which corresponds to absolute numbers of sparks staying constant).
extrapolate :: SparkStats -> SparkStats
extrapolate s =
let f w _ = 0 * w
in foldStats f (meanPool s) (maxPool s) (minPool s) [s]
-- | Aggregate, if any data provided. Extrapolate from previous data, otherwise.
-- In both cases, the second component is the new choice of "previous data".
-- The list of stats is expected in reverse chronological order,
-- as for aggregate.
agEx :: [SparkStats] -> SparkStats -> (SparkStats, SparkStats)
agEx [] s = (extrapolate s, s)
agEx l@(s:_) _ = (aggregate l, s)
threadscope-0.2.2/Events/ReadEvents.hs 0000644 0000000 0000000 00000024770 12044651254 016057 0 ustar 00 0000000 0000000 module Events.ReadEvents (
registerEventsFromFile, registerEventsFromTrace
) where
import Events.EventTree
import Events.SparkTree
import Events.HECs (HECs(..), histogram)
import Events.TestEvents
import Events.EventDuration
import qualified GUI.ProgressView as ProgressView
import GUI.ProgressView (ProgressView)
import GHC.RTS.Events -- hiding (Event)
import GHC.RTS.Events.Analysis
import GHC.RTS.Events.Analysis.SparkThread
import GHC.RTS.Events.Analysis.Capability
import Data.Array
import qualified Data.List as L
import Data.Map (Map)
import qualified Data.Map as M
import qualified Data.IntMap as IM
import Data.Set (Set)
import Data.Maybe (catMaybes, fromMaybe)
import Text.Printf
import System.FilePath
import Control.Monad
import Control.Exception
import qualified Control.DeepSeq as DeepSeq
import Data.Function
import Data.Either
-------------------------------------------------------------------------------
-- import qualified GHC.RTS.Events as GHCEvents
--
-- The GHC.RTS.Events library returns the profile information
-- in a data-streucture which contains a list data structure
-- representing the events i.e. [GHCEvents.Event]
-- ThreadScope transforms this list into an alternative representation
-- which (for each HEC) records event *durations* which are ordered in time.
-- The durations represent the run-lengths for thread execution and
-- run-lengths for garbage colleciton. This data-structure is called
-- EventDuration.
-- ThreadScope then transformations this data-structure into another
-- data-structure which gives a binary-tree view of the event information
-- by performing a binary split on the time domain i.e. the EventTree
-- data structure.
-- GHCEvents.Event => [EventDuration] => EventTree
-------------------------------------------------------------------------------
rawEventsToHECs :: [CapEvent] -> Timestamp
-> [(Double, (DurationTree, EventTree, SparkTree))]
rawEventsToHECs evs endTime
= map (\ cap -> toTree $ L.find ((Just cap ==) . ce_cap . head) heclists)
[0 .. maximum (0 : map (fromMaybe 0 . ce_cap) evs)]
where
heclists =
L.groupBy ((==) `on` ce_cap) $ L.sortBy (compare `on` ce_cap) evs
toTree Nothing = (0, (DurationTreeEmpty,
EventTree 0 0 (EventTreeLeaf []),
emptySparkTree))
toTree (Just evs) =
(maxSparkPool,
(mkDurationTree (eventsToDurations nondiscrete) endTime,
mkEventTree discrete endTime,
mkSparkTree sparkD endTime))
where es = map ce_event evs
(discrete, nondiscrete) = L.partition isDiscreteEvent es
(maxSparkPool, sparkD) = eventsToSparkDurations nondiscrete
-------------------------------------------------------------------------------
registerEventsFromFile :: String -> ProgressView
-> IO (HECs, String, Int, Double)
registerEventsFromFile filename = registerEvents (Left filename)
registerEventsFromTrace :: String -> ProgressView
-> IO (HECs, String, Int, Double)
registerEventsFromTrace traceName = registerEvents (Right traceName)
registerEvents :: Either FilePath String
-> ProgressView
-> IO (HECs, String, Int, Double)
registerEvents from progress = do
let msg = case from of
Left filename -> filename
Right test -> test
ProgressView.setTitle progress ("Loading " ++ takeFileName msg)
buildEventLog progress from
-------------------------------------------------------------------------------
-- Runs in a background thread
--
buildEventLog :: ProgressView -> Either FilePath String
-> IO (HECs, String, Int, Double)
buildEventLog progress from =
case from of
Right test -> build test (testTrace test)
Left filename -> do
stopPulse <- ProgressView.startPulse progress
fmt <- readEventLogFromFile filename
stopPulse
case fmt of
Left err -> fail err --FIXME: report error properly
Right evs -> build filename evs
where
-- | Integer division, rounding up.
divUp :: Timestamp -> Timestamp -> Timestamp
divUp n k = (n + k - 1) `div` k
build name evs = do
let
specBy1000 e@EventBlock{} =
e{end_time = end_time e `divUp` 1000,
block_events = map eBy1000 (block_events e)}
specBy1000 e = e
eBy1000 ev = ev{time = time ev `divUp` 1000,
spec = specBy1000 (spec ev)}
eventsBy = map eBy1000 (events (dat evs))
eventBlockEnd e | EventBlock{ end_time=t } <- spec e = t
eventBlockEnd e = time e
-- 1, to avoid graph scale 0 and division by 0 later on
lastTx = maximum (1 : map eventBlockEnd eventsBy)
-- Add caps to perf events, using the OS thread numbers
-- obtained from task validation data.
-- Only the perf events with a cap are displayed in the timeline.
-- TODO: it may make sense to move this code to ghc-events
-- and run after to-eventlog and ghc-events merge, but it requires
-- one more step in the 'perf to TS' workflow and is a bit slower
-- (yet another event sorting and loading eventlog chunks
-- into the CPU cache).
steps :: [CapEvent] -> [(Map KernelThreadId Int, CapEvent)]
steps evs =
zip (map fst $ rights $ validates capabilityTaskOSMachine evs) evs
addC :: (Map KernelThreadId Int, CapEvent) -> CapEvent
addC (state, ev@CapEvent{ce_event=Event{spec=PerfTracepoint{tid}}}) =
case M.lookup tid state of
Nothing -> ev -- unknown task's OS thread
ce_cap -> ev {ce_cap}
addC (state, ev@CapEvent{ce_event=Event{spec=PerfCounter{tid}}}) =
case M.lookup tid state of
Nothing -> ev -- unknown task's OS thread
ce_cap -> ev {ce_cap}
addC (_, ev) = ev
addCaps evs = map addC (steps evs)
-- sort the events by time, add extra caps and put them in an array
sorted = addCaps $ sortEvents eventsBy
maxTrees = rawEventsToHECs sorted lastTx
maxSparkPool = maximum (0 : map fst maxTrees)
trees = map snd maxTrees
-- put events in an array
n_events = length sorted
event_arr = listArray (0, n_events-1) sorted
hec_count = length trees
-- Pre-calculate the data for the sparks histogram.
intDoub :: Integral a => a -> Double
intDoub = fromIntegral
-- Discretizes the data using log.
-- Log base 2 seems to result in 7--15 bars, which is OK visually.
-- Better would be 10--15 bars, but we want the base to be a small
-- integer, for readable scales, and we can't go below 2.
ilog :: Timestamp -> Int
ilog 0 = 0
ilog x = floor $ logBase 2 (intDoub x)
times :: (Int, Timestamp, Timestamp)
-> Maybe (Timestamp, Int, Timestamp)
times (_, timeStarted, timeElapsed) =
Just (timeStarted, ilog timeElapsed, timeElapsed)
sparkProfile :: Process
((Map ThreadId (Profile SparkThreadState),
(Map Int ThreadId, Set ThreadId)),
CapEvent)
(ThreadId, (SparkThreadState, Timestamp, Timestamp))
sparkProfile = profileRouted
(refineM (spec . ce_event) sparkThreadMachine)
capabilitySparkThreadMachine
capabilitySparkThreadIndexer
(time . ce_event)
sorted
sparkSummary :: Map ThreadId (Int, Timestamp, Timestamp)
-> [(ThreadId, (SparkThreadState, Timestamp, Timestamp))]
-> [Maybe (Timestamp, Int, Timestamp)]
sparkSummary m [] = map times $ M.elems m
sparkSummary m ((threadId, (state, timeStarted', timeElapsed')):xs) =
case state of
SparkThreadRunning sparkId' -> case M.lookup threadId m of
Just el@(sparkId, timeStarted, timeElapsed) ->
if sparkId == sparkId'
then let value = (sparkId, timeStarted, timeElapsed + timeElapsed')
in sparkSummary (M.insert threadId value m) xs
else times el : newSummary sparkId' xs
Nothing -> newSummary sparkId' xs
_ -> sparkSummary m xs
where
newSummary sparkId = let value = (sparkId, timeStarted', timeElapsed')
in sparkSummary (M.insert threadId value m)
allHisto :: [(Timestamp, Int, Timestamp)]
allHisto = catMaybes . sparkSummary M.empty . toList $ sparkProfile
-- Sparks of zero lenght are already well visualized in other graphs:
durHistogram = filter (\ (_, logdur, _) -> logdur > 0) allHisto
-- Precompute some extremums of the maximal interval, needed for scales.
durs = [(logdur, dur) | (_start, logdur, dur) <- durHistogram]
(logDurs, sumDurs) = L.unzip (histogram durs)
minXHistogram = minimum (maxBound : logDurs)
maxXHistogram = maximum (minBound : logDurs)
maxY = maximum (minBound : sumDurs)
-- round up to multiples of 10ms
maxYHistogram = 10000 * ceiling (fromIntegral maxY / 10000)
getPerfNames nmap ev =
case spec ev of
EventBlock{block_events} ->
L.foldl' getPerfNames nmap block_events
PerfName{perfNum, name} ->
IM.insert (fromIntegral perfNum) name nmap
_ -> nmap
perfNames = L.foldl' getPerfNames IM.empty eventsBy
hecs = HECs {
hecCount = hec_count,
hecTrees = trees,
hecEventArray = event_arr,
hecLastEventTime = lastTx,
maxSparkPool,
minXHistogram,
maxXHistogram,
maxYHistogram,
durHistogram,
perfNames
}
treeProgress :: Int -> (DurationTree, EventTree, SparkTree) -> IO ()
treeProgress hec (tree1, tree2, tree3) = do
ProgressView.setText progress $
printf "Building HEC %d/%d" (hec+1) hec_count
ProgressView.setProgress progress hec_count hec
evaluate tree1
evaluate (eventTreeMaxDepth tree2)
evaluate (sparkTreeMaxDepth tree3)
when (hec_count == 1 || hec == 1) -- eval only with 2nd HEC
(return $! DeepSeq.rnf durHistogram)
zipWithM_ treeProgress [0..] trees
ProgressView.setProgress progress hec_count hec_count
-- TODO: fully evaluate HECs before returning because otherwise the last
-- bit of work gets done after the progress window has been closed.
return (hecs, name, n_events, fromIntegral lastTx / 1000000)
threadscope-0.2.2/Events/TestEvents.hs 0000644 0000000 0000000 00000024065 12044651254 016120 0 ustar 00 0000000 0000000 module Events.TestEvents (testTrace)
where
import GHC.RTS.Events
import Data.Word
-------------------------------------------------------------------------------
testTrace :: String -> EventLog
testTrace name = eventLog (test name)
-------------------------------------------------------------------------------
eventLog :: [Event] -> EventLog
eventLog events =
let specBy1000 e@EventBlock{} =
e{end_time = end_time e * 1000,
block_events = map eBy1000 (block_events e)}
specBy1000 e = e
eBy1000 ev = ev{time = time ev * 1000,
spec = specBy1000 (spec ev)}
eventsBy = map eBy1000 events
in EventLog (Header testEventTypes) (Data eventsBy)
-------------------------------------------------------------------------------
create :: Word16
create = 0
-------------------------------------------------------------------------------
runThread :: Word16
runThread = 1
-------------------------------------------------------------------------------
stop :: Word16
stop = 2
-------------------------------------------------------------------------------
runnable :: Word16
runnable = 3
-------------------------------------------------------------------------------
migrate :: Word16
migrate = 4
-------------------------------------------------------------------------------
runSpark :: Word16
runSpark = 5
-------------------------------------------------------------------------------
stealSpark :: Word16
stealSpark = 6
-------------------------------------------------------------------------------
shutdown :: Word16
shutdown = 7
-------------------------------------------------------------------------------
wakeup :: Word16
wakeup = 8
-------------------------------------------------------------------------------
startGC :: Word16
startGC = 9
------------------------------------------------------------------------------
finishGC :: Word16
finishGC = 10
------------------------------------------------------------------------------
reqSeqGC :: Word16
reqSeqGC = 11
------------------------------------------------------------------------------
reqParGC :: Word16
reqParGC = 12
------------------------------------------------------------------------------
createSparkThread :: Word16
createSparkThread = 15
------------------------------------------------------------------------------
logMessage :: Word16
logMessage = 16
------------------------------------------------------------------------------
startup :: Word16
startup = 17
------------------------------------------------------------------------------
blockMarker :: Word16
blockMarker = 18
------------------------------------------------------------------------------
testEventTypes :: [EventType]
testEventTypes
= [EventType create "Create thread" (Just 8),
EventType runThread "Run thread" (Just 8),
EventType stop "Stop thread" (Just 10),
EventType runnable "Thread runnable" (Just 8),
EventType migrate "Migrate thread" (Just 10),
EventType runSpark "Run spark" (Just 8),
EventType stealSpark "Steal spark" (Just 10),
EventType shutdown "Shutdown" (Just 0),
EventType wakeup "Wakeup thread" (Just 10),
EventType startGC "Start GC" (Just 0),
EventType finishGC "Finish GC" (Just 0),
EventType reqSeqGC "Request sequetial GC" (Just 0),
EventType reqParGC "Reqpargc parallel GC" (Just 0),
EventType createSparkThread "Create spark thread" (Just 8),
EventType logMessage "Log message" Nothing,
EventType startup "Startup" (Just 0),
EventType blockMarker "Block marker" (Just 14)
]
-------------------------------------------------------------------------------
test :: String -> [Event]
-------------------------------------------------------------------------------
test "empty0"
= [
Event 0 (Startup 1)
]
-------------------------------------------------------------------------------
test "empty1"
= [
Event 0 (Startup 1),
Event 0 $ EventBlock 4000000 0 []
]
-------------------------------------------------------------------------------
test "test0"
= [
Event 0 (Startup 1),
Event 0 $ EventBlock 4000000 0 [
Event 4000000 Shutdown
]
]
-------------------------------------------------------------------------------
test "small"
= [
Event 0 (Startup 1),
Event 0 $ EventBlock 4000000 0 [
Event 1000000 (CreateThread 1),
Event 2000000 (RunThread 1),
Event 3000000 (StopThread 1 ThreadFinished),
Event 4000000 (Shutdown)
]
]
-------------------------------------------------------------------------------
test "tick"
= [-- A thread from 2s to 3s
Event 0 (Startup 3),
Event 0 $ EventBlock 4000000000 0 [
Event 1000000000 (CreateThread 1),
Event 2000000000 (RunThread 1),
Event 3000000000 (StopThread 1 ThreadFinished),
Event 4000000000 (Shutdown)
],
-- A thread from 0.2ms to 0.3ms
Event 0 $ EventBlock 4000000000 1 [
Event 1000000 (CreateThread 2),
Event 2000000 (RunThread 2),
Event 3000000 (StopThread 2 ThreadFinished),
Event 4000000 (Shutdown)
],
-- A thread from 0.2us to 0.3us
Event 0 $ EventBlock 4000000000 2 [
Event 1000 (CreateThread 3),
Event 2000 (RunThread 3),
Event 3000 (StopThread 3 ThreadFinished),
Event 4000 (Shutdown)
]
]
-------------------------------------------------------------------------------
test "tick2"
= [-- A thread create but no run
Event 0 (Startup 1),
Event 0 $ EventBlock 4000000000 0 [
Event 1000000000 (CreateThread 1),
Event 4000000000 (Shutdown)
]
]
-------------------------------------------------------------------------------
test "tick3"
= [-- A thread from 2s to 3s
Event 0 (Startup 1),
Event 0 $ EventBlock 4000000000 0 [
Event 1000000000 (CreateThread 1),
Event 2000000000 (RunThread 1),
Event 3000000000 (StopThread 1 ThreadFinished),
Event 4000000000 (Shutdown)
]
]
-------------------------------------------------------------------------------
test "tick4"
= [-- A test for scale values close to 1.0
Event 0 (Startup 1),
Event 0 $ EventBlock 4000000000 0 [
Event 100 (CreateThread 1),
Event 200 (RunThread 1),
Event 300 (StopThread 1 ThreadFinished),
Event 400 (Shutdown)
]
]
-------------------------------------------------------------------------------
test "tick5"
= [-- A thread from 2s to 3s
Event 0 (Startup 1),
Event 0 $ EventBlock 4000000000 0 [
Event 1000000000 (CreateThread 1),
Event 2000000000 (RunThread 1),
Event 3000000000 (StopThread 1 ThreadFinished),
Event 4000000000 (Shutdown)
]
]
-------------------------------------------------------------------------------
-- A long tick run to check small and large tick labels
test "tick6" = chequered 2 100 10000000
-------------------------------------------------------------------------------
test "overlap"
= [-- A thread from 2s to 3s
Event 0 (Startup 1),
Event 0 $ EventBlock 3000 0 [
Event 1000 (CreateThread 1),
Event 1100 (RunThread 1),
Event 1200 (CreateThread 2),
Event 1300 (StopThread 1 ThreadFinished),
Event 1400 (RunThread 2),
Event 1500 (CreateThread 3),
Event 1500 (CreateThread 4),
Event 1500 (StopThread 2 ThreadFinished),
Event 1600 (RunThread 3),
Event 1600 (CreateThread 5),
Event 1600 (StopThread 3 ThreadFinished),
Event 1700 (RunThread 4),
Event 1700 (CreateThread 6),
Event 1800 (StopThread 4 ThreadFinished),
Event 3000 (Shutdown)
]
]
-------------------------------------------------------------------------------
-- These tests are for chequered patterns to help check for rendering
-- problems and also to help test the performance of scrolling etc.
-- Each line has a fixed frequency of a thread running and then performing GC.
-- Each successive HEC runs thread at half the frequency of the previous HEC.
test "ch1" = chequered 1 100 100000
test "ch2" = chequered 2 100 100000
test "ch3" = chequered 3 100 100000
test "ch4" = chequered 4 100 100000
test "ch5" = chequered 5 100 100000
test "ch6" = chequered 6 100 100000
test "ch7" = chequered 7 100 100000
test "ch8" = chequered 8 100 100000
-------------------------------------------------------------------------------
test _ = []
-------------------------------------------------------------------------------
chequered :: ThreadId -> Timestamp -> Timestamp -> [Event]
chequered numThreads basicDuration runLength
= Event 0 (Startup (fromIntegral numThreads)) :
makeChequered 1 numThreads basicDuration runLength
-------------------------------------------------------------------------------
makeChequered :: ThreadId -> ThreadId -> Timestamp -> Timestamp -> [Event]
makeChequered currentThread numThreads _basicDuration _runLength
| currentThread > numThreads = [] -- All threads rendered
makeChequered currentThread numThreads basicDuration runLength
= Event 0 eventBlock :
makeChequered (currentThread+1) numThreads (2*basicDuration) runLength
where
eventBlock :: EventInfo
eventBlock = EventBlock runLength (fromIntegral (currentThread-1))
(Event 0 (CreateThread currentThread)
: chequeredPattern currentThread 0 basicDuration runLength)
-------------------------------------------------------------------------------
chequeredPattern :: ThreadId -> Timestamp -> Timestamp -> Timestamp -> [Event]
chequeredPattern currentThread currentPos basicDuration runLength
= if currentPos + 2*basicDuration > runLength then
[Event runLength (Shutdown)]
else
[Event currentPos (RunThread currentThread),
Event (currentPos+basicDuration) (StopThread currentThread ThreadYielding),
Event (currentPos+basicDuration) StartGC,
Event (currentPos+2*basicDuration) EndGC
] ++ chequeredPattern currentThread (currentPos+2*basicDuration) basicDuration runLength
-------------------------------------------------------------------------------
threadscope-0.2.2/Events/SparkTree.hs 0000644 0000000 0000000 00000024142 12044651254 015710 0 ustar 00 0000000 0000000 module Events.SparkTree (
SparkTree,
sparkTreeMaxDepth,
emptySparkTree,
eventsToSparkDurations,
mkSparkTree,
sparkProfile,
) where
import qualified Events.SparkStats as SparkStats
import qualified GHC.RTS.Events as GHCEvents
import GHC.RTS.Events (Timestamp)
import Control.Exception (assert)
import Text.Printf
-- import Debug.Trace
-- | Sparks change state. Each state transition process has a duration.
-- SparkDuration is a condensed description of such a process,
-- containing a start time of the duration interval,
-- spark stats that record the spark transition rate
-- and the absolute number of sparks in the spark pool within the duration.
data SparkDuration =
SparkDuration { startT :: {-#UNPACK#-}!Timestamp,
deltaC :: {-#UNPACK#-}!SparkStats.SparkStats }
deriving Show
-- | Calculates durations and maximal rendered values from the event log.
-- Warning: cannot be applied to a suffix of the log (assumes start at time 0).
eventsToSparkDurations :: [GHCEvents.Event] -> (Double, [SparkDuration])
eventsToSparkDurations es =
let aux _startTime _startCounters [] = (0, [])
aux startTime startCounters (event : events) =
case GHCEvents.spec event of
GHCEvents.SparkCounters crt dud ovf cnv fiz gcd rem ->
let endTime = GHCEvents.time event
endCounters = (crt, dud, ovf, cnv, fiz, gcd, rem)
delta = SparkStats.create startCounters endCounters
newMaxSparkPool = SparkStats.maxPool delta
sd = SparkDuration { startT = startTime,
deltaC = delta }
(oldMaxSparkPool, l) = aux endTime endCounters events
in (max oldMaxSparkPool newMaxSparkPool, sd : l)
_otherEvent -> aux startTime startCounters events
in aux 0 (0,0,0,0,0,0,0) es
-- | We map the spark transition durations (intervals) onto a binary
-- search tree, so that we can easily find the durations
-- that correspond to a particular view of the timeline.
-- Additionally, each node of the tree contains a summary
-- of the information below it, so that we can render views at various
-- levels of resolution. For example, if a tree node would represent
-- less than one pixel on the display, there is no point is descending
-- the tree further.
data SparkTree
= SparkTree
{-#UNPACK#-}!Timestamp -- ^ start time of span represented by the tree
{-#UNPACK#-}!Timestamp -- ^ end time of the span represented by the tree
SparkNode
deriving Show
data SparkNode
= SparkSplit
{-#UNPACK#-}!Timestamp -- ^ time used to split the span into two parts
SparkNode
-- ^ the LHS split; all data lies completely between start and split
SparkNode
-- ^ the RHS split; all data lies completely between split and end
{-#UNPACK#-}!SparkStats.SparkStats
-- ^ aggregate of the spark stats within the span
| SparkTreeLeaf
{-#UNPACK#-}!SparkStats.SparkStats
-- ^ the spark stats for the base duration
| SparkTreeEmpty
-- ^ represents a span that no data referts to, e.g., after the last GC
deriving Show
sparkTreeMaxDepth :: SparkTree -> Int
sparkTreeMaxDepth (SparkTree _ _ t) = sparkNodeMaxDepth t
sparkNodeMaxDepth :: SparkNode -> Int
sparkNodeMaxDepth (SparkSplit _ lhs rhs _)
= 1 + sparkNodeMaxDepth lhs `max` sparkNodeMaxDepth rhs
sparkNodeMaxDepth _ = 1
emptySparkTree :: SparkTree
emptySparkTree = SparkTree 0 0 SparkTreeEmpty
-- | Create spark tree from spark durations.
-- Note that the last event may be not a spark event, in which case
-- there is no data about sparks for the last time interval
-- (the subtree for the interval will have SparkTreeEmpty node).
mkSparkTree :: [SparkDuration] -- ^ spark durations calculated from events
-> Timestamp -- ^ end time of last event in the list
-> SparkTree
mkSparkTree es endTime =
SparkTree s e $
-- trace (show tree) $
tree
where
tree = splitSparks es endTime
(s, e) = if null es then (0, 0) else (startT (head es), endTime)
-- | Construct spark tree, by recursively splitting time intervals..
-- We only split at spark transition duration boundaries;
-- we never split a duration into multiple pieces.
-- Therefore, the binary tree is only roughly split by time,
-- the actual split depends on the distribution of sample points below it.
splitSparks :: [SparkDuration] -> Timestamp -> SparkNode
splitSparks [] !_endTime =
SparkTreeEmpty
splitSparks [e] !_endTime =
SparkTreeLeaf (deltaC e)
splitSparks es !endTime
| null rhs
= splitSparks es lhs_end
| null lhs
= error $
printf "splitSparks: null lhs: len = %d, startTime = %d, endTime = %d\n"
(length es) startTime endTime
++ '\n' : show es
| otherwise
= -- trace (printf "len = %d, startTime = %d, endTime = %d\n" (length es) startTime endTime) $
assert (length lhs + length rhs == length es) $
SparkSplit (startT $ head rhs)
ltree
rtree
(SparkStats.aggregate (subDelta rtree ++ subDelta ltree))
where
-- | Integer division, rounding up.
divUp :: Timestamp -> Timestamp -> Timestamp
divUp n k = (n + k - 1) `div` k
startTime = startT $ head es
splitTime = startTime + (endTime - startTime) `divUp` 2
(lhs, lhs_end, rhs) = splitSparkList es [] splitTime 0
ltree = splitSparks lhs lhs_end
rtree = splitSparks rhs endTime
subDelta (SparkSplit _ _ _ delta) = [delta]
subDelta (SparkTreeLeaf delta) = [delta]
subDelta SparkTreeEmpty = []
splitSparkList :: [SparkDuration]
-> [SparkDuration]
-> Timestamp
-> Timestamp
-> ([SparkDuration], Timestamp, [SparkDuration])
splitSparkList [] acc !_tsplit !tmax
= (reverse acc, tmax, [])
splitSparkList [e] acc !_tsplit !tmax
-- Just one event left: put it on the right. This ensures that we
-- have at least one event on each side of the split.
= (reverse acc, tmax, [e])
splitSparkList (e:es) acc !tsplit !tmax
| startT e <= tsplit -- pick all durations that start at or before the split
= splitSparkList es (e:acc) tsplit (max tmax (startT e))
| otherwise
= (reverse acc, tmax, e:es)
-- | For each timeslice, give the spark stats calculated for that interval.
-- The spark stats are Approximated from the aggregated data
-- at the level of the spark tree covering intervals of the size
-- similar to the timeslice size.
sparkProfile :: Timestamp -> Timestamp -> Timestamp -> SparkTree
-> [SparkStats.SparkStats]
sparkProfile slice start0 end0 t
= {- trace (show flat) $ -} chopped
where
-- do an extra slice at both ends
start = if start0 < slice then start0 else start0 - slice
end = end0 + slice
flat = flatten start t []
-- TODO: redefine chop so that it's obvious this error will not happen
-- e.g., catch pathological cases, like a tree with only SparkTreeEmpty
-- inside and/or make it tail-recursive instead of
-- taking the 'previous' argument
chopped0 = chop (error "Fatal error in sparkProfile.") [] start flat
chopped | start0 < slice = SparkStats.initial : chopped0
| otherwise = chopped0
flatten :: Timestamp -> SparkTree -> [SparkTree] -> [SparkTree]
flatten _start (SparkTree _s _e SparkTreeEmpty) rest = rest
flatten start t@(SparkTree s e (SparkSplit split l r _)) rest
| e <= start = rest
| end <= s = rest
| start >= split = flatten start (SparkTree split e r) rest
| end <= split = flatten start (SparkTree s split l) rest
| e - s > slice = flatten start (SparkTree s split l) $
flatten start (SparkTree split e r) rest
-- A rule of thumb: if a node is narrower than slice, don't drill down,
-- even if the node sits astride slice boundaries and so the readings
-- for each of the two neigbouring slices will not be accurate
-- (but for the pair as a whole, they will be). Smooths the curve down
-- even more than averaging over the timeslice already does.
| otherwise = t : rest
flatten _start t@(SparkTree _s _e (SparkTreeLeaf _)) rest
= t : rest
chop :: SparkStats.SparkStats -> [SparkStats.SparkStats]
-> Timestamp -> [SparkTree] -> [SparkStats.SparkStats]
chop _previous sofar start1 _ts
| start1 >= end
= case sofar of
_ : _ -> [SparkStats.aggregate sofar]
[] -> []
chop _previous sofar _start1 [] -- data too short for the redrawn area
| null sofar -- no data at all in the redrawn area
= []
| otherwise
= [SparkStats.aggregate sofar]
chop previous sofar start1 (t : ts)
| e <= start1 -- skipping data left of the slice
= case sofar of
_ : _ -> error "chop"
[] -> chop previous sofar start1 ts
| s >= start1 + slice -- postponing data right of the slice
= let (c, p) = SparkStats.agEx sofar previous
in c : chop p [] (start1 + slice) (t : ts)
| e > start1 + slice
= let (c, p) = SparkStats.agEx (created_in_this_slice t ++ sofar) previous
in c : chop p [] (start1 + slice) (t : ts)
| otherwise
= chop previous (created_in_this_slice t ++ sofar) start1 ts
where
(s, e) | SparkTree s e _ <- t = (s, e)
-- The common part of the slice and the duration.
mi = min (start1 + slice) e
ma = max start1 s
common = if mi < ma then 0 else mi - ma
-- Instead of drilling down the tree (unless it's a leaf),
-- we approximate by taking a proportion of the aggregate value,
-- depending on how much of the spark duration corresponding
-- to the tree node is covered by our timeslice.
proportion = if e > s
then fromIntegral common / fromIntegral (e - s)
else assert (e == s && common == 0) $ 0
-- Spark transitions in the tree are in units spark/duration.
-- Here the numbers are rescaled so that the units are spark/ms.
created_in_this_slice (SparkTree _ _ node) = case node of
SparkTreeLeaf delta -> [SparkStats.rescale proportion delta]
SparkTreeEmpty -> []
SparkSplit _ _ _ delta -> [SparkStats.rescale proportion delta]
threadscope-0.2.2/Events/HECs.hs 0000644 0000000 0000000 00000005036 12044651254 014573 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
module Events.HECs (
HECs(..),
Event,
CapEvent,
Timestamp,
eventIndexToTimestamp,
timestampToEventIndex,
extractUserMarkers,
histogram,
histogramCounts,
) where
import Events.EventTree
import Events.SparkTree
import GHC.RTS.Events
import Data.Array
import qualified Data.IntMap as IM
import qualified Data.List as L
-----------------------------------------------------------------------------
-- all the data from a .eventlog file
data HECs = HECs {
hecCount :: Int,
hecTrees :: [(DurationTree, EventTree, SparkTree)],
hecEventArray :: Array Int CapEvent,
hecLastEventTime :: Timestamp,
maxSparkPool :: Double,
minXHistogram :: Int,
maxXHistogram :: Int,
maxYHistogram :: Timestamp,
durHistogram :: [(Timestamp, Int, Timestamp)],
perfNames :: IM.IntMap String
}
-----------------------------------------------------------------------------
eventIndexToTimestamp :: HECs -> Int -> Timestamp
eventIndexToTimestamp HECs{hecEventArray=arr} n =
time (ce_event (arr ! n))
timestampToEventIndex :: HECs -> Timestamp -> Int
timestampToEventIndex HECs{hecEventArray=arr} ts =
search l (r+1)
where
(l,r) = bounds arr
search !l !r
| (r - l) <= 1 = if ts > time (ce_event (arr!l)) then r else l
| ts < tmid = search l mid
| otherwise = search mid r
where
mid = l + (r - l) `quot` 2
tmid = time (ce_event (arr!mid))
extractUserMarkers :: HECs -> [(Timestamp, String)]
extractUserMarkers hecs =
[ (ts, mark)
| CapEvent _ (Event ts (UserMarker mark)) <- elems (hecEventArray hecs) ]
-- | Sum durations in the same buckets to form a histogram.
histogram :: [(Int, Timestamp)] -> [(Int, Timestamp)]
histogram durs = IM.toList $ fromListWith' (+) durs
-- | Sum durations and spark counts in the same buckets to form a histogram.
histogramCounts :: [(Int, (Timestamp, Int))] -> [(Int, (Timestamp, Int))]
histogramCounts durs =
let agg (dur1, count1) (dur2, count2) =
-- bangs needed to avoid stack overflow
let !dur = dur1 + dur2
!count = count1 + count2
in (dur, count)
in IM.toList $ fromListWith' agg durs
fromListWith' :: (a -> a -> a) -> [(Int, a)] -> IM.IntMap a
fromListWith' f xs =
L.foldl' ins IM.empty xs
where
#if MIN_VERSION_containers(0,4,1)
ins t (k,x) = IM.insertWith' f k x t
#else
ins t (k,x) =
let r = IM.insertWith f k x t
v = r IM.! k
in v `seq` r
#endif
threadscope-0.2.2/Events/EventDuration.hs 0000644 0000000 0000000 00000013275 12044651254 016604 0 ustar 00 0000000 0000000 -- This module supports a duration-based data-type to represent thread
-- execution and GC information.
module Events.EventDuration (
EventDuration(..),
isGCDuration,
startTimeOf, endTimeOf, durationOf,
eventsToDurations,
isDiscreteEvent
) where
-- Imports for GHC Events
import qualified GHC.RTS.Events as GHC
import GHC.RTS.Events hiding (Event,GCWork,GCIdle)
-------------------------------------------------------------------------------
-- This datastructure is a duration-based representation of the event
-- loginformation where thread-runs and GCs are explicitly represented
-- by a single constructor identifying their start and end points.
data EventDuration
= ThreadRun {-#UNPACK#-}!ThreadId
ThreadStopStatus
{-#UNPACK#-}!Timestamp
{-#UNPACK#-}!Timestamp
| GCStart {-#UNPACK#-}!Timestamp
{-#UNPACK#-}!Timestamp
| GCWork {-#UNPACK#-}!Timestamp
{-#UNPACK#-}!Timestamp
| GCIdle {-#UNPACK#-}!Timestamp
{-#UNPACK#-}!Timestamp
| GCEnd {-#UNPACK#-}!Timestamp
{-#UNPACK#-}!Timestamp
deriving Show
{-
GCStart GCWork GCIdle GCEnd
gc start -----> work -----> idle ------+> done -----> gc end
| |
`-------<-------<-----'
-}
isGCDuration :: EventDuration -> Bool
isGCDuration GCStart{} = True
isGCDuration GCWork{} = True
isGCDuration GCIdle{} = True
isGCDuration GCEnd{} = True
isGCDuration _ = False
-------------------------------------------------------------------------------
-- The start time of an event.
startTimeOf :: EventDuration -> Timestamp
startTimeOf ed
= case ed of
ThreadRun _ _ startTime _ -> startTime
GCStart startTime _ -> startTime
GCWork startTime _ -> startTime
GCIdle startTime _ -> startTime
GCEnd startTime _ -> startTime
-------------------------------------------------------------------------------
-- The emd time of an event.
endTimeOf :: EventDuration -> Timestamp
endTimeOf ed
= case ed of
ThreadRun _ _ _ endTime -> endTime
GCStart _ endTime -> endTime
GCWork _ endTime -> endTime
GCIdle _ endTime -> endTime
GCEnd _ endTime -> endTime
-------------------------------------------------------------------------------
-- The duration of an EventDuration
durationOf :: EventDuration -> Timestamp
durationOf ed = endTimeOf ed - startTimeOf ed
-------------------------------------------------------------------------------
eventsToDurations :: [GHC.Event] -> [EventDuration]
eventsToDurations [] = []
eventsToDurations (event : events) =
case spec event of
RunThread{thread=t} -> runDuration t : rest
StopThread{} -> rest
StartGC -> gcStart (time event) events
EndGC{} -> rest
_otherEvent -> rest
where
rest = eventsToDurations events
runDuration t = ThreadRun t s (time event) endTime
where (endTime, s) = case findRunThreadTime events of
Nothing -> error $ "findRunThreadTime for " ++ (show event)
Just x -> x
isDiscreteEvent :: GHC.Event -> Bool
isDiscreteEvent e =
case spec e of
RunThread{} -> False
StopThread{} -> False
StartGC{} -> False
EndGC{} -> False
GHC.GCWork{} -> False
GHC.GCIdle{} -> False
GHC.GCDone{} -> False
GHC.SparkCounters{} -> False
_ -> True
gcStart :: Timestamp -> [GHC.Event] -> [EventDuration]
gcStart _ [] = []
gcStart t0 (event : events) =
case spec event of
GHC.GCWork{} -> GCStart t0 t1 : gcWork t1 events
GHC.GCIdle{} -> GCStart t0 t1 : gcIdle t1 events
GHC.GCDone{} -> GCStart t0 t1 : gcDone t1 events
GHC.EndGC{} -> GCStart t0 t1 : eventsToDurations events
RunThread{} -> GCStart t0 t1 : eventsToDurations (event : events)
_other -> gcStart t0 events
where
t1 = time event
gcWork :: Timestamp -> [GHC.Event] -> [EventDuration]
gcWork _ [] = []
gcWork t0 (event : events) =
case spec event of
GHC.GCWork{} -> gcWork t0 events
GHC.GCIdle{} -> GCWork t0 t1 : gcIdle t1 events
GHC.GCDone{} -> GCWork t0 t1 : gcDone t1 events
GHC.EndGC{} -> GCWork t0 t1 : eventsToDurations events
RunThread{} -> GCWork t0 t1 : eventsToDurations (event : events)
_other -> gcStart t0 events
where
t1 = time event
gcIdle :: Timestamp -> [GHC.Event] -> [EventDuration]
gcIdle _ [] = []
gcIdle t0 (event : events) =
case spec event of
GHC.GCIdle{} -> gcIdle t0 events
GHC.GCWork{} -> GCIdle t0 t1 : gcWork t1 events
GHC.GCDone{} -> GCIdle t0 t1 : gcDone t1 events
GHC.EndGC{} -> GCIdle t0 t1 : eventsToDurations events
RunThread{} -> GCIdle t0 t1 : eventsToDurations (event : events)
_other -> gcStart t0 events
where
t1 = time event
gcDone :: Timestamp -> [GHC.Event] -> [EventDuration]
gcDone _ [] = []
gcDone t0 (event : events) =
case spec event of
GHC.GCDone{} -> gcDone t0 events
GHC.GCWork{} -> GCEnd t0 t1 : gcWork t1 events
GHC.GCIdle{} -> GCEnd t0 t1 : gcIdle t1 events
GHC.EndGC{} -> GCEnd t0 t1 : eventsToDurations events
RunThread{} -> GCEnd t0 t1 : eventsToDurations (event : events)
_other -> gcStart t0 events
where
t1 = time event
-------------------------------------------------------------------------------
findRunThreadTime :: [GHC.Event] -> Maybe (Timestamp, ThreadStopStatus)
findRunThreadTime [] = Nothing
findRunThreadTime (e : es)
= case spec e of
StopThread{status=s} -> Just (time e, s)
_ -> findRunThreadTime es
-------------------------------------------------------------------------------
threadscope-0.2.2/Events/EventTree.hs 0000644 0000000 0000000 00000022555 12044651254 015717 0 ustar 00 0000000 0000000 module Events.EventTree (
DurationTree(..),
mkDurationTree,
runTimeOf, gcTimeOf,
reportDurationTree,
durationTreeCountNodes,
durationTreeMaxDepth,
EventTree(..), EventNode(..),
mkEventTree,
reportEventTree, eventTreeMaxDepth,
) where
import Events.EventDuration
import qualified GHC.RTS.Events as GHC
import GHC.RTS.Events hiding (Event)
import Text.Printf
import Control.Exception (assert)
-------------------------------------------------------------------------------
-- We map the events onto a binary search tree, so that we can easily
-- find the events that correspond to a particular view of the
-- timeline. Additionally, each node of the tree contains a summary
-- of the information below it, so that we can render views at various
-- levels of resolution. For example, if a tree node would represent
-- less than one pixel on the display, there is no point is descending
-- the tree further.
-- We only split at event boundaries; we never split an event into
-- multiple pieces. Therefore, the binary tree is only roughly split
-- by time, the actual split depends on the distribution of events
-- below it.
data DurationTree
= DurationSplit
{-#UNPACK#-}!Timestamp -- The start time of this run-span
{-#UNPACK#-}!Timestamp -- The time used to split the events into two parts
{-#UNPACK#-}!Timestamp -- The end time of this run-span
DurationTree -- The LHS split; all events lie completely between
-- start and split
DurationTree -- The RHS split; all events lie completely between
-- split and end
{-#UNPACK#-}!Timestamp -- The total amount of time spent running a thread
{-#UNPACK#-}!Timestamp -- The total amount of time spend in GC
| DurationTreeLeaf
EventDuration
| DurationTreeEmpty
deriving Show
-------------------------------------------------------------------------------
mkDurationTree :: [EventDuration] -> Timestamp -> DurationTree
mkDurationTree es endTime =
-- trace (show tree) $
tree
where
tree = splitDurations es endTime
splitDurations :: [EventDuration] -- events
-> Timestamp -- end time of last event in the list
-> DurationTree
splitDurations [] _endTime =
-- if len /= 0 then error "splitDurations0" else
DurationTreeEmpty -- The case for an empty list of events.
splitDurations [e] _entTime =
DurationTreeLeaf e
splitDurations es endTime
| null rhs
= splitDurations es lhs_end
| null lhs
= error $
printf "splitDurations: null lhs: len = %d, startTime = %d, endTime = %d\n"
(length es) startTime endTime
++ '\n': show es
| otherwise
= -- trace (printf "len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" len startTime endTime lhs_len) $
assert (length lhs + length rhs == length es) $
DurationSplit startTime
lhs_end
endTime
ltree
rtree
runTime
gcTime
where
startTime = startTimeOf (head es)
splitTime = startTime + (endTime - startTime) `div` 2
(lhs, lhs_end, rhs) = splitDurationList es [] splitTime 0
ltree = splitDurations lhs lhs_end
rtree = splitDurations rhs endTime
runTime = runTimeOf ltree + runTimeOf rtree
gcTime = gcTimeOf ltree + gcTimeOf rtree
splitDurationList :: [EventDuration]
-> [EventDuration]
-> Timestamp
-> Timestamp
-> ([EventDuration], Timestamp, [EventDuration])
splitDurationList [] acc !_tsplit !tmax
= (reverse acc, tmax, [])
splitDurationList [e] acc !_tsplit !tmax
-- Just one event left: put it on the right. This ensures that we
-- have at least one event on each side of the split.
= (reverse acc, tmax, [e])
splitDurationList (e:es) acc !tsplit !tmax
| tstart <= tsplit -- pick all events that start at or before the split
= splitDurationList es (e:acc) tsplit (max tmax tend)
| otherwise
= (reverse acc, tmax, e:es)
where
tstart = startTimeOf e
tend = endTimeOf e
-------------------------------------------------------------------------------
runTimeOf :: DurationTree -> Timestamp
runTimeOf (DurationSplit _ _ _ _ _ runTime _) = runTime
runTimeOf (DurationTreeLeaf e) | ThreadRun{} <- e = durationOf e
runTimeOf _ = 0
-------------------------------------------------------------------------------
gcTimeOf :: DurationTree -> Timestamp
gcTimeOf (DurationSplit _ _ _ _ _ _ gcTime) = gcTime
gcTimeOf (DurationTreeLeaf e) | isGCDuration e = durationOf e
gcTimeOf _ = 0
-------------------------------------------------------------------------------
reportDurationTree :: Int -> DurationTree -> IO ()
reportDurationTree hecNumber eventTree
= putStrLn ("HEC " ++ show hecNumber ++ reportText)
where
reportText = " nodes = " ++ show (durationTreeCountNodes eventTree) ++
" max depth = " ++ show (durationTreeMaxDepth eventTree)
-------------------------------------------------------------------------------
durationTreeCountNodes :: DurationTree -> Int
durationTreeCountNodes (DurationSplit _ _ _ lhs rhs _ _)
= 1 + durationTreeCountNodes lhs + durationTreeCountNodes rhs
durationTreeCountNodes _ = 1
-------------------------------------------------------------------------------
durationTreeMaxDepth :: DurationTree -> Int
durationTreeMaxDepth (DurationSplit _ _ _ lhs rhs _ _)
= 1 + durationTreeMaxDepth lhs `max` durationTreeMaxDepth rhs
durationTreeMaxDepth _ = 1
-------------------------------------------------------------------------------
data EventTree
= EventTree
{-#UNPACK#-}!Timestamp -- The start time of this run-span
{-#UNPACK#-}!Timestamp -- The end time of this run-span
EventNode
data EventNode
= EventSplit
{-#UNPACK#-}!Timestamp -- The time used to split the events into two parts
EventNode -- The LHS split; all events lie completely between
-- start and split
EventNode -- The RHS split; all events lie completely between
-- split and end
| EventTreeLeaf [GHC.Event]
-- sometimes events happen "simultaneously" (at the same time
-- given the resolution of our clock source), so we can't
-- separate them.
| EventTreeOne GHC.Event
-- This is a space optimisation for the common case of
-- EventTreeLeaf [e].
mkEventTree :: [GHC.Event] -> Timestamp -> EventTree
mkEventTree es endTime =
EventTree s e $
-- trace (show tree) $
tree
where
tree = splitEvents es endTime
(s,e) = if null es then (0,0) else (time (head es), endTime)
splitEvents :: [GHC.Event] -- events
-> Timestamp -- end time of last event in the list
-> EventNode
splitEvents [] !_endTime =
-- if len /= 0 then error "splitEvents0" else
EventTreeLeaf [] -- The case for an empty list of events
splitEvents [e] !_endTime =
EventTreeOne e
splitEvents es !endTime
| duration == 0
= EventTreeLeaf es
| null rhs
= splitEvents es lhs_end
| null lhs
= error $
printf "splitEvents: null lhs: len = %d, startTime = %d, endTime = %d\n"
(length es) startTime endTime
++ '\n': show es
| otherwise
= -- trace (printf "len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" len startTime endTime lhs_len) $
assert (length lhs + length rhs == length es) $
EventSplit (time (head rhs))
ltree
rtree
where
-- | Integer division, rounding up.
divUp :: Timestamp -> Timestamp -> Timestamp
divUp n k = (n + k - 1) `div` k
startTime = time (head es)
splitTime = startTime + (endTime - startTime) `divUp` 2
duration = endTime - startTime
(lhs, lhs_end, rhs) = splitEventList es [] splitTime 0
ltree = splitEvents lhs lhs_end
rtree = splitEvents rhs endTime
splitEventList :: [GHC.Event]
-> [GHC.Event]
-> Timestamp
-> Timestamp
-> ([GHC.Event], Timestamp, [GHC.Event])
splitEventList [] acc !_tsplit !tmax
= (reverse acc, tmax, [])
splitEventList [e] acc !_tsplit !tmax
-- Just one event left: put it on the right. This ensures that we
-- have at least one event on each side of the split.
= (reverse acc, tmax, [e])
splitEventList (e:es) acc !tsplit !tmax
| t <= tsplit -- pick all events that start at or before the split
= splitEventList es (e:acc) tsplit (max tmax t)
| otherwise
= (reverse acc, tmax, e:es)
where
t = time e
-------------------------------------------------------------------------------
reportEventTree :: Int -> EventTree -> IO ()
reportEventTree hecNumber (EventTree _ _ eventTree)
= putStrLn ("HEC " ++ show hecNumber ++ reportText)
where
reportText = " nodes = " ++ show (eventTreeCountNodes eventTree) ++
" max depth = " ++ show (eventNodeMaxDepth eventTree)
-------------------------------------------------------------------------------
eventTreeCountNodes :: EventNode -> Int
eventTreeCountNodes (EventSplit _ lhs rhs)
= 1 + eventTreeCountNodes lhs + eventTreeCountNodes rhs
eventTreeCountNodes _ = 1
-------------------------------------------------------------------------------
eventTreeMaxDepth :: EventTree -> Int
eventTreeMaxDepth (EventTree _ _ t) = eventNodeMaxDepth t
eventNodeMaxDepth :: EventNode -> Int
eventNodeMaxDepth (EventSplit _ lhs rhs)
= 1 + eventNodeMaxDepth lhs `max` eventNodeMaxDepth rhs
eventNodeMaxDepth _ = 1
threadscope-0.2.2/GUI/ 0000755 0000000 0000000 00000000000 12044651254 012631 5 ustar 00 0000000 0000000 threadscope-0.2.2/GUI/StartupInfoView.hs 0000644 0000000 0000000 00000012350 12044651254 016277 0 ustar 00 0000000 0000000 module GUI.StartupInfoView (
StartupInfoView,
startupInfoViewNew,
startupInfoViewSetEvents,
) where
import GHC.RTS.Events
import Graphics.UI.Gtk
import Data.Array
import Data.List
import Data.Maybe
import Data.Time
import Data.Time.Clock.POSIX
-------------------------------------------------------------------------------
data StartupInfoView = StartupInfoView
{ labelProgName :: Label
, storeProgArgs :: ListStore String
, storeProgEnv :: ListStore (String, String)
, labelProgStartTime :: Label
, labelProgRtsId :: Label
}
data StartupInfoState
= StartupInfoEmpty
| StartupInfoLoaded
{ progName :: Maybe String
, progArgs :: Maybe [String]
, progEnv :: Maybe [(String, String)]
, progStartTime :: Maybe UTCTime
, progRtsId :: Maybe String
}
-------------------------------------------------------------------------------
startupInfoViewNew :: Builder -> IO StartupInfoView
startupInfoViewNew builder = do
let getWidget cast = builderGetObject builder cast
labelProgName <- getWidget castToLabel "labelProgName"
treeviewProgArgs <- getWidget castToTreeView "treeviewProgArguments"
treeviewProgEnv <- getWidget castToTreeView "treeviewProgEnvironment"
labelProgStartTime <- getWidget castToLabel "labelProgStartTime"
labelProgRtsId <- getWidget castToLabel "labelProgRtsIdentifier"
storeProgArgs <- listStoreNew []
columnArgs <- treeViewColumnNew
cellArgs <- cellRendererTextNew
treeViewColumnPackStart columnArgs cellArgs True
treeViewAppendColumn treeviewProgArgs columnArgs
treeViewSetModel treeviewProgArgs storeProgArgs
set cellArgs [ cellTextEditable := True ]
cellLayoutSetAttributes columnArgs cellArgs storeProgArgs $ \arg ->
[ cellText := arg ]
storeProgEnv <- listStoreNew []
columnVar <- treeViewColumnNew
cellVar <- cellRendererTextNew
columnValue <- treeViewColumnNew
cellValue <- cellRendererTextNew
treeViewColumnPackStart columnVar cellVar False
treeViewColumnPackStart columnValue cellValue True
treeViewAppendColumn treeviewProgEnv columnVar
treeViewAppendColumn treeviewProgEnv columnValue
treeViewSetModel treeviewProgEnv storeProgEnv
cellLayoutSetAttributes columnVar cellVar storeProgEnv $ \(var,_) ->
[ cellText := var ]
set cellValue [ cellTextEditable := True ]
cellLayoutSetAttributes columnValue cellValue storeProgEnv $ \(_,value) ->
[ cellText := value ]
let startupInfoView = StartupInfoView{..}
return startupInfoView
-------------------------------------------------------------------------------
startupInfoViewSetEvents :: StartupInfoView -> Maybe (Array Int CapEvent) -> IO ()
startupInfoViewSetEvents view mevents =
updateStartupInfo view (maybe StartupInfoEmpty processEvents mevents)
--TODO: none of this handles the possibility of an eventlog containing multiple
-- OS processes. Note that the capset arg is ignored in the events below.
processEvents :: Array Int CapEvent -> StartupInfoState
processEvents = foldl' accum (StartupInfoLoaded Nothing Nothing Nothing Nothing Nothing)
. take 1000
. elems
where
accum info (CapEvent _ (Event _ (ProgramArgs _ (name:args)))) =
info {
progName = Just name,
progArgs = Just args
}
accum info (CapEvent _ (Event _ (ProgramEnv _ env))) =
info { progEnv = Just (sort (parseEnv env)) }
accum info (CapEvent _ (Event _ (RtsIdentifier _ rtsid))) =
info { progRtsId = Just rtsid }
accum info (CapEvent _ (Event timestamp (WallClockTime _ sec nsec))) =
-- WallClockTime records the wall clock time of *this* event
-- which occurs some time after startup, so we can just subtract
-- the timestamp since that is the relative time since startup.
let wallTimePosix :: NominalDiffTime
wallTimePosix = fromIntegral sec
+ (fromIntegral nsec / nanoseconds)
- (fromIntegral timestamp / nanoseconds)
nanoseconds = 1000000000
wallTimeUTC = posixSecondsToUTCTime wallTimePosix
in info { progStartTime = Just wallTimeUTC }
accum info _ = info
-- convert ["foo=bar", ...] to [("foo", "bar"), ...]
parseEnv env = [ (var, value) | (var, '=':value) <- map (span (/='=')) env ]
updateStartupInfo :: StartupInfoView -> StartupInfoState -> IO ()
updateStartupInfo StartupInfoView{..} StartupInfoLoaded{..} = do
set labelProgName [ labelText := fromMaybe "(unknown)" progName ]
set labelProgStartTime [ labelText := maybe "(unknown)" show progStartTime ]
set labelProgRtsId [ labelText := fromMaybe "(unknown)" progRtsId ]
listStoreClear storeProgArgs
mapM_ (listStoreAppend storeProgArgs) (fromMaybe [] progArgs)
listStoreClear storeProgEnv
mapM_ (listStoreAppend storeProgEnv) (fromMaybe [] progEnv)
updateStartupInfo StartupInfoView{..} StartupInfoEmpty = do
set labelProgName [ labelText := "" ]
set labelProgStartTime [ labelText := "" ]
set labelProgRtsId [ labelText := "" ]
listStoreClear storeProgArgs
listStoreClear storeProgEnv
threadscope-0.2.2/GUI/GtkExtras.hs 0000644 0000000 0000000 00000010617 12044651254 015106 0 ustar 00 0000000 0000000 {-# LANGUAGE ForeignFunctionInterface, CPP #-}
module GUI.GtkExtras where
-- This is all stuff that should be bound in the gtk package but is not yet
-- (as of gtk-0.12.0)
import Graphics.UI.GtkInternals
import Graphics.UI.Gtk (Rectangle)
import System.Glib.GError
import System.Glib.MainLoop
import Graphics.Rendering.Pango.Types
import Graphics.Rendering.Pango.BasicTypes
import Graphics.UI.Gtk.General.Enums (StateType, ShadowType)
import Foreign
import Foreign.C
import Control.Monad
import Control.Concurrent.MVar
waitGUI :: IO ()
waitGUI = do
resultVar <- newEmptyMVar
idleAdd (putMVar resultVar () >> return False) priorityDefaultIdle
takeMVar resultVar
-------------------------------------------------------------------------------
stylePaintFlatBox :: WidgetClass widget
=> Style
-> DrawWindow
-> StateType
-> ShadowType
-> Rectangle
-> widget
-> String
-> Int -> Int -> Int -> Int
-> IO ()
stylePaintFlatBox style window stateType shadowType
clipRect widget detail x y width height =
with clipRect $ \rectPtr ->
withCString detail $ \detailPtr ->
(\(Style arg1) (DrawWindow arg2) arg3 arg4 arg5 (Widget arg6) arg7 arg8 arg9 arg10 arg11 -> withForeignPtr arg1 $ \argPtr1 ->withForeignPtr arg2 $ \argPtr2 ->withForeignPtr arg6 $ \argPtr6 -> gtk_paint_flat_box argPtr1 argPtr2 arg3 arg4 arg5 argPtr6 arg7 arg8 arg9 arg10 arg11)
style
window
((fromIntegral.fromEnum) stateType)
((fromIntegral.fromEnum) shadowType)
(castPtr rectPtr)
(toWidget widget)
detailPtr
(fromIntegral x) (fromIntegral y)
(fromIntegral width) (fromIntegral height)
stylePaintLayout :: WidgetClass widget
=> Style
-> DrawWindow
-> StateType
-> Bool
-> Rectangle
-> widget
-> String
-> Int -> Int
-> PangoLayout
-> IO ()
stylePaintLayout style window stateType useText
clipRect widget detail x y (PangoLayout _ layout) =
with clipRect $ \rectPtr ->
withCString detail $ \detailPtr ->
(\(Style arg1) (DrawWindow arg2) arg3 arg4 arg5 (Widget arg6) arg7 arg8 arg9 (PangoLayoutRaw arg10) -> withForeignPtr arg1 $ \argPtr1 ->withForeignPtr arg2 $ \argPtr2 ->withForeignPtr arg6 $ \argPtr6 ->withForeignPtr arg10 $ \argPtr10 -> gtk_paint_layout argPtr1 argPtr2 arg3 arg4 arg5 argPtr6 arg7 arg8 arg9 argPtr10)
style
window
((fromIntegral.fromEnum) stateType)
(fromBool useText)
(castPtr rectPtr)
(toWidget widget)
detailPtr
(fromIntegral x) (fromIntegral y)
layout
launchProgramForURI :: String -> IO Bool
#if mingw32_HOST_OS || mingw32_TARGET_OS
launchProgramForURI uri = do
withCString "open" $ \verbPtr ->
withCString uri $ \filePtr ->
c_ShellExecuteA
nullPtr
verbPtr
filePtr
nullPtr
nullPtr
1 -- SW_SHOWNORMAL
return True
foreign import stdcall unsafe "shlobj.h ShellExecuteA"
c_ShellExecuteA :: Ptr () -- HWND hwnd
-> CString -- LPCTSTR lpOperation
-> CString -- LPCTSTR lpFile
-> CString -- LPCTSTR lpParameters
-> CString -- LPCTSTR lpDirectory
-> CInt -- INT nShowCmd
-> IO CInt -- HINSTANCE return
#else
launchProgramForURI uri =
propagateGError $ \errPtrPtr ->
withCString uri $ \uriStrPtr -> do
timestamp <- gtk_get_current_event_time
liftM toBool $ gtk_show_uri nullPtr uriStrPtr timestamp errPtrPtr
#endif
-------------------------------------------------------------------------------
foreign import ccall safe "gtk_paint_flat_box"
gtk_paint_flat_box :: Ptr Style -> Ptr DrawWindow -> CInt -> CInt -> Ptr () -> Ptr Widget -> Ptr CChar -> CInt -> CInt -> CInt -> CInt -> IO ()
foreign import ccall safe "gtk_paint_layout"
gtk_paint_layout :: Ptr Style -> Ptr DrawWindow -> CInt -> CInt -> Ptr () -> Ptr Widget -> Ptr CChar -> CInt -> CInt -> Ptr PangoLayoutRaw -> IO ()
foreign import ccall safe "gtk_show_uri"
gtk_show_uri :: Ptr Screen -> Ptr CChar -> CUInt -> Ptr (Ptr ()) -> IO CInt
foreign import ccall unsafe "gtk_get_current_event_time"
gtk_get_current_event_time :: IO CUInt
threadscope-0.2.2/GUI/Timeline.hs 0000644 0000000 0000000 00000045714 12044651254 014746 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
module GUI.Timeline (
TimelineView,
timelineViewNew,
TimelineViewActions(..),
timelineSetBWMode,
timelineSetLabelsMode,
timelineGetViewParameters,
timelineGetYScaleArea,
timelineWindowSetHECs,
timelineWindowSetTraces,
timelineWindowSetBookmarks,
timelineSetSelection,
TimeSelection(..),
timelineZoomIn,
timelineZoomOut,
timelineZoomToFit,
timelineScrollLeft,
timelineScrollRight,
timelineScrollToBeginning,
timelineScrollToEnd,
timelineCentreOnCursor,
) where
import GUI.Types
import GUI.Timeline.Types
import GUI.Timeline.Motion
import GUI.Timeline.Render
import GUI.Timeline.Render.Constants
import Events.HECs
import Graphics.UI.Gtk
import Graphics.Rendering.Cairo
import Data.IORef
import Control.Monad
-----------------------------------------------------------------------------
-- The CPUs view
data TimelineView = TimelineView {
timelineState :: TimelineState,
hecsIORef :: IORef (Maybe HECs),
tracesIORef :: IORef [Trace],
bookmarkIORef :: IORef [Timestamp],
selectionRef :: IORef TimeSelection,
labelsModeIORef :: IORef Bool,
bwmodeIORef :: IORef Bool,
cursorIBeam :: Cursor,
cursorMove :: Cursor
}
data TimelineViewActions = TimelineViewActions {
timelineViewSelectionChanged :: TimeSelection -> IO ()
}
-- | Draw some parts of the timeline in black and white rather than colour.
timelineSetBWMode :: TimelineView -> Bool -> IO ()
timelineSetBWMode timelineWin bwmode = do
writeIORef (bwmodeIORef timelineWin) bwmode
widgetQueueDraw (timelineDrawingArea (timelineState timelineWin))
timelineSetLabelsMode :: TimelineView -> Bool -> IO ()
timelineSetLabelsMode timelineWin labelsMode = do
writeIORef (labelsModeIORef timelineWin) labelsMode
widgetQueueDraw (timelineDrawingArea (timelineState timelineWin))
timelineGetViewParameters :: TimelineView -> IO ViewParameters
timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, labelsModeIORef,
timelineState=TimelineState{..}} = do
(w, _) <- widgetGetSize timelineDrawingArea
scaleValue <- readIORef scaleIORef
maxSpkValue <- readIORef maxSpkIORef
-- snap the view to whole pixels, to avoid blurring
hadj_value0 <- adjustmentGetValue timelineAdj
let hadj_value = toWholePixels scaleValue hadj_value0
traces <- readIORef tracesIORef
bwmode <- readIORef bwmodeIORef
labelsMode <- readIORef labelsModeIORef
(_, xScaleAreaHeight) <- widgetGetSize timelineXScaleArea
let histTotalHeight = stdHistogramHeight + histXScaleHeight
timelineHeight =
calculateTotalTimelineHeight labelsMode histTotalHeight traces
return ViewParameters
{ width = w
, height = timelineHeight
, viewTraces = traces
, hadjValue = hadj_value
, scaleValue = scaleValue
, maxSpkValue = maxSpkValue
, detail = 3 --for now
, bwMode = bwmode
, labelsMode = labelsMode
, histogramHeight = stdHistogramHeight
, minterval = Nothing
, xScaleAreaHeight = xScaleAreaHeight
}
timelineGetYScaleArea :: TimelineView -> DrawingArea
timelineGetYScaleArea timelineWin =
timelineYScaleArea $ timelineState timelineWin
timelineWindowSetHECs :: TimelineView -> Maybe HECs -> IO ()
timelineWindowSetHECs timelineWin@TimelineView{..} mhecs = do
writeIORef hecsIORef mhecs
zoomToFit timelineState mhecs
timelineParamsChanged timelineWin
timelineWindowSetTraces :: TimelineView -> [Trace] -> IO ()
timelineWindowSetTraces timelineWin@TimelineView{tracesIORef} traces = do
writeIORef tracesIORef traces
timelineParamsChanged timelineWin
timelineWindowSetBookmarks :: TimelineView -> [Timestamp] -> IO ()
timelineWindowSetBookmarks timelineWin@TimelineView{bookmarkIORef} bookmarks = do
writeIORef bookmarkIORef bookmarks
timelineParamsChanged timelineWin
-----------------------------------------------------------------------------
timelineViewNew :: Builder -> TimelineViewActions -> IO TimelineView
timelineViewNew builder actions@TimelineViewActions{..} = do
let getWidget cast = builderGetObject builder cast
timelineViewport <- getWidget castToWidget "timeline_viewport"
timelineDrawingArea <- getWidget castToDrawingArea "timeline_drawingarea"
timelineYScaleArea <- getWidget castToDrawingArea "timeline_yscale_area"
timelineXScaleArea <- getWidget castToDrawingArea "timeline_xscale_area"
timelineHScrollbar <- getWidget castToHScrollbar "timeline_hscroll"
timelineVScrollbar <- getWidget castToVScrollbar "timeline_vscroll"
timelineAdj <- rangeGetAdjustment timelineHScrollbar
timelineVAdj <- rangeGetAdjustment timelineVScrollbar
-- HACK: layoutSetAttributes does not work for \mu, so let's work around
fd <- fontDescriptionNew
fontDescriptionSetSize fd 8
fontDescriptionSetFamily fd "sans serif"
widgetModifyFont timelineYScaleArea (Just fd)
cursorIBeam <- cursorNew Xterm
cursorMove <- cursorNew Fleur
hecsIORef <- newIORef Nothing
tracesIORef <- newIORef []
bookmarkIORef <- newIORef []
scaleIORef <- newIORef 0
maxSpkIORef <- newIORef 0
selectionRef <- newIORef (PointSelection 0)
bwmodeIORef <- newIORef False
labelsModeIORef <- newIORef False
timelinePrevView <- newIORef Nothing
let timelineState = TimelineState{..}
timelineWin = TimelineView{..}
------------------------------------------------------------------------
-- Redrawing labelDrawingArea
timelineYScaleArea `onExpose` \_ -> do
maybeEventArray <- readIORef hecsIORef
-- Check to see if an event trace has been loaded
case maybeEventArray of
Nothing -> return False
Just hecs -> do
traces <- readIORef tracesIORef
labelsMode <- readIORef labelsModeIORef
let maxP = maxSparkPool hecs
maxH = fromIntegral (maxYHistogram hecs)
updateYScaleArea timelineState maxP maxH Nothing labelsMode traces
return True
------------------------------------------------------------------------
-- Redrawing XScaleArea
timelineXScaleArea `onExpose` \_ -> do
maybeEventArray <- readIORef hecsIORef
-- Check to see if an event trace has been loaded
case maybeEventArray of
Nothing -> return False
Just hecs -> do
let lastTx = hecLastEventTime hecs
updateXScaleArea timelineState lastTx
return True
------------------------------------------------------------------------
-- Allow mouse wheel to be used for zoom in/out
on timelineViewport scrollEvent $ tryEvent $ do
dir <- eventScrollDirection
mods <- eventModifier
(x, _y) <- eventCoordinates
x_ts <- liftIO $ viewPointToTime timelineWin x
liftIO $ case (dir,mods) of
(ScrollUp, [Control]) -> zoomIn timelineState x_ts
(ScrollDown, [Control]) -> zoomOut timelineState x_ts
(ScrollUp, []) -> vscrollUp timelineState
(ScrollDown, []) -> vscrollDown timelineState
_ -> return ()
------------------------------------------------------------------------
-- Mouse button and selection
widgetSetCursor timelineDrawingArea (Just cursorIBeam)
mouseStateVar <- newIORef None
let withMouseState action = liftIO $ do
st <- readIORef mouseStateVar
st' <- action st
writeIORef mouseStateVar st'
on timelineDrawingArea buttonPressEvent $ do
(x,_y) <- eventCoordinates
button <- eventButton
liftIO $ widgetGrabFocus timelineViewport
withMouseState (\st -> mousePress timelineWin actions st button x)
return False
on timelineDrawingArea buttonReleaseEvent $ do
(x,_y) <- eventCoordinates
button <- eventButton
withMouseState (\st -> mouseRelease timelineWin actions st button x)
return False
widgetAddEvents timelineDrawingArea [Button1MotionMask, Button2MotionMask]
on timelineDrawingArea motionNotifyEvent $ do
(x, _y) <- eventCoordinates
withMouseState (\st -> mouseMove timelineWin st x)
return False
on timelineDrawingArea grabBrokenEvent $ do
withMouseState (mouseMoveCancel timelineWin actions)
return False
-- Escape key to cancel selection or drag
on timelineViewport keyPressEvent $ do
let liftNoMouse a =
let whenNoMouse None = a >> return None
whenNoMouse st = return st
in withMouseState whenNoMouse >> return True
keyName <- eventKeyName
keyVal <- eventKeyVal
case (keyName, keyToChar keyVal, keyVal) of
("Right", _, _) -> liftNoMouse $ scrollRight timelineState
("Left", _, _) -> liftNoMouse $ scrollLeft timelineState
(_ , Just '+', _) -> liftNoMouse $ timelineZoomIn timelineWin
(_ , Just '-', _) -> liftNoMouse $ timelineZoomOut timelineWin
(_, _, 0xff1b) -> withMouseState (mouseMoveCancel timelineWin actions)
>> return True
_ -> return False
------------------------------------------------------------------------
-- Scroll bars
onValueChanged timelineAdj $ queueRedrawTimelines timelineState
onValueChanged timelineVAdj $ queueRedrawTimelines timelineState
onAdjChanged timelineAdj $ queueRedrawTimelines timelineState
onAdjChanged timelineVAdj $ queueRedrawTimelines timelineState
------------------------------------------------------------------------
-- Redrawing
on timelineDrawingArea exposeEvent $ do
exposeRegion <- eventRegion
liftIO $ do
maybeEventArray <- readIORef hecsIORef
-- Check to see if an event trace has been loaded
case maybeEventArray of
Nothing -> return ()
Just hecs -> do
params <- timelineGetViewParameters timelineWin
-- render either the whole height of the timeline, or the window, whichever
-- is larger (this just ensure we fill the background if the timeline is
-- smaller than the window).
(_, h) <- widgetGetSize timelineDrawingArea
let params' = params { height = max (height params) h }
selection <- readIORef selectionRef
bookmarks <- readIORef bookmarkIORef
renderView timelineState params' hecs selection bookmarks exposeRegion
return True
on timelineDrawingArea configureEvent $ do
liftIO $ configureTimelineDrawingArea timelineWin
return True
return timelineWin
-------------------------------------------------------------------------------
viewPointToTime :: TimelineView -> Double -> IO Timestamp
viewPointToTime TimelineView{timelineState=TimelineState{..}} x = do
hadjValue <- adjustmentGetValue timelineAdj
scaleValue <- readIORef scaleIORef
let ts = round (max 0 (hadjValue + x * scaleValue))
return $! ts
viewPointToTimeNoClamp :: TimelineView -> Double -> IO Double
viewPointToTimeNoClamp TimelineView{timelineState=TimelineState{..}} x = do
hadjValue <- adjustmentGetValue timelineAdj
scaleValue <- readIORef scaleIORef
let ts = hadjValue + x * scaleValue
return $! ts
viewRangeToTimeRange :: TimelineView
-> (Double, Double) -> IO (Timestamp, Timestamp)
viewRangeToTimeRange view (x, x') = do
let xMin = min x x'
xMax = max x x'
xv <- viewPointToTime view xMin
xv' <- viewPointToTime view xMax
return (xv, xv')
-------------------------------------------------------------------------------
-- Update the internal state and the timemline view after changing which
-- traces are displayed, or the order of traces.
queueRedrawTimelines :: TimelineState -> IO ()
queueRedrawTimelines TimelineState{..} = do
widgetQueueDraw timelineDrawingArea
widgetQueueDraw timelineYScaleArea
widgetQueueDraw timelineXScaleArea
--FIXME: we are still unclear about which state changes involve which updates
timelineParamsChanged :: TimelineView -> IO ()
timelineParamsChanged timelineWin@TimelineView{timelineState} = do
queueRedrawTimelines timelineState
updateTimelineVScroll timelineWin
configureTimelineDrawingArea :: TimelineView -> IO ()
configureTimelineDrawingArea timelineWin@TimelineView{timelineState} = do
updateTimelineVScroll timelineWin
updateTimelineHPageSize timelineState
updateTimelineVScroll :: TimelineView -> IO ()
updateTimelineVScroll TimelineView{tracesIORef, labelsModeIORef, timelineState=TimelineState{..}} = do
traces <- readIORef tracesIORef
labelsMode <- readIORef labelsModeIORef
let histTotalHeight = stdHistogramHeight + histXScaleHeight
h = calculateTotalTimelineHeight labelsMode histTotalHeight traces
(_,winh) <- widgetGetSize timelineDrawingArea
let winh' = fromIntegral winh;
h' = fromIntegral h
adjustmentSetLower timelineVAdj 0
adjustmentSetUpper timelineVAdj h'
val <- adjustmentGetValue timelineVAdj
when (val > h') $ adjustmentSetValue timelineVAdj h'
set timelineVAdj [
adjustmentPageSize := winh',
adjustmentStepIncrement := winh' * 0.1,
adjustmentPageIncrement := winh' * 0.9
]
-- when the drawing area is resized, we update the page size of the
-- adjustment. Everything else stays the same: we don't scale or move
-- the view at all.
updateTimelineHPageSize :: TimelineState -> IO ()
updateTimelineHPageSize TimelineState{..} = do
(winw,_) <- widgetGetSize timelineDrawingArea
scaleValue <- readIORef scaleIORef
adjustmentSetPageSize timelineAdj (fromIntegral winw * scaleValue)
-------------------------------------------------------------------------------
-- Cursor / selection and mouse interaction
timelineSetSelection :: TimelineView -> TimeSelection -> IO ()
timelineSetSelection TimelineView{..} selection = do
writeIORef selectionRef selection
queueRedrawTimelines timelineState
-- little state machine
data MouseState = None
| PressLeft !Double -- left mouse button is currently pressed
-- but not over threshold for dragging
| DragLeft !Double -- dragging with left mouse button
| DragMiddle !Double !Double -- dragging with middle mouse button
mousePress :: TimelineView -> TimelineViewActions
-> MouseState -> MouseButton -> Double -> IO MouseState
mousePress view@TimelineView{..} TimelineViewActions{..} state button x =
case (state, button) of
(None, LeftButton) -> do xv <- viewPointToTime view x
-- update the view without notifying the client
timelineSetSelection view (PointSelection xv)
return (PressLeft x)
(None, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorMove)
v <- adjustmentGetValue timelineAdj
return (DragMiddle x v)
_ -> return state
where
TimelineState{timelineAdj, timelineDrawingArea} = timelineState
mouseMove :: TimelineView -> MouseState
-> Double -> IO MouseState
mouseMove view@TimelineView{..} state x =
case state of
None -> return None
PressLeft x0
| dragThreshold -> mouseMove view (DragLeft x0) x
| otherwise -> return (PressLeft x0)
where
dragThreshold = abs (x - x0) > 5
DragLeft x0 -> do (xv, xv') <- viewRangeToTimeRange view (x0, x)
-- update the view without notifying the client
timelineSetSelection view (RangeSelection xv xv')
return (DragLeft x0)
DragMiddle x0 v -> do xv <- viewPointToTimeNoClamp view x
xv' <- viewPointToTimeNoClamp view x0
scrollTo timelineState (v + (xv' - xv))
return (DragMiddle x0 v)
mouseMoveCancel :: TimelineView -> TimelineViewActions
-> MouseState -> IO MouseState
mouseMoveCancel view@TimelineView{..} TimelineViewActions{..} state =
case state of
PressLeft x0 -> do xv <- viewPointToTime view x0
timelineViewSelectionChanged (PointSelection xv)
return None
DragLeft x0 -> do xv <- viewPointToTime view x0
timelineViewSelectionChanged (PointSelection xv)
return None
DragMiddle _ _ -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam)
return None
None -> return None
where
TimelineState{timelineDrawingArea} = timelineState
mouseRelease :: TimelineView -> TimelineViewActions
-> MouseState -> MouseButton -> Double -> IO MouseState
mouseRelease view@TimelineView{..} TimelineViewActions{..} state button x =
case (state, button) of
(PressLeft x0, LeftButton) -> do xv <- viewPointToTime view x0
timelineViewSelectionChanged (PointSelection xv)
return None
(DragLeft x0, LeftButton) -> do (xv, xv') <- viewRangeToTimeRange view (x0, x)
timelineViewSelectionChanged (RangeSelection xv xv')
return None
(DragMiddle{}, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam)
return None
_ -> return state
where
TimelineState{timelineDrawingArea} = timelineState
widgetSetCursor :: WidgetClass widget => widget -> Maybe Cursor -> IO ()
widgetSetCursor widget cursor = do
#if MIN_VERSION_gtk(0,12,1)
dw <- widgetGetDrawWindow widget
drawWindowSetCursor dw cursor
#endif
return ()
-------------------------------------------------------------------------------
timelineZoomIn :: TimelineView -> IO ()
timelineZoomIn TimelineView{..} = do
selection <- readIORef selectionRef
zoomIn timelineState (selectionPoint selection)
timelineZoomOut :: TimelineView -> IO ()
timelineZoomOut TimelineView{..} = do
selection <- readIORef selectionRef
zoomOut timelineState (selectionPoint selection)
timelineZoomToFit :: TimelineView -> IO ()
timelineZoomToFit TimelineView{..} = do
mhecs <- readIORef hecsIORef
zoomToFit timelineState mhecs
timelineScrollLeft :: TimelineView -> IO ()
timelineScrollLeft TimelineView{timelineState} = scrollLeft timelineState
timelineScrollRight :: TimelineView -> IO ()
timelineScrollRight TimelineView{timelineState} = scrollRight timelineState
timelineScrollToBeginning :: TimelineView -> IO ()
timelineScrollToBeginning TimelineView{timelineState} =
scrollToBeginning timelineState
timelineScrollToEnd :: TimelineView -> IO ()
timelineScrollToEnd TimelineView{timelineState} =
scrollToEnd timelineState
-- This one is especially evil since it relies on a shared cursor IORef
timelineCentreOnCursor :: TimelineView -> IO ()
timelineCentreOnCursor TimelineView{..} = do
selection <- readIORef selectionRef
centreOnCursor timelineState (selectionPoint selection)
selectionPoint :: TimeSelection -> Timestamp
selectionPoint (PointSelection x) = x
selectionPoint (RangeSelection x x') = midpoint x x'
where
midpoint a b = a + (b - a) `div` 2
threadscope-0.2.2/GUI/ProgressView.hs 0000644 0000000 0000000 00000006453 12044651254 015634 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
module GUI.ProgressView (
ProgressView,
withProgress,
setText,
setTitle,
setProgress,
startPulse,
) where
import Graphics.UI.Gtk as Gtk
import GUI.GtkExtras
import Graphics.Rendering.Cairo
import qualified Control.Concurrent as Concurrent
import Control.Exception
import Data.Typeable
import Prelude hiding (catch)
data ProgressView = ProgressView {
progressWindow :: Gtk.Window,
progressLabel :: Gtk.Label,
progressBar :: Gtk.ProgressBar
}
-- | Perform a long-running operation and display a progress window. The
-- operation has access to the progress window and it is expected to update it
-- using 'setText' and 'setProgress'
--
-- The user may cancel the operation at any time.
--
withProgress :: WindowClass win => win -> (ProgressView -> IO a) -> IO (Maybe a)
withProgress parent action = do
self <- Concurrent.myThreadId
let cancel = throwTo self OperationInterrupted
bracket (new parent cancel) close $ \progress ->
fmap Just (action progress)
`catch` \OperationInterrupted -> return Nothing
data OperationInterrupted = OperationInterrupted
deriving (Typeable, Show)
instance Exception OperationInterrupted
setText :: ProgressView -> String -> IO ()
setText view msg =
set (progressBar view) [
progressBarText := msg
]
setTitle :: ProgressView -> String -> IO ()
setTitle view msg = do
set (progressWindow view) [ windowTitle := msg ]
set (progressLabel view) [ labelLabel := "" ++ msg ++ "" ]
startPulse :: ProgressView -> IO (IO ())
startPulse view = do
let pulse = do
progressBarPulse (progressBar view)
Concurrent.threadDelay 200000
pulse
thread <- Concurrent.forkIO $
pulse `catch` \OperationInterrupted -> return ()
let stop = throwTo thread OperationInterrupted
waitGUI
return stop
setProgress :: ProgressView -> Int -> Int -> IO ()
setProgress view total current = do
let frac = fromIntegral current / fromIntegral total
set (progressBar view) [ progressBarFraction := frac ]
waitGUI
close :: ProgressView -> IO ()
close view = widgetDestroy (progressWindow view)
new :: WindowClass win => win -> IO () -> IO ProgressView
new parent cancelAction = do
win <- windowNew
set win [
containerBorderWidth := 10,
windowTitle := "",
windowTransientFor := toWindow parent,
windowModal := True,
windowWindowPosition := WinPosCenterOnParent,
windowDefaultWidth := 400,
windowSkipTaskbarHint := True
]
progText <- labelNew Nothing
set progText [
miscXalign := 0,
labelUseMarkup := True
]
progress <- progressBarNew
cancel <- buttonNewFromStock stockCancel
onClicked cancel (widgetDestroy win >> cancelAction)
onDelete win (\_ -> cancelAction >> return True)
on win keyPressEvent $ do
keyVal <- eventKeyVal
case keyVal of
0xff1b -> liftIO $ cancelAction >> return True
_ -> return False
vbox <- vBoxNew False 20
hbox <- hBoxNew False 0
boxPackStart vbox progText PackRepel 10
boxPackStart vbox progress PackGrow 5
boxPackStart vbox hbox PackNatural 5
boxPackEnd hbox cancel PackNatural 0
containerAdd win vbox
widgetShowAll win
return ProgressView {
progressWindow = win,
progressLabel = progText,
progressBar = progress
}
threadscope-0.2.2/GUI/Dialogs.hs 0000644 0000000 0000000 00000013166 12044651254 014556 0 ustar 00 0000000 0000000 module GUI.Dialogs where
import Paths_threadscope (getDataFileName, version)
import Graphics.UI.Gtk
import Data.Version (showVersion)
import System.FilePath
-------------------------------------------------------------------------------
aboutDialog :: WindowClass window => window -> IO ()
aboutDialog parent
= do dialog <- aboutDialogNew
logoPath <- getDataFileName "threadscope.png"
logo <- pixbufNewFromFile logoPath
set dialog [
aboutDialogName := "ThreadScope",
aboutDialogVersion := showVersion version,
aboutDialogCopyright := "Released under the GHC license as part of the Glasgow Haskell Compiler.",
aboutDialogComments := "A GHC eventlog profile viewer",
aboutDialogAuthors := ["Donnie Jones ",
"Simon Marlow ",
"Satnam Singh ",
"Duncan Coutts ",
"Mikolaj Konarski ",
"Nicolas Wu ",
"Eric Kow "],
aboutDialogLogo := Just logo,
aboutDialogWebsite := "http://www.haskell.org/haskellwiki/ThreadScope",
windowTransientFor := toWindow parent
]
onResponse dialog $ \_ -> widgetDestroy dialog
widgetShow dialog
-------------------------------------------------------------------------------
openFileDialog :: WindowClass window => window -> (FilePath -> IO ()) -> IO ()
openFileDialog parent open
= do dialog <- fileChooserDialogNew
(Just "Open Profile...")
(Just (toWindow parent))
FileChooserActionOpen
[("gtk-cancel", ResponseCancel)
,("gtk-open", ResponseAccept)]
set dialog [
windowModal := True
]
eventlogfiles <- fileFilterNew
fileFilterSetName eventlogfiles "GHC eventlog files (*.eventlog)"
fileFilterAddPattern eventlogfiles "*.eventlog"
fileChooserAddFilter dialog eventlogfiles
allfiles <- fileFilterNew
fileFilterSetName allfiles "All files"
fileFilterAddPattern allfiles "*"
fileChooserAddFilter dialog allfiles
onResponse dialog $ \response -> do
case response of
ResponseAccept -> do
mfile <- fileChooserGetFilename dialog
case mfile of
Just file -> open file
Nothing -> return ()
_ -> return ()
widgetDestroy dialog
widgetShowAll dialog
-------------------------------------------------------------------------------
data FileExportFormat = FormatPDF | FormatPNG
exportFileDialog :: WindowClass window => window
-> FilePath
-> (FilePath -> FileExportFormat -> IO ())
-> IO ()
exportFileDialog parent oldfile save = do
dialog <- fileChooserDialogNew
(Just "Save timeline image...")
(Just (toWindow parent))
FileChooserActionSave
[("gtk-cancel", ResponseCancel)
,("gtk-save", ResponseAccept)]
set dialog [
fileChooserDoOverwriteConfirmation := True,
windowModal := True
]
let (olddir, oldfilename) = splitFileName oldfile
fileChooserSetCurrentName dialog (replaceExtension oldfilename "png")
fileChooserSetCurrentFolder dialog olddir
pngFiles <- fileFilterNew
fileFilterSetName pngFiles "PNG bitmap files"
fileFilterAddPattern pngFiles "*.png"
fileChooserAddFilter dialog pngFiles
pdfFiles <- fileFilterNew
fileFilterSetName pdfFiles "PDF files"
fileFilterAddPattern pdfFiles "*.pdf"
fileChooserAddFilter dialog pdfFiles
onResponse dialog $ \response ->
case response of
ResponseAccept -> do
mfile <- fileChooserGetFilename dialog
case mfile of
Just file
| takeExtension file == ".pdf" -> do
save file FormatPDF
widgetDestroy dialog
| takeExtension file == ".png" -> do
save file FormatPNG
widgetDestroy dialog
| otherwise ->
formatError dialog
Nothing -> widgetDestroy dialog
_ -> widgetDestroy dialog
widgetShowAll dialog
where
formatError dialog = do
msg <- messageDialogNew (Just (toWindow dialog))
[DialogModal, DialogDestroyWithParent]
MessageError ButtonsClose
"The file format is unknown or unsupported"
set msg [
messageDialogSecondaryText := Just $
"The PNG and PDF formats are supported. "
++ "Please use a file extension of '.png' or '.pdf'."
]
dialogRun msg
widgetDestroy msg
-------------------------------------------------------------------------------
errorMessageDialog :: WindowClass window => window -> String -> String -> IO ()
errorMessageDialog parent headline explanation = do
dialog <- messageDialogNew (Just (toWindow parent))
[] MessageError ButtonsNone ""
set dialog
[ windowModal := True
, windowTransientFor := toWindow parent
, messageDialogText := Just headline
, messageDialogSecondaryText := Just explanation
, windowResizable := True
]
dialogAddButton dialog "Close" ResponseClose
dialogSetDefaultResponse dialog ResponseClose
onResponse dialog $ \_-> widgetDestroy dialog
widgetShowAll dialog
threadscope-0.2.2/GUI/SummaryView.hs 0000644 0000000 0000000 00000111327 12044651254 015462 0 ustar 00 0000000 0000000 module GUI.SummaryView (
SummaryView,
summaryViewNew,
summaryViewSetEvents,
summaryViewSetInterval,
) where
import GHC.RTS.Events
import GUI.Types
import Graphics.UI.Gtk
import Data.Array
import Data.IORef
import Data.Maybe
import Data.Word (Word64)
import Data.List as L
import qualified Data.IntMap as IM
import Control.Monad
import Control.Exception (assert)
import Numeric (showFFloat)
import Text.Printf
------------------------------------------------------------------------------
type Events = Array Int CapEvent
data SummaryView = SummaryView {
-- we cache the stats for the whole interval
cacheEventsStats :: !(IORef (Maybe (Events, SummaryStats, Bool)))
-- widgets for time stuff
, labelTimeTotal :: Label
, labelTimeMutator :: Label
, labelTimeGC :: Label
, labelTimeProductivity :: Label
-- widgets for heap stuff
, labelHeapMaxSize
, labelHeapMaxResidency
, labelHeapAllocTotal
, labelHeapAllocRate
, labelHeapMaxSlop :: (Label, Label, Label, Label)
, tableHeap :: Widget
-- widgets for GC stuff
, labelGcCopied :: (Label, Label, Label, Label)
, labelGcParWorkBalance :: Label
, storeGcStats :: ListStore GcStatsEntry
, tableGc :: Widget
-- widgets for sparks stuff
, storeSparkStats :: ListStore (Cap, SparkCounts)
}
------------------------------------------------------------------------------
summaryViewNew :: Builder -> IO SummaryView
summaryViewNew builder = do
cacheEventsStats <- newIORef Nothing
let getWidget cast = builderGetObject builder cast
getLabel = getWidget castToLabel
getHeapLabels w1 w2 w3 w4 = liftM4 (,,,) (getLabel w1) (getLabel w2)
(getLabel w3) (getLabel w4)
labelTimeTotal <- getWidget castToLabel "labelTimeTotal"
labelTimeMutator <- getWidget castToLabel "labelTimeMutator"
labelTimeGC <- getWidget castToLabel "labelTimeGC"
labelTimeProductivity <- getWidget castToLabel "labelTimeProductivity"
labelHeapMaxSize <- getHeapLabels "labelHeapMaxSize" "labelHeapMaxSizeUnit"
"labelHeapMaxSizeBytes" "labelHeapMaxSizeUnit1"
labelHeapMaxResidency <- getHeapLabels "labelHeapMaxResidency" "labelHeapMaxResidencyUnit"
"labelHeapMaxResidencyBytes" "labelHeapMaxResidencyUnit1"
labelHeapAllocTotal <- getHeapLabels "labelHeapAllocTotal" "labelHeapAllocTotalUnit"
"labelHeapAllocTotalBytes" "labelHeapAllocTotalUnit1"
labelHeapAllocRate <- getHeapLabels "labelHeapAllocRate" "labelHeapAllocRateUnit"
"labelHeapAllocRateBytes" "labelHeapAllocRateUnit1"
labelHeapMaxSlop <- getHeapLabels "labelHeapMaxSlop" "labelHeapMaxSlopUnit"
"labelHeapMaxSlopBytes" "labelHeapMaxSlopUnit1"
tableHeap <- getWidget castToWidget "tableHeap"
labelGcCopied <- getHeapLabels "labelGcCopied" "labelGcCopiedUnit"
"labelGcCopiedBytes" "labelGcCopiedUnit1"
labelGcParWorkBalance <- getWidget castToLabel "labelGcParWorkBalance"
storeGcStats <- listStoreNew []
tableGc <- getWidget castToWidget "tableGC"
storeSparkStats <- listStoreNew []
let summaryView = SummaryView{..}
treeviewGcStats <- getWidget castToTreeView "treeviewGcStats"
treeViewSetModel treeviewGcStats storeGcStats
let addGcColumn = addColumn treeviewGcStats storeGcStats
addGcColumn "Generation" $ \(GcStatsEntry gen _ _ _ _ _) ->
[ cellText := if gen == -1 then "GC Total" else "Gen " ++ show gen ]
addGcColumn "Collections" $ \(GcStatsEntry _ colls _ _ _ _) ->
[ cellText := show colls ]
addGcColumn "Par collections" $ \(GcStatsEntry _ _ pcolls _ _ _) ->
[ cellText := show pcolls ]
addGcColumn "Elapsed time" $ \(GcStatsEntry _ _ _ time _ _) ->
[ cellText := printf "%5.2fs" (timeToSecondsDbl time) ]
addGcColumn "Avg pause" $ \(GcStatsEntry _ _ _ _ avgpause _) ->
[ cellText := printf "%3.4fs" avgpause ]
addGcColumn "Max pause" $ \(GcStatsEntry _ _ _ _ _ maxpause) ->
[ cellText := printf "%3.4fs" maxpause ]
treeviewSparkStats <- getWidget castToTreeView "treeviewSparkStats"
treeViewSetModel treeviewSparkStats storeSparkStats
let addSparksColumn = addColumn treeviewSparkStats storeSparkStats
addSparksColumn "HEC" $ \(hec, _) ->
[ cellText := if hec == -1 then "Total" else "HEC " ++ show hec ]
addSparksColumn "Total" $ \(_, SparkCounts total _ _ _ _ _) ->
[ cellText := show total ]
addSparksColumn "Converted" $ \(_, SparkCounts _ conv _ _ _ _) ->
[ cellText := show conv ]
addSparksColumn "Overflowed" $ \(_, SparkCounts _ _ ovf _ _ _) ->
[ cellText := show ovf ]
addSparksColumn "Dud" $ \(_, SparkCounts _ _ _ dud _ _) ->
[ cellText := show dud ]
addSparksColumn "GC'd" $ \(_, SparkCounts _ _ _ _ gc _) ->
[ cellText := show gc ]
addSparksColumn "Fizzled" $ \(_, SparkCounts _ _ _ _ _ fiz) ->
[ cellText := show fiz ]
return summaryView
where
addColumn view store title mkAttrs = do
col <- treeViewColumnNew
cell <- cellRendererTextNew
treeViewColumnSetTitle col title
treeViewColumnPackStart col cell False
treeViewAppendColumn view col
cellLayoutSetAttributes col cell store mkAttrs
------------------------------------------------------------------------------
summaryViewSetEvents :: SummaryView -> Maybe (Array Int CapEvent) -> IO ()
summaryViewSetEvents view@SummaryView{cacheEventsStats} Nothing = do
writeIORef cacheEventsStats Nothing
setSummaryStatsEmpty view
summaryViewSetEvents view@SummaryView{cacheEventsStats} (Just events) = do
let stats = summaryStats events Nothing
-- this is an almost certain indicator that there
-- are no heap events in the eventlog:
hasHeapEvents = heapMaxSize (summHeapStats stats) /= Just 0
writeIORef cacheEventsStats (Just (events, stats, hasHeapEvents))
setSummaryStats view stats hasHeapEvents
summaryViewSetInterval :: SummaryView -> Maybe Interval -> IO ()
summaryViewSetInterval view@SummaryView{cacheEventsStats} Nothing = do
cache <- readIORef cacheEventsStats
case cache of
Nothing -> return ()
Just (_, stats, hasHeap) -> setSummaryStats view stats hasHeap
summaryViewSetInterval view@SummaryView{cacheEventsStats} (Just interval) = do
cache <- readIORef cacheEventsStats
case cache of
Nothing -> return ()
Just (events, _, hasHeap) -> setSummaryStats view stats hasHeap
where stats = summaryStats events (Just interval)
------------------------------------------------------------------------------
setSummaryStats :: SummaryView -> SummaryStats -> Bool -> IO ()
setSummaryStats view SummaryStats{..} hasHeapEvents = do
setTimeStats view summTimeStats
if hasHeapEvents
then do setHeapStatsAvailable view True
setHeapStats view summHeapStats
setGcStats view summGcStats
else setHeapStatsAvailable view False
setSparkStats view summSparkStats
setTimeStats :: SummaryView -> TimeStats -> IO ()
setTimeStats SummaryView{..} TimeStats{..} =
mapM_ (\(label, text) -> set label [ labelText := text ])
[ (labelTimeTotal , showFFloat (Just 2) (timeToSecondsDbl timeTotal) "s")
, (labelTimeMutator , showFFloat (Just 2) (timeToSecondsDbl timeMutator) "s")
, (labelTimeGC , showFFloat (Just 2) (timeToSecondsDbl timeGC) "s")
, (labelTimeProductivity, showFFloat (Just 1) (timeProductivity * 100) "% of mutator vs total")
]
setHeapStats :: SummaryView -> HeapStats -> IO ()
setHeapStats SummaryView{..} HeapStats{..} = do
setHeapStatLabels labelHeapMaxSize heapMaxSize "" ""
setHeapStatLabels labelHeapMaxResidency heapMaxResidency "" ""
setHeapStatLabels labelHeapAllocTotal heapTotalAlloc "" ""
setHeapStatLabels labelHeapAllocRate heapAllocRate "/s" " per second (of mutator time)"
setHeapStatLabels labelHeapMaxSlop heapMaxSlop "" ""
setHeapStatLabels labelGcCopied heapCopiedDuringGc "" ""
where
setHeapStatLabels labels stat unitSuffix unitSuffixLong =
let texts = case stat of
Nothing -> ("N/A", "", "", "")
Just b -> ( formatBytesInUnit b u, formatUnit u ++ unitSuffix
, formatBytes b, "bytes" ++ unitSuffixLong)
where u = getByteUnit b
in setLabels labels texts
setLabels (short,shortunit,long,longunit) (short', shortunit', long', longunit') = do
mapM_ (\(label, text) -> set label [ labelText := text ])
[ (short, short'), (shortunit, shortunit')
, (long, long'), (longunit, longunit') ]
setGcStats :: SummaryView -> GcStats -> IO ()
setGcStats SummaryView{..} GcStats{..} = do
let balText = maybe "N/A"
(printf "%.2f%% (serial 0%%, perfect 100%%)")
gcParWorkBalance
set labelGcParWorkBalance [ labelText := balText ]
listStoreClear storeGcStats
mapM_ (listStoreAppend storeGcStats) (gcTotalStats:gcGenStats)
setSparkStats :: SummaryView -> SparkStats -> IO ()
setSparkStats SummaryView{..} SparkStats{..} = do
listStoreClear storeSparkStats
mapM_ (listStoreAppend storeSparkStats) ((-1,totalSparkStats):capSparkStats)
data ByteUnit = TiB | GiB | MiB | KiB | B deriving Show
byteUnitVal :: ByteUnit -> Word64
byteUnitVal TiB = 2^40
byteUnitVal GiB = 2^30
byteUnitVal MiB = 2^20
byteUnitVal KiB = 2^10
byteUnitVal B = 1
getByteUnit :: Word64 -> ByteUnit
getByteUnit b
| b >= 2^40 = TiB
| b >= 2^30 = GiB
| b >= 2^20 = MiB
| b >= 2^10 = KiB
| otherwise = B
formatBytesInUnit :: Word64 -> ByteUnit -> String
formatBytesInUnit n u =
formatFixed (fromIntegral n / fromIntegral (byteUnitVal u))
where
formatFixed x = showFFloat (Just 1) x ""
formatUnit :: ByteUnit -> String
formatUnit = show
formatBytes :: Word64 -> String
formatBytes b = ppWithCommas b
ppWithCommas :: Word64 -> String
ppWithCommas =
let spl [] = []
spl l = let (c3, cs) = L.splitAt 3 l
in c3 : spl cs
in L.reverse . L.intercalate "," . spl . L.reverse . show
setSummaryStatsEmpty :: SummaryView -> IO ()
setSummaryStatsEmpty SummaryView{..} = do
mapM_ (\label -> set label [ labelText := "", widgetTooltipText := Nothing ]) $
[ labelTimeTotal, labelTimeMutator
, labelTimeGC, labelTimeProductivity ] ++
[ w
| (a,b,c,d) <- [ labelHeapMaxSize, labelHeapMaxResidency
, labelHeapAllocTotal, labelHeapAllocRate
, labelHeapMaxSlop, labelGcCopied ]
, w <- [ a,b,c,d] ]
listStoreClear storeGcStats
listStoreClear storeSparkStats
setHeapStatsAvailable :: SummaryView -> Bool -> IO ()
setHeapStatsAvailable SummaryView{..} available
| available = do
forM_ unavailableWidgets $ \widget ->
set widget [ widgetTooltipText := Nothing, widgetSensitive := True ]
| otherwise = do
forM_ allLabels $ \label -> set label [ labelText := "" ]
listStoreClear storeGcStats
forM_ unavailableLabels $ \label ->
set label [ labelText := "(unavailable)" ]
forM_ unavailableWidgets $ \widget ->
set widget [ widgetTooltipText := Just msgInfoUnavailable, widgetSensitive := False ]
where
allLabels =
[ labelTimeMutator, labelTimeGC
, labelTimeProductivity, labelGcParWorkBalance ] ++
[ w | (a,b,c,d) <- [ labelHeapMaxSize, labelHeapMaxResidency
, labelHeapAllocTotal, labelHeapAllocRate
, labelHeapMaxSlop, labelGcCopied ]
, w <- [ a,b,c,d] ]
unavailableLabels =
[ labelTimeMutator, labelTimeGC
, labelTimeProductivity, labelGcParWorkBalance
, case labelGcCopied of (w,_,_,_) -> w ] ++
[ c | (_,_,c,_) <- [ labelHeapMaxSize, labelHeapMaxResidency
, labelHeapAllocTotal, labelHeapAllocRate
, labelHeapMaxSlop ] ]
unavailableWidgets = [ toWidget labelTimeMutator, toWidget labelTimeGC
, toWidget labelTimeProductivity
, tableHeap, tableGc ]
msgInfoUnavailable = "This eventlog does not contain heap or GC information."
------------------------------------------------------------------------------
-- Calculating the stats we want to display
--
data SummaryStats = SummaryStats {
summTimeStats :: TimeStats,
summHeapStats :: HeapStats,
summGcStats :: GcStats,
summSparkStats :: SparkStats
}
data TimeStats = TimeStats {
timeTotal :: !Word64, -- we really should have a better type for elapsed time
timeGC :: !Word64,
timeMutator :: !Word64,
timeProductivity :: !Double
}
data HeapStats = HeapStats {
heapMaxSize :: Maybe Word64,
heapMaxResidency :: Maybe Word64,
heapMaxSlop :: Maybe Word64,
heapTotalAlloc :: Maybe Word64,
heapAllocRate :: Maybe Word64,
heapCopiedDuringGc :: Maybe Word64
}
data GcStats = GcStats {
gcNumThreads :: !Int,
gcParWorkBalance :: !(Maybe Double),
gcGenStats :: [GcStatsEntry],
gcTotalStats :: !GcStatsEntry
}
data GcStatsEntry = GcStatsEntry !Int !Int !Int !Word64 !Double !Double
data SparkStats = SparkStats {
capSparkStats :: [(Cap, SparkCounts)],
totalSparkStats :: !SparkCounts
}
data SparkCounts = SparkCounts !Word64 !Word64 !Word64 !Word64 !Word64 !Word64
-- | Take the events, and optionally some sub-range, and generate the summary
-- stats for that range.
--
-- We take a two-step approach:
-- * a single pass over the events, accumulating into an intermediate
-- 'StatsAccum' record,
-- * then look at that 'StatsAccum' record and construct the various final
-- stats that we want to present.
--
summaryStats :: Array Int CapEvent -> Maybe Interval -> SummaryStats
summaryStats events minterval =
SummaryStats {
summHeapStats = hs,
summGcStats = gs,
summSparkStats = ss,
summTimeStats = ts
}
where
!statsAccum = accumStats events minterval
gs = gcStats statsAccum
ss = sparkStats statsAccum
ts = timeStats events minterval gs
hs = heapStats statsAccum ts
-- | Linearly accumulate the stats from the events array,
-- either the full thing or some sub-range.
accumStats :: Array Int CapEvent -> Maybe Interval -> StatsAccum
accumStats events minterval =
foldl' accumEvent start [ events ! i | i <- range eventsRange ]
where
eventsRange = selectEventRange events minterval
-- If we're starting from time zero then we know many of the stats
-- also start at from, where as from other points it's just unknown
start | fst eventsRange == 0 = zeroStatsAccum
| otherwise = emptyStatsAccum
-- | Given the event array and a time interval, return the range of array
-- indicies containing that interval. The Nothing interval means to select
-- the whole array range.
--
selectEventRange :: Array Int CapEvent -> Maybe Interval -> (Int, Int)
selectEventRange arr Nothing = bounds arr
selectEventRange arr (Just (start, end)) = (lbound, ubound)
where
!lbound = either snd id $ findArrayRange cmp arr start
!ubound = either fst id $ findArrayRange cmp arr end
cmp ts (CapEvent _ (Event ts' _)) = compare ts ts'
findArrayRange :: (key -> val -> Ordering)
-> Array Int val -> key -> Either (Int,Int) Int
findArrayRange cmp arr key =
binarySearch a0 b0 key
where
(a0,b0) = bounds arr
binarySearch a b key
| a > b = Left (b,a)
| otherwise = case cmp key (arr ! mid) of
LT -> binarySearch a (mid-1) key
EQ -> Right mid
GT -> binarySearch (mid+1) b key
where mid = (a + b) `div` 2
------------------------------------------------------------------------------
-- Final step where we convert from StatsAccum to various presentation forms
timeStats :: Array Int CapEvent -> Maybe Interval -> GcStats -> TimeStats
timeStats events minterval
GcStats { gcTotalStats = GcStatsEntry _ _ _ timeGC _ _ } =
TimeStats {..}
where
timeTotal = intervalEnd - intervalStart
timeMutator = timeTotal - timeGC
timeProductivity = timeToSecondsDbl timeMutator
/ timeToSecondsDbl timeTotal
(intervalStart, intervalEnd) =
case minterval of
Just (s,e) -> (s, e)
Nothing -> (0, timeOf (events ! ub))
where
(_lb, ub) = bounds events
timeOf (CapEvent _ (Event t _)) = t
heapStats :: StatsAccum -> TimeStats -> HeapStats
heapStats StatsAccum{..} TimeStats{timeMutator} =
HeapStats {
heapMaxSize = dmaxMemory,
heapMaxResidency = dmaxResidency,
heapMaxSlop = dmaxSlop,
heapTotalAlloc = if totalAlloc == 0
then Nothing
else Just totalAlloc,
heapAllocRate = if timeMutator == 0 || totalAlloc == 0
then Nothing
else Just $ truncate (fromIntegral totalAlloc / timeToSecondsDbl timeMutator),
heapCopiedDuringGc = if dcopied == Just 0
then Nothing
else dcopied
}
where
totalAlloc = sum [ end - start
| (end,start) <- IM.elems dallocTable ]
gcStats :: StatsAccum -> GcStats
gcStats StatsAccum{..} =
GcStats {
gcNumThreads = nThreads,
gcParWorkBalance,
gcGenStats = [ mkGcStatsEntry gen (gcGather gen)
| gen <- gens ],
gcTotalStats = mkGcStatsEntry gcGenTot (gcGather gcGenTot)
}
where
nThreads = fromMaybe 1 dmaxParNThreads
gcParWorkBalance | nThreads <= 1
|| fromMaybe 0 dparMaxCopied <= 0 = Nothing
| otherwise =
Just $
100 * ((maybe 0 fromIntegral dparTotCopied
/ maybe 0 fromIntegral dparMaxCopied) - 1)
/ (fromIntegral nThreads - 1)
gens = [0..maxGeneration]
where
-- Does not work for generationless GCs, but works reasonably
-- for > 2 gens and perfectly for 2 gens.
maxGeneration = maximum $ 1
: [ maxGen
| RtsGC { gcGenStat } <- IM.elems dGCTable
, not (IM.null gcGenStat)
, let (maxGen, _) = IM.findMax gcGenStat ]
gcGather :: Gen -> GenStat
gcGather gen = gcSum gen $ map gcGenStat $ IM.elems dGCTable
-- TODO: Consider per-HEC display of GC stats and then use
-- the values summed over all generations at key gcGenTot at each cap.
gcSum :: Gen -> [IM.IntMap GenStat] -> GenStat
gcSum gen l =
GenStat (sumPr gcAll) (sumPr gcPar)
(gcElapsed mainGen) (gcMaxPause mainGen)
where
l_genGC = map (IM.findWithDefault emptyGenStat gen) l
sumPr proj = sum $ map proj l_genGC
_maxPr proj = L.maximum $ map proj l_genGC
_minPr proj = L.minimum $ filter (> 0) $ map proj l_genGC
-- This would be the most balanced way of aggregating gcElapsed,
-- if only the event times were accurate.
_avgPr proj = let vs = filter (> 0) $ map proj l_genGC
in sum vs `div` fromIntegral (length vs)
-- But since the times include scheduling noise,
-- we only use the times from the main cap for each GC
-- and so get readings almost identical to +RTS -s.
mainGen = IM.findWithDefault emptyGenStat gen mainStat
mainStat = gcGenStat (fromMaybe (defaultGC 0) dGCMain)
mkGcStatsEntry :: Gen -> GenStat -> GcStatsEntry
mkGcStatsEntry gen GenStat{..} =
GcStatsEntry gen gcAll gcPar gcElapsedS gcAvgPauseS gcMaxPauseS
where
gcElapsedS = gcElapsed
gcMaxPauseS = timeToSecondsDbl gcMaxPause
gcAvgPauseS
| gcAll == 0 = 0
| otherwise = timeToSeconds $
fromIntegral gcElapsed / fromIntegral gcAll
sparkStats :: StatsAccum -> SparkStats
sparkStats StatsAccum{dsparkTable} =
SparkStats {
capSparkStats =
[ (cap, mkSparkStats sparkCounts)
| (cap, sparkCounts) <- capsSparkCounts ],
totalSparkStats =
mkSparkStats $
foldl' (binopSparks (+)) zeroSparks
[ sparkCounts | (_cap, sparkCounts) <- capsSparkCounts ]
}
where
capsSparkCounts =
[ (cap, sparkCounts)
| (cap, (countsEnd, countsStart)) <- IM.assocs dsparkTable
, let sparkCounts = binopSparks (-) countsEnd countsStart ]
mkSparkStats RtsSpark {sparkCreated, sparkDud, sparkOverflowed,
sparkConverted, sparkFizzled, sparkGCd} =
-- in our final presentation we show the total created,
-- and the breakdown of that into outcomes:
SparkCounts (sparkCreated + sparkDud + sparkOverflowed)
sparkConverted sparkOverflowed
sparkDud sparkGCd sparkFizzled
------------------------------------------------------------------------------
timeToSecondsDbl :: Integral a => a -> Double
timeToSecondsDbl t = timeToSeconds $ fromIntegral t
timeToSeconds :: Double -> Double
timeToSeconds t = t / tIME_RESOLUTION
where tIME_RESOLUTION = 1000000
------------------------------------------------------------------------------
-- The single-pass stats accumulation stuff
--
-- | Data collected and computed gradually while events are scanned.
data StatsAccum = StatsAccum
{ dallocTable :: !(IM.IntMap (Word64, Word64)) -- indexed by caps
, dcopied :: !(Maybe Word64)
, dmaxResidency :: !(Maybe Word64)
, dmaxSlop :: !(Maybe Word64)
, dmaxMemory :: !(Maybe Word64)
--, dmaxFrag :: Maybe Word64 -- not important enough
, dGCTable :: !(IM.IntMap RtsGC) -- indexed by caps
-- Here we store the official +RTS -s timings of GCs,
-- that is times aggregated from the main caps of all GCs.
-- For now only gcElapsed and gcMaxPause are needed, so the rest
-- of the fields stays at default values.
, dGCMain :: !(Maybe RtsGC)
, dparMaxCopied :: !(Maybe Word64)
, dparTotCopied :: !(Maybe Word64)
, dmaxParNThreads :: !(Maybe Int)
--, dtaskTable -- of questionable usefulness, hard to get
, dsparkTable :: !(IM.IntMap (RtsSpark, RtsSpark)) -- indexed by caps
--, dInitExitT -- TODO. At least init time can be included in the total
-- time registered in the eventlog. Can we measure this
-- as the time between some initial events?
--, dGCTime -- Is better computed after all events are scanned,
-- e.g., because the same info can be used to calculate
-- per-cap GCTime and other per-cap stats.
--, dtotalTime -- TODO: can we measure this excluding INIT or EXIT times?
}
data RtsSpark = RtsSpark
{ sparkCreated, sparkDud, sparkOverflowed
, sparkConverted, sparkFizzled, sparkGCd :: !Word64
}
zeroSparks :: RtsSpark
zeroSparks = RtsSpark 0 0 0 0 0 0
binopSparks :: (Word64 -> Word64 -> Word64) -> RtsSpark -> RtsSpark -> RtsSpark
binopSparks op (RtsSpark crt1 dud1 ovf1 cnv1 fiz1 gcd1)
(RtsSpark crt2 dud2 ovf2 cnv2 fiz2 gcd2) =
RtsSpark (crt1 `op` crt2) (dud1 `op` dud2) (ovf1 `op` ovf2)
(cnv1 `op` cnv2) (fiz1 `op` fiz2) (gcd1 `op` gcd2)
type Gen = Int
type Cap = Int
data GcMode =
ModeInit | ModeStart | ModeSync Cap | ModeGHC Cap Gen | ModeEnd | ModeIdle
deriving Eq
data RtsGC = RtsGC
{ gcMode :: !GcMode
, gcStartTime :: !Timestamp
, gcGenStat :: !(IM.IntMap GenStat) -- indexed by generations
}
-- Index at the @gcGenStat@ map at which we store the sum of stats over all
-- generations, or the single set of stats for non-genenerational GC models.
gcGenTot :: Gen
gcGenTot = -1
data GenStat = GenStat
{ -- Sum over all seqential and pararell GC invocations.
gcAll :: !Int
, -- Only parallel GCs. For GC models without stop-the-world par, always 0.
gcPar :: !Int
, gcElapsed :: !Timestamp
, gcMaxPause :: !Timestamp
}
emptyStatsAccum :: StatsAccum
emptyStatsAccum = StatsAccum
{ dallocTable = IM.empty
, dcopied = Nothing
, dmaxResidency = Nothing
, dmaxSlop = Nothing
, dmaxMemory = Nothing
, dGCTable = IM.empty
, dGCMain = Nothing
, dparMaxCopied = Nothing
, dparTotCopied = Nothing
, dmaxParNThreads = Nothing
, dsparkTable = IM.empty
}
-- | At the beginning of a program run, we know for sure several of the
-- stats start at zero:
zeroStatsAccum :: StatsAccum
zeroStatsAccum = emptyStatsAccum {
dcopied = Just 0,
dmaxResidency = Just 0,
dmaxSlop = Just 0,
dmaxMemory = Just 0,
dallocTable = -- a hack: we assume no more than 999 caps
IM.fromDistinctAscList $ zip [0..999] $ repeat (0, 0)
-- FIXME: but also, we should have a way to init to 0 for all caps.
}
defaultGC :: Timestamp -> RtsGC
defaultGC time = RtsGC
{ gcMode = ModeInit
, gcStartTime = time
, gcGenStat = IM.empty
}
emptyGenStat :: GenStat
emptyGenStat = GenStat
{ gcAll = 0
, gcPar = 0
, gcElapsed = 0
, gcMaxPause = 0
}
accumEvent :: StatsAccum -> CapEvent -> StatsAccum
accumEvent !statsAccum (CapEvent mcap ev) =
let -- For events that contain a counter with a running sum.
-- Eventually we'll subtract the last found
-- event from the first. Intervals beginning at time 0
-- are a special case, because morally the first event should have
-- value 0, but it may be absent, so we start with @Just (0, 0)@.
alterCounter n Nothing = Just (n, n)
alterCounter n (Just (_previous, first)) = Just (n, first)
-- For events that contain discrete increments. We assume the event
-- is emitted close to the end of the process it measures,
-- so we ignore the first found event, because most of the process
-- could have happened before the start of the current inverval.
-- This is consistent with @alterCounter@. For interval beginning
-- at time 0, we start with @Just 0@.
alterIncrement _ Nothing = Just 0
alterIncrement n (Just k) = Just (k + n)
-- For events that contain sampled values, where a max is sought.
alterMax n Nothing = Just n
alterMax n (Just k) | n > k = Just n
alterMax _ jk = jk
-- Scan events, updating summary data.
scan cap !sd@StatsAccum{..} Event{time, spec} =
let capGC = IM.findWithDefault (defaultGC time) cap dGCTable
in case spec of
-- TODO: check EventBlock elsewhere; define {map,fold}EventBlock
EventBlock{cap = bcap, block_events} ->
L.foldl' (scan bcap) sd block_events
HeapAllocated{allocBytes} ->
sd { dallocTable =
IM.alter (alterCounter allocBytes) cap dallocTable }
HeapLive{liveBytes} ->
sd { dmaxResidency = alterMax liveBytes dmaxResidency}
HeapSize{sizeBytes} ->
sd { dmaxMemory = alterMax sizeBytes dmaxMemory}
StartGC ->
assert (gcMode capGC `elem` [ModeInit, ModeEnd, ModeIdle]) $
let newGC = capGC { gcMode = ModeStart
, gcStartTime = time
}
-- TODO: Index with generations, not caps?
in sd { dGCTable = IM.insert cap newGC dGCTable }
GlobalSyncGC ->
-- All caps must be stopped. Those that take part in the GC
-- are in ModeInit or ModeStart, those that do not
-- are in ModeInit, ModeEnd or ModeIdle.
assert (L.all (notModeGHCEtc . gcMode) (IM.elems dGCTable)) $
sd { dGCTable = IM.mapWithKey setSync dGCTable }
where
notModeGHCEtc ModeGHC{} = False
notModeGHCEtc ModeSync{} = False
notModeGHCEtc _ = True
someInit = L.any ((== ModeInit) . gcMode) (IM.elems dGCTable)
setSync capKey dGC@RtsGC{gcGenStat}
| someInit =
-- If even one cap could possibly have started GC before
-- the start of the selected interval, skip the GC on all caps.
-- We don't verify the overwritten modes in this case.
-- TODO: we could be smarter and defer the decision to EndGC,
-- when we can deduce if the suspect caps take part in GC
-- or not at all.
dGC { gcMode = ModeInit }
| otherwise =
let totGC = IM.findWithDefault emptyGenStat gcGenTot gcGenStat
in case gcMode dGC of
-- Cap takes part in the GC (not known if seq or par).
-- Here is the moment where all caps taking place in the GC
-- are identified and we can aggregate all their data
-- at once (currently we just increment a counter for each).
-- The EndGC events can come much later for some caps and at
-- that time other caps are already inside their new GC.
ModeStart ->
dGC { gcMode = ModeSync cap
, gcGenStat =
if capKey == cap
then IM.insert gcGenTot
totGC{ gcAll = gcAll totGC + 1 }
gcGenStat
else gcGenStat
}
-- Cap is not in the GC. Mark it as idle to complete
-- the identification of caps that take part
-- in the current GC. Without overwritin the mode,
-- the cap could be processed later on as if
-- it took part in the GC, giving wrong results.
ModeEnd -> dGC { gcMode = ModeIdle }
ModeIdle -> dGC
-- Impossible.
ModeInit -> error "scanEvents: GlobalSyncGC ModeInit"
ModeSync{} -> error "scanEvents: GlobalSyncGC ModeSync"
ModeGHC{} -> error "scanEvents: GlobalSyncGC ModeGHC"
GCStatsGHC{..} ->
-- All caps must be stopped. Those that take part in the GC
-- are in ModeInit or ModeSync, those that do not
-- are in ModeInit or ModeIdle.
assert (L.all (notModeStartEtc . gcMode) (IM.elems dGCTable)) $
sd { dcopied = alterIncrement copied dcopied -- sum over caps
, dmaxSlop = alterMax slop dmaxSlop -- max over all caps
, dGCTable = IM.mapWithKey setParSeq dGCTable
, dparMaxCopied = alterIncrement parMaxCopied dparMaxCopied
, dparTotCopied = alterIncrement parTotCopied dparTotCopied
, dmaxParNThreads = alterMax parNThreads dmaxParNThreads
}
where
notModeStartEtc ModeStart = False
notModeStartEtc ModeGHC{} = False
notModeStartEtc ModeEnd = False
notModeStartEtc _ = True
someInit = L.any ((== ModeInit) . gcMode) (IM.elems dGCTable)
setParSeq capKey dGC@RtsGC{gcGenStat}
| someInit =
-- Just starting the selected interval, so skip the GC.
dGC
| otherwise =
let genGC = IM.findWithDefault emptyGenStat gen gcGenStat
totGC = IM.findWithDefault emptyGenStat gcGenTot gcGenStat
in case gcMode dGC of
-- Cap takes part in seq GC.
ModeSync capSync | parNThreads == 1 ->
assert (cap == capSync) $
dGC { gcMode = ModeGHC cap gen
, gcGenStat =
-- Already inserted into gcGenTot in GlobalSyncGC,
-- so only inserting into gen.
if capKey == cap
then IM.insert gen
genGC{ gcAll = gcAll genGC + 1 }
gcGenStat
else gcGenStat
}
-- Cap takes part in par GC.
ModeSync capSync ->
assert (cap == capSync) $
assert (parNThreads > 1) $
dGC { gcMode = ModeGHC cap gen
, gcGenStat =
if capKey == cap
then IM.insert gen
genGC{ gcAll = gcAll genGC + 1
, gcPar = gcPar genGC + 1
}
(IM.insert gcGenTot
-- Already incremented gcAll in SyncGC.
totGC{ gcPar = gcPar totGC + 1 }
gcGenStat)
else gcGenStat
}
-- Cap not in the current GC, leave it alone.
ModeIdle -> dGC
-- Impossible.
ModeInit -> error "scanEvents: GCStatsGHC ModeInit"
ModeStart -> error "scanEvents: GCStatsGHC ModeStart"
ModeGHC{} -> error "scanEvents: GCStatsGHC ModeGHC"
ModeEnd -> error "scanEvents: GCStatsGHC ModeEnd"
EndGC ->
assert (gcMode capGC `notElem` [ModeEnd, ModeIdle]) $
let endedGC = capGC { gcMode = ModeEnd }
duration = time - gcStartTime capGC
timeGC gen gstat =
let genGC =
IM.findWithDefault emptyGenStat gen (gcGenStat gstat)
newGenGC =
genGC { gcElapsed = gcElapsed genGC + duration
, gcMaxPause = max (gcMaxPause genGC) duration
}
in gstat { gcGenStat = IM.insert gen newGenGC
(gcGenStat gstat) }
timeGenTot = timeGC gcGenTot endedGC
updateMainCap mainCap _ dgm | mainCap /= cap = dgm
updateMainCap _ currentGen dgm =
-- We are at the EndGC event of the main cap of current GC.
-- The timings from this cap are the only that +RTS -s uses.
-- We will record them in the dGCMain field to be able
-- to display a look-alike of +RTS -s.
timeGC currentGen dgm
in case gcMode capGC of
-- We don't know the exact timing of this GC started before
-- the selected interval, so we skip it and clear its mode.
ModeInit -> sd { dGCTable = IM.insert cap endedGC dGCTable }
-- There is no GlobalSyncGC nor GCStatsGHC for this GC.
-- Consequently, we can't determine the main cap,
-- so skip it and and clear its mode.
ModeStart -> sd { dGCTable = IM.insert cap endedGC dGCTable }
-- There is no GCStatsGHC for this GC. Gather partial data.
ModeSync mainCap ->
let dgm = fromMaybe (defaultGC time) dGCMain
mainGenTot = updateMainCap mainCap gcGenTot dgm
in sd { dGCTable = IM.insert cap timeGenTot dGCTable
, dGCMain = Just mainGenTot
}
-- All is known, so we update the times.
ModeGHC mainCap gen ->
let newTime = timeGC gen timeGenTot
dgm = fromMaybe (defaultGC time) dGCMain
mainGenTot = updateMainCap mainCap gcGenTot dgm
newMain = updateMainCap mainCap gen mainGenTot
in sd { dGCTable = IM.insert cap newTime dGCTable
, dGCMain = Just newMain
}
ModeEnd -> error "scanEvents: EndGC ModeEnd"
ModeIdle -> error "scanEvents: EndGC ModeIdle"
SparkCounters crt dud ovf cnv fiz gcd _rem ->
-- We are guranteed the first spark counters event has all zeroes,
-- do we don't need to rig the counters for maximal interval.
let current = RtsSpark crt dud ovf cnv fiz gcd
in sd { dsparkTable =
IM.alter (alterCounter current) cap dsparkTable }
_ -> sd
in scan (fromJust mcap) statsAccum ev
threadscope-0.2.2/GUI/BookmarkView.hs 0000644 0000000 0000000 00000010441 12044651254 015565 0 ustar 00 0000000 0000000 module GUI.BookmarkView (
BookmarkView,
bookmarkViewNew,
BookmarkViewActions(..),
bookmarkViewGet,
bookmarkViewAdd,
bookmarkViewRemove,
bookmarkViewClear,
bookmarkViewSetLabel,
) where
import GHC.RTS.Events (Timestamp)
import Graphics.UI.Gtk
import Numeric
---------------------------------------------------------------------------
-- | Abstract bookmark view object.
--
data BookmarkView = BookmarkView {
bookmarkStore :: ListStore (Timestamp, String)
}
-- | The actions to take in response to TraceView events.
--
data BookmarkViewActions = BookmarkViewActions {
bookmarkViewAddBookmark :: IO (),
bookmarkViewRemoveBookmark :: Int -> IO (),
bookmarkViewGotoBookmark :: Timestamp -> IO (),
bookmarkViewEditLabel :: Int -> String -> IO ()
}
---------------------------------------------------------------------------
bookmarkViewAdd :: BookmarkView -> Timestamp -> String -> IO ()
bookmarkViewAdd BookmarkView{bookmarkStore} ts label = do
listStoreAppend bookmarkStore (ts, label)
return ()
bookmarkViewRemove :: BookmarkView -> Int -> IO ()
bookmarkViewRemove BookmarkView{bookmarkStore} n = do
listStoreRemove bookmarkStore n
return ()
bookmarkViewClear :: BookmarkView -> IO ()
bookmarkViewClear BookmarkView{bookmarkStore} =
listStoreClear bookmarkStore
bookmarkViewGet :: BookmarkView -> IO [(Timestamp, String)]
bookmarkViewGet BookmarkView{bookmarkStore} =
listStoreToList bookmarkStore
bookmarkViewSetLabel :: BookmarkView -> Int -> String -> IO ()
bookmarkViewSetLabel BookmarkView{bookmarkStore} n label = do
(ts,_) <- listStoreGetValue bookmarkStore n
listStoreSetValue bookmarkStore n (ts, label)
---------------------------------------------------------------------------
bookmarkViewNew :: Builder -> BookmarkViewActions -> IO BookmarkView
bookmarkViewNew builder BookmarkViewActions{..} = do
let getWidget cast name = builderGetObject builder cast name
---------------------------------------------------------------------------
bookmarkTreeView <- getWidget castToTreeView "bookmark_list"
bookmarkStore <- listStoreNew []
columnTs <- treeViewColumnNew
cellTs <- cellRendererTextNew
columnLabel <- treeViewColumnNew
cellLabel <- cellRendererTextNew
selection <- treeViewGetSelection bookmarkTreeView
treeViewColumnSetTitle columnTs "Time"
treeViewColumnSetTitle columnLabel "Label"
treeViewColumnPackStart columnTs cellTs False
treeViewColumnPackStart columnLabel cellLabel True
treeViewAppendColumn bookmarkTreeView columnTs
treeViewAppendColumn bookmarkTreeView columnLabel
treeViewSetModel bookmarkTreeView bookmarkStore
cellLayoutSetAttributes columnTs cellTs bookmarkStore $ \(ts,_) ->
[ cellText := showFFloat (Just 6) (fromIntegral ts / 1000000) "s" ]
cellLayoutSetAttributes columnLabel cellLabel bookmarkStore $ \(_,label) ->
[ cellText := label ]
---------------------------------------------------------------------------
addBookmarkButton <- getWidget castToToolButton "add_bookmark_button"
deleteBookmarkButton <- getWidget castToToolButton "delete_bookmark"
gotoBookmarkButton <- getWidget castToToolButton "goto_bookmark_button"
onToolButtonClicked addBookmarkButton $
bookmarkViewAddBookmark
onToolButtonClicked deleteBookmarkButton $ do
selected <- treeSelectionGetSelected selection
case selected of
Nothing -> return ()
Just iter ->
let pos = listStoreIterToIndex iter
in bookmarkViewRemoveBookmark pos
onToolButtonClicked gotoBookmarkButton $ do
selected <- treeSelectionGetSelected selection
case selected of
Nothing -> return ()
Just iter -> do
let pos = listStoreIterToIndex iter
(ts,_) <- listStoreGetValue bookmarkStore pos
bookmarkViewGotoBookmark ts
onRowActivated bookmarkTreeView $ \[pos] _ -> do
(ts, _) <- listStoreGetValue bookmarkStore pos
bookmarkViewGotoBookmark ts
set cellLabel [ cellTextEditable := True ]
on cellLabel edited $ \[pos] val -> do
bookmarkViewEditLabel pos val
---------------------------------------------------------------------------
return BookmarkView{..}
threadscope-0.2.2/GUI/MainWindow.hs 0000644 0000000 0000000 00000016651 12044651254 015252 0 ustar 00 0000000 0000000 module GUI.MainWindow (
MainWindow,
mainWindowNew,
MainWindowActions(..),
setFileLoaded,
setStatusMessage,
sidebarSetVisibility,
eventsSetVisibility,
) where
import Paths_threadscope
-- Imports for GTK
import Graphics.UI.Gtk as Gtk
import qualified System.Glib.GObject as Glib
-------------------------------------------------------------------------------
data MainWindow = MainWindow {
mainWindow :: Window,
sidebarBox,
eventsBox :: Widget,
statusBar :: Statusbar,
statusBarCxt :: ContextId
}
instance Glib.GObjectClass MainWindow where
toGObject = toGObject . mainWindow
unsafeCastGObject = error "cannot downcast to MainView type"
instance Gtk.ObjectClass MainWindow
instance Gtk.WidgetClass MainWindow
instance Gtk.ContainerClass MainWindow
instance Gtk.BinClass MainWindow
instance Gtk.WindowClass MainWindow
data MainWindowActions = MainWindowActions {
-- Menu actions
mainWinOpen :: IO (),
mainWinExport :: IO (),
mainWinQuit :: IO (),
mainWinViewSidebar :: Bool -> IO (),
mainWinViewEvents :: Bool -> IO (),
mainWinViewBW :: Bool -> IO (),
mainWinViewReload :: IO (),
mainWinWebsite :: IO (),
mainWinTutorial :: IO (),
mainWinAbout :: IO (),
-- Toolbar actions
mainWinJumpStart :: IO (),
mainWinJumpEnd :: IO (),
mainWinJumpCursor :: IO (),
mainWinJumpZoomIn :: IO (),
mainWinJumpZoomOut :: IO (),
mainWinJumpZoomFit :: IO (),
mainWinScrollLeft :: IO (),
mainWinScrollRight :: IO (),
mainWinDisplayLabels :: Bool -> IO ()
}
-------------------------------------------------------------------------------
setFileLoaded :: MainWindow -> Maybe FilePath -> IO ()
setFileLoaded mainWin Nothing =
set (mainWindow mainWin) [
windowTitle := "ThreadScope"
]
setFileLoaded mainWin (Just file) =
set (mainWindow mainWin) [
windowTitle := file ++ " - ThreadScope"
]
setStatusMessage :: MainWindow -> String -> IO ()
setStatusMessage mainWin msg = do
statusbarPop (statusBar mainWin) (statusBarCxt mainWin)
statusbarPush (statusBar mainWin) (statusBarCxt mainWin) (' ':msg)
return ()
sidebarSetVisibility :: MainWindow -> Bool -> IO ()
sidebarSetVisibility mainWin visible =
set (sidebarBox mainWin) [ widgetVisible := visible ]
eventsSetVisibility :: MainWindow -> Bool -> IO ()
eventsSetVisibility mainWin visible =
set (eventsBox mainWin) [ widgetVisible := visible ]
-------------------------------------------------------------------------------
mainWindowNew :: Builder -> MainWindowActions -> IO MainWindow
mainWindowNew builder actions = do
let getWidget cast name = builderGetObject builder cast name
mainWindow <- getWidget castToWindow "main_window"
statusBar <- getWidget castToStatusbar "statusbar"
sidebarBox <- getWidget castToWidget "sidebar"
eventsBox <- getWidget castToWidget "eventsbox"
bwToggle <- getWidget castToCheckMenuItem "black_and_white"
labModeToggle <- getWidget castToCheckMenuItem "view_labels_mode"
sidebarToggle <- getWidget castToCheckMenuItem "view_sidebar"
eventsToggle <- getWidget castToCheckMenuItem "view_events"
openMenuItem <- getWidget castToMenuItem "openMenuItem"
exportMenuItem <- getWidget castToMenuItem "exportMenuItem"
reloadMenuItem <- getWidget castToMenuItem "view_reload"
quitMenuItem <- getWidget castToMenuItem "quitMenuItem"
websiteMenuItem <- getWidget castToMenuItem "websiteMenuItem"
tutorialMenuItem <- getWidget castToMenuItem "tutorialMenuItem"
aboutMenuItem <- getWidget castToMenuItem "aboutMenuItem"
firstMenuItem <- getWidget castToMenuItem "move_first"
centreMenuItem <- getWidget castToMenuItem "move_centre"
lastMenuItem <- getWidget castToMenuItem "move_last"
zoomInMenuItem <- getWidget castToMenuItem "move_zoomin"
zoomOutMenuItem <- getWidget castToMenuItem "move_zoomout"
zoomFitMenuItem <- getWidget castToMenuItem "move_zoomfit"
openButton <- getWidget castToToolButton "cpus_open"
firstButton <- getWidget castToToolButton "cpus_first"
centreButton <- getWidget castToToolButton "cpus_centre"
lastButton <- getWidget castToToolButton "cpus_last"
zoomInButton <- getWidget castToToolButton "cpus_zoomin"
zoomOutButton <- getWidget castToToolButton "cpus_zoomout"
zoomFitButton <- getWidget castToToolButton "cpus_zoomfit"
--TODO: this is currently not used, but it'be nice if it were!
eventsTextEntry <- getWidget castToEntry "events_entry"
------------------------------------------------------------------------
-- Show everything
widgetShowAll mainWindow
widgetHide eventsTextEntry -- for now we hide it, see above.
------------------------------------------------------------------------
logoPath <- getDataFileName "threadscope.png"
windowSetIconFromFile mainWindow logoPath
------------------------------------------------------------------------
-- Status bar functionality
statusBarCxt <- statusbarGetContextId statusBar "file"
statusbarPush statusBar statusBarCxt "No eventlog loaded."
------------------------------------------------------------------------
-- Bind all the events
-- Menus
on openMenuItem menuItemActivate $ mainWinOpen actions
on exportMenuItem menuItemActivate $ mainWinExport actions
on quitMenuItem menuItemActivate $ mainWinQuit actions
on mainWindow objectDestroy $ mainWinQuit actions
on sidebarToggle checkMenuItemToggled $ checkMenuItemGetActive sidebarToggle
>>= mainWinViewSidebar actions
on eventsToggle checkMenuItemToggled $ checkMenuItemGetActive eventsToggle
>>= mainWinViewEvents actions
on bwToggle checkMenuItemToggled $ checkMenuItemGetActive bwToggle
>>= mainWinViewBW actions
on labModeToggle checkMenuItemToggled $ checkMenuItemGetActive labModeToggle
>>= mainWinDisplayLabels actions
on reloadMenuItem menuItemActivate $ mainWinViewReload actions
on websiteMenuItem menuItemActivate $ mainWinWebsite actions
on tutorialMenuItem menuItemActivate $ mainWinTutorial actions
on aboutMenuItem menuItemActivate $ mainWinAbout actions
on firstMenuItem menuItemActivate $ mainWinJumpStart actions
on centreMenuItem menuItemActivate $ mainWinJumpCursor actions
on lastMenuItem menuItemActivate $ mainWinJumpEnd actions
on zoomInMenuItem menuItemActivate $ mainWinJumpZoomIn actions
on zoomOutMenuItem menuItemActivate $ mainWinJumpZoomOut actions
on zoomFitMenuItem menuItemActivate $ mainWinJumpZoomFit actions
-- Toolbar
onToolButtonClicked openButton $ mainWinOpen actions
onToolButtonClicked firstButton $ mainWinJumpStart actions
onToolButtonClicked centreButton $ mainWinJumpCursor actions
onToolButtonClicked lastButton $ mainWinJumpEnd actions
onToolButtonClicked zoomInButton $ mainWinJumpZoomIn actions
onToolButtonClicked zoomOutButton $ mainWinJumpZoomOut actions
onToolButtonClicked zoomFitButton $ mainWinJumpZoomFit actions
return MainWindow {..}
threadscope-0.2.2/GUI/TraceView.hs 0000644 0000000 0000000 00000016162 12044651254 015064 0 ustar 00 0000000 0000000 module GUI.TraceView (
TraceView,
traceViewNew,
TraceViewActions(..),
traceViewSetHECs,
traceViewGetTraces,
) where
import Events.HECs
import GUI.Types
import Graphics.UI.Gtk
import Data.Tree
-- | Abstract trace view object.
--
data TraceView = TraceView {
tracesStore :: TreeStore (Trace, Visibility)
}
data Visibility = Visible | Hidden | MixedVisibility
deriving Eq
-- | The actions to take in response to TraceView events.
--
data TraceViewActions = TraceViewActions {
traceViewTracesChanged :: [Trace] -> IO ()
}
traceViewNew :: Builder -> TraceViewActions -> IO TraceView
traceViewNew builder actions = do
tracesTreeView <- builderGetObject builder castToTreeView "traces_tree"
tracesStore <- treeStoreNew []
traceColumn <- treeViewColumnNew
textcell <- cellRendererTextNew
togglecell <- cellRendererToggleNew
let traceview = TraceView {..}
treeViewColumnPackStart traceColumn textcell True
treeViewColumnPackStart traceColumn togglecell False
treeViewAppendColumn tracesTreeView traceColumn
treeViewSetModel tracesTreeView tracesStore
cellLayoutSetAttributes traceColumn textcell tracesStore $ \(tr, _) ->
[ cellText := renderTrace tr ]
cellLayoutSetAttributes traceColumn togglecell tracesStore $ \(_, vis) ->
[ cellToggleActive := vis == Visible
, cellToggleInconsistent := vis == MixedVisibility ]
on togglecell cellToggled $ \str -> do
let path = stringToTreePath str
Node (trace, visibility) subtrees <- treeStoreGetTree tracesStore path
let visibility' = invertVisibility visibility
treeStoreSetValue tracesStore path (trace, visibility')
updateChildren tracesStore path subtrees visibility'
updateParents tracesStore (init path)
traceViewTracesChanged actions =<< traceViewGetTraces traceview
return traceview
where
renderTrace (TraceHEC hec) = "HEC " ++ show hec
renderTrace (TraceInstantHEC hec) = "HEC " ++ show hec
renderTrace (TraceCreationHEC hec) = "HEC " ++ show hec
renderTrace (TraceConversionHEC hec) = "HEC " ++ show hec
renderTrace (TracePoolHEC hec) = "HEC " ++ show hec
renderTrace (TraceHistogram) = "Spark Histogram"
renderTrace (TraceGroup label) = label
renderTrace (TraceActivity) = "Activity Profile"
updateChildren tracesStore path subtrees visibility' =
sequence_
[ do treeStoreSetValue tracesStore path' (trace, visibility')
updateChildren tracesStore path' subtrees' visibility'
| (Node (trace, _) subtrees', n) <- zip subtrees [0..]
, let path' = path ++ [n] ]
updateParents :: TreeStore (Trace, Visibility) -> TreePath -> IO ()
updateParents _ [] = return ()
updateParents tracesStore path = do
Node (trace, _) subtrees <- treeStoreGetTree tracesStore path
let visibility = accumVisibility [ vis | subtree <- subtrees
, (_, vis) <- flatten subtree ]
treeStoreSetValue tracesStore path (trace, visibility)
updateParents tracesStore (init path)
invertVisibility Hidden = Visible
invertVisibility _ = Hidden
accumVisibility = foldr1 (\a b -> if a == b then a else MixedVisibility)
-- Find the HEC traces in the treeStore and replace them
traceViewSetHECs :: TraceView -> HECs -> IO ()
traceViewSetHECs TraceView{tracesStore} hecs = do
treeStoreClear tracesStore
-- for testing only (e.g., to compare with histogram of data from interval
-- or to compare visually with other traces):
-- treeStoreInsert tracesStore [] 0 (TraceHistogram, Visible)
go 0
treeStoreInsert tracesStore [] 0 (TraceActivity, Visible)
where
newT = Node { rootLabel = (TraceGroup "HEC Traces", Visible),
subForest = [ Node { rootLabel = (TraceHEC k, Visible),
subForest = [] }
| k <- [ 0 .. hecCount hecs - 1 ] ] }
newI = Node { rootLabel = (TraceGroup "Instant Events", Hidden),
subForest = [ Node { rootLabel = (TraceInstantHEC k, Hidden),
subForest = [] }
| k <- [ 0 .. hecCount hecs - 1 ] ] }
nCre = Node { rootLabel = (TraceGroup "Spark Creation", Hidden),
subForest = [ Node { rootLabel = (TraceCreationHEC k, Hidden),
subForest = [] }
| k <- [ 0 .. hecCount hecs - 1 ] ] }
nCon = Node { rootLabel = (TraceGroup "Spark Conversion", Hidden),
subForest = [ Node { rootLabel = (TraceConversionHEC k, Hidden),
subForest = [] }
| k <- [ 0 .. hecCount hecs - 1 ] ] }
nPoo = Node { rootLabel = (TraceGroup "Spark Pool", Hidden),
subForest = [ Node { rootLabel = (TracePoolHEC k, Hidden),
subForest = [] }
| k <- [ 0 .. hecCount hecs - 1 ] ] }
go n = do
m <- treeStoreLookup tracesStore [n]
case m of
Nothing -> do
treeStoreInsertTree tracesStore [] 0 nPoo
treeStoreInsertTree tracesStore [] 0 nCon
treeStoreInsertTree tracesStore [] 0 nCre
treeStoreInsertTree tracesStore [] 0 newI
treeStoreInsertTree tracesStore [] 0 newT
Just t ->
case t of
Node { rootLabel = (TraceGroup "HEC Traces", _) } -> do
treeStoreRemove tracesStore [n]
treeStoreInsertTree tracesStore [] n newT
go (n+1)
Node { rootLabel = (TraceGroup "HEC Instant Events", _) } -> do
treeStoreRemove tracesStore [n]
treeStoreInsertTree tracesStore [] n newI
go (n+1)
Node { rootLabel = (TraceGroup "Spark Creation", _) } -> do
treeStoreRemove tracesStore [n]
treeStoreInsertTree tracesStore [] n nCre
go (n+1)
Node { rootLabel = (TraceGroup "Spark Conversion", _) } -> do
treeStoreRemove tracesStore [n]
treeStoreInsertTree tracesStore [] n nCon
go (n+1)
Node { rootLabel = (TraceGroup "Spark Pool", _) } -> do
treeStoreRemove tracesStore [n]
treeStoreInsertTree tracesStore [] n nPoo
go (n+1)
Node { rootLabel = (TraceActivity, _) } -> do
treeStoreRemove tracesStore [n]
go (n+1)
_ ->
go (n+1)
traceViewGetTraces :: TraceView -> IO [Trace]
traceViewGetTraces TraceView{tracesStore} = do
f <- getTracesStoreContents tracesStore
return [ t | (t, Visible) <- concatMap flatten f, notGroup t ]
where
notGroup (TraceGroup _) = False
notGroup _ = True
getTracesStoreContents :: TreeStore a -> IO (Forest a)
getTracesStoreContents tracesStore = go 0
where
go !n = do
m <- treeStoreLookup tracesStore [n]
case m of
Nothing -> return []
Just t -> do
ts <- go (n+1)
return (t:ts)
threadscope-0.2.2/GUI/KeyView.hs 0000644 0000000 0000000 00000015217 12044651254 014556 0 ustar 00 0000000 0000000 module GUI.KeyView (
KeyView,
keyViewNew,
) where
import GUI.ViewerColours
import GUI.Timeline.Render.Constants
import Graphics.UI.Gtk
import qualified Graphics.Rendering.Cairo as C
---------------------------------------------------------------------------
-- | Abstract key view object.
--
data KeyView = KeyView
---------------------------------------------------------------------------
keyViewNew :: Builder -> IO KeyView
keyViewNew builder = do
keyTreeView <- builderGetObject builder castToTreeView "key_list"
dw <- widgetGetDrawWindow keyTreeView
keyEntries <- createKeyEntries dw keyData
keyStore <- listStoreNew keyEntries
keyColumn <- treeViewColumnNew
imageCell <- cellRendererPixbufNew
labelCell <- cellRendererTextNew
treeViewColumnPackStart keyColumn imageCell False
treeViewColumnPackStart keyColumn labelCell True
treeViewAppendColumn keyTreeView keyColumn
selection <- treeViewGetSelection keyTreeView
treeSelectionSetMode selection SelectionNone
let tooltipColumn = makeColumnIdString 0
customStoreSetColumn keyStore tooltipColumn (\(_,tooltip,_) -> tooltip)
treeViewSetModel keyTreeView keyStore
set keyTreeView [ treeViewTooltipColumn := tooltipColumn ]
cellLayoutSetAttributes keyColumn imageCell keyStore $ \(_,_,img) ->
[ cellPixbuf := img ]
cellLayoutSetAttributes keyColumn labelCell keyStore $ \(label,_,_) ->
[ cellText := label ]
---------------------------------------------------------------------------
return KeyView
-------------------------------------------------------------------------------
data KeyStyle = KDuration | KEvent | KEventAndGraph
keyData :: [(String, KeyStyle, Color, String)]
keyData =
[ ("running", KDuration, runningColour,
"Indicates a period of time spent running Haskell code (not GC, not blocked/idle)")
, ("GC", KDuration, gcColour,
"Indicates a period of time spent by the RTS performing garbage collection (GC)")
, ("create thread", KEvent, createThreadColour,
"Indicates a new Haskell thread has been created")
, ("seq GC req", KEvent, seqGCReqColour,
"Indicates a HEC has requested to start a sequential GC")
, ("par GC req", KEvent, parGCReqColour,
"Indicates a HEC has requested to start a parallel GC")
, ("migrate thread", KEvent, migrateThreadColour,
"Indicates a Haskell thread has been moved from one HEC to another")
, ("thread wakeup", KEvent, threadWakeupColour,
"Indicates that a thread that was previously blocked (e.g. I/O, MVar etc) is now ready to run")
, ("shutdown", KEvent, shutdownColour,
"Indicates a HEC is terminating")
, ("user message", KEvent, userMessageColour,
"Indicates a message generated from Haskell code (via traceEvent)")
, ("perf counter", KEvent, createdConvertedColour,
"Indicates an update of a perf counter")
, ("perf tracepoint", KEvent, shutdownColour,
"Indicates that a perf tracepoint was reached")
, ("create spark", KEventAndGraph, createdConvertedColour,
"As an event it indicates a use of `par` resulted in a spark being " ++
"created (and added to the spark pool). In the spark creation " ++
"graph the coloured area represents the number of sparks created.")
, ("dud spark", KEventAndGraph, fizzledDudsColour,
"As an event it indicates a use of `par` resulted in the spark being " ++
"discarded because it was a 'dud' (already evaluated). In the spark " ++
"creation graph the coloured area represents the number of dud sparks.")
, ("overflowed spark",KEventAndGraph, overflowedColour,
"As an event it indicates a use of `par` resulted in the spark being " ++
"discarded because the spark pool was full. In the spark creation " ++
"graph the coloured area represents the number of overflowed sparks.")
, ("run spark", KEventAndGraph, createdConvertedColour,
"As an event it indicates a spark has started to be run/evaluated. " ++
"In the spark conversion graph the coloured area represents the number " ++
"of sparks run.")
, ("fizzled spark", KEventAndGraph, fizzledDudsColour,
"As an event it indicates a spark has 'fizzled', meaning it has been " ++
"discovered that the spark's thunk was evaluated by some other thread. " ++
"In the spark conversion graph the coloured area represents the number " ++
"of sparks that have fizzled.")
, ("GCed spark", KEventAndGraph, gcColour,
"As an event it indicates a spark has been GC'd, meaning it has been " ++
"discovered that the spark's thunk was no longer needed anywhere. " ++
"In the spark conversion graph the coloured area represents the number " ++
"of sparks that were GC'd.")
]
createKeyEntries :: DrawableClass dw
=> dw
-> [(String, KeyStyle, Color,String)]
-> IO [(String, String, Pixbuf)]
createKeyEntries similar entries =
sequence
[ do pixbuf <- renderToPixbuf similar (50, hecBarHeight) $ do
C.setSourceRGB 1 1 1
C.paint
renderKeyIcon style colour
return (label, tooltip, pixbuf)
| (label, style, colour, tooltip) <- entries ]
renderKeyIcon :: KeyStyle -> Color -> C.Render ()
renderKeyIcon KDuration keyColour = do
setSourceRGBAhex keyColour 1.0
let x = fromIntegral ox
C.rectangle (x - 2) 5 38 (fromIntegral (hecBarHeight `div` 2))
C.fill
renderKeyIcon KEvent keyColour = renderKEvent keyColour
renderKeyIcon KEventAndGraph keyColour = do
renderKEvent keyColour
-- An icon roughly repreenting a jagedy graph.
let x = fromIntegral ox
y = fromIntegral hecBarHeight
C.moveTo (2*x) (y - 2)
C.relLineTo 3 (-6)
C.relLineTo 3 0
C.relLineTo 3 3
C.relLineTo 5 1
C.relLineTo 1 (-(y - 4))
C.relLineTo 2 (y - 4)
C.relLineTo 1 (-(y - 4))
C.relLineTo 2 (y - 4)
C.lineTo (2*x+20) (y - 2)
C.fill
setSourceRGBAhex black 1.0
C.setLineWidth 1.0
C.moveTo (2*x-4) (y - 2.5)
C.lineTo (2*x+24) (y - 2.5)
C.stroke
renderKEvent :: Color -> C.Render ()
renderKEvent keyColour = do
setSourceRGBAhex keyColour 1.0
C.setLineWidth 3.0
let x = fromIntegral ox
C.moveTo x 0
C.relLineTo 0 25
C.stroke
renderToPixbuf :: DrawableClass dw => dw -> (Int, Int) -> C.Render ()
-> IO Pixbuf
renderToPixbuf similar (w, h) draw = do
pixmap <- pixmapNew (Just similar) w h Nothing
renderWithDrawable pixmap draw
Just pixbuf <- pixbufGetFromDrawable pixmap (Rectangle 0 0 w h)
return pixbuf
-------------------------------------------------------------------------------
threadscope-0.2.2/GUI/Histogram.hs 0000644 0000000 0000000 00000010776 12044651254 015135 0 ustar 00 0000000 0000000 module GUI.Histogram (
HistogramView,
histogramViewNew,
histogramViewSetHECs,
histogramViewSetInterval,
) where
import Events.HECs
import GUI.Timeline.Render (renderTraces, renderYScaleArea)
import GUI.Timeline.Render.Constants
import GUI.Types
import Graphics.UI.Gtk
import qualified Graphics.Rendering.Cairo as C
import qualified GUI.GtkExtras as GtkExt
import Data.IORef
data HistogramView =
HistogramView
{ hecsIORef :: IORef (Maybe HECs)
, mintervalIORef :: IORef (Maybe Interval)
, histogramDrawingArea :: DrawingArea
, histogramYScaleArea :: DrawingArea
}
histogramViewSetHECs :: HistogramView -> Maybe HECs -> IO ()
histogramViewSetHECs HistogramView{..} mhecs = do
writeIORef hecsIORef mhecs
writeIORef mintervalIORef Nothing -- the old interval may make no sense
widgetQueueDraw histogramDrawingArea
widgetQueueDraw histogramYScaleArea
histogramViewSetInterval :: HistogramView -> Maybe Interval -> IO ()
histogramViewSetInterval HistogramView{..} minterval = do
writeIORef mintervalIORef minterval
widgetQueueDraw histogramDrawingArea
widgetQueueDraw histogramYScaleArea
histogramViewNew :: Builder -> IO HistogramView
histogramViewNew builder = do
let getWidget cast = builderGetObject builder cast
histogramDrawingArea <- getWidget castToDrawingArea "histogram_drawingarea"
histogramYScaleArea <- getWidget castToDrawingArea "timeline_yscale_area2"
timelineXScaleArea <- getWidget castToDrawingArea "timeline_xscale_area"
-- HACK: layoutSetAttributes does not work for \mu, so let's work around
fd <- fontDescriptionNew
fontDescriptionSetSize fd 8
fontDescriptionSetFamily fd "sans serif"
widgetModifyFont histogramYScaleArea (Just fd)
(_, xh) <- widgetGetSize timelineXScaleArea
let xScaleAreaHeight = fromIntegral xh
traces = [TraceHistogram]
paramsHist (w, h) minterval = ViewParameters
{ width = w
, height = h
, viewTraces = traces
, hadjValue = 0
, scaleValue = 1
, maxSpkValue = undefined
, detail = undefined
, bwMode = undefined
, labelsMode = False
, histogramHeight = h - histXScaleHeight
, minterval = minterval
, xScaleAreaHeight = xScaleAreaHeight
}
hecsIORef <- newIORef Nothing
mintervalIORef <- newIORef Nothing
pangoCtx <- widgetGetPangoContext histogramDrawingArea
style <- get histogramDrawingArea widgetStyle
layout <- layoutEmpty pangoCtx
layoutSetMarkup layout $ "No detailed spark events in this eventlog.\n"
++ "Re-run with +RTS -lf to generate them."
-- Program the callback for the capability drawingArea
on histogramDrawingArea exposeEvent $
C.liftIO $ do
maybeEventArray <- readIORef hecsIORef
win <- widgetGetDrawWindow histogramDrawingArea
(w, windowHeight) <- widgetGetSize histogramDrawingArea
case maybeEventArray of
Nothing -> return False
Just hecs
| null (durHistogram hecs) -> do
GtkExt.stylePaintLayout
style win
StateNormal True
(Rectangle 0 0 w windowHeight)
histogramDrawingArea ""
4 20
layout
return True
| otherwise -> do
minterval <- readIORef mintervalIORef
if windowHeight < 80
then return False
else do
let size = (w, windowHeight - firstTraceY)
params = paramsHist size minterval
rect = Rectangle 0 0 w (snd size)
renderWithDrawable win $
renderTraces params hecs rect
return True
-- Redrawing histogramYScaleArea
histogramYScaleArea `onExpose` \_ -> do
maybeEventArray <- readIORef hecsIORef
case maybeEventArray of
Nothing -> return False
Just hecs
| null (durHistogram hecs) -> return False
| otherwise -> do
win <- widgetGetDrawWindow histogramYScaleArea
minterval <- readIORef mintervalIORef
(_, windowHeight) <- widgetGetSize histogramYScaleArea
if windowHeight < 80
then return False
else do
let size = (undefined, windowHeight - firstTraceY)
params = paramsHist size minterval
renderWithDrawable win $
renderYScaleArea params hecs histogramYScaleArea
return True
return HistogramView{..}
threadscope-0.2.2/GUI/ConcurrencyControl.hs 0000644 0000000 0000000 00000004230 12044651254 017017 0 ustar 00 0000000 0000000
module GUI.ConcurrencyControl (
ConcurrencyControl,
start,
fullSpeed,
) where
import qualified System.Glib.MainLoop as Glib
import qualified Control.Concurrent as Concurrent
import qualified Control.Exception as Exception
import Control.Concurrent.MVar
newtype ConcurrencyControl = ConcurrencyControl (MVar (Int, Glib.HandlerId))
-- | Setup cooperative thread scheduling with Gtk+.
--
start :: IO ConcurrencyControl
start = do
handlerId <- normalScheduling
return . ConcurrencyControl =<< newMVar (0, handlerId)
-- | Run an expensive action that needs to use all the available CPU power.
--
-- The normal cooperative GUI thread scheduling does not work so well in this
-- case so we use an alternative technique. We can't use this one all the time
-- however or we'd hog the CPU even when idle.
--
fullSpeed :: ConcurrencyControl -> IO a -> IO a
fullSpeed (ConcurrencyControl handlerRef) =
Exception.bracket_ begin end
where
-- remove the normal scheduling handler and put in the full speed one
begin = do
(count, handlerId) <- takeMVar handlerRef
if count == 0
-- nobody else is running fullSpeed
then do Glib.timeoutRemove handlerId
handlerId' <- fullSpeedScheduling
putMVar handlerRef (1, handlerId')
-- we're already running fullSpeed, just inc the count
else do putMVar handlerRef (count+1, handlerId)
-- reinstate the normal scheduling
end = do
(count, handlerId) <- takeMVar handlerRef
if count == 1
-- just us running fullSpeed so we clean up
then do Glib.timeoutRemove handlerId
handlerId' <- normalScheduling
putMVar handlerRef (0, handlerId')
-- someone else running fullSpeed, they're responsible for stopping
else do putMVar handlerRef (count-1, handlerId)
normalScheduling :: IO Glib.HandlerId
normalScheduling =
Glib.timeoutAddFull
(Concurrent.yield >> return True)
Glib.priorityDefaultIdle 50
--50ms, ie 20 times a second.
fullSpeedScheduling :: IO Glib.HandlerId
fullSpeedScheduling =
Glib.idleAdd
(Concurrent.yield >> return True)
Glib.priorityDefaultIdle
threadscope-0.2.2/GUI/Types.hs 0000644 0000000 0000000 00000001671 12044651254 014276 0 ustar 00 0000000 0000000 module GUI.Types (
ViewParameters(..),
Trace(..),
Timestamp,
Interval,
) where
import GHC.RTS.Events
-----------------------------------------------------------------------------
data Trace
= TraceHEC Int
| TraceInstantHEC Int
| TraceCreationHEC Int
| TraceConversionHEC Int
| TracePoolHEC Int
| TraceHistogram
| TraceGroup String
| TraceActivity
-- more later ...
-- | TraceThread ThreadId
deriving Eq
type Interval = (Timestamp, Timestamp)
-- the parameters for a timeline render; used to figure out whether
-- we're drawing the same thing twice.
data ViewParameters = ViewParameters {
width, height :: Int,
viewTraces :: [Trace],
hadjValue :: Double,
scaleValue :: Double,
maxSpkValue :: Double,
detail :: Int,
bwMode, labelsMode :: Bool,
histogramHeight :: Int,
minterval :: Maybe Interval,
xScaleAreaHeight :: Int
}
deriving Eq
threadscope-0.2.2/GUI/SaveAs.hs 0000644 0000000 0000000 00000005015 12044651254 014350 0 ustar 00 0000000 0000000 module GUI.SaveAs (saveAsPDF, saveAsPNG) where
-- Imports for ThreadScope
import GUI.Timeline.Render (renderTraces, renderYScaleArea)
import GUI.Timeline.Render.Constants
import GUI.Timeline.Ticks (renderXScaleArea)
import GUI.Types
import Events.HECs
-- Imports for GTK
import Graphics.UI.Gtk
import Graphics.Rendering.Cairo
saveAs :: HECs -> ViewParameters -> Double -> DrawingArea
-> (Int, Int, Render ())
saveAs hecs params' @ViewParameters{xScaleAreaHeight, width,
height = oldHeight {-, histogramHeight-}}
yScaleAreaWidth yScaleArea =
let histTotalHeight = histXScaleHeight -- + histogramHeight
params@ViewParameters{height} =
params'{ viewTraces = viewTraces params' -- ++ [TraceHistogram]
, height = oldHeight + histTotalHeight + tracePad
}
w = ceiling yScaleAreaWidth + width
h = xScaleAreaHeight + height
drawTraces = renderTraces params hecs (Rectangle 0 0 width height)
drawXScale = renderXScaleArea params hecs
drawYScale = renderYScaleArea params hecs yScaleArea
-- Functions renderTraces and renderXScaleArea draw to the left of 0
-- which is not seen in the normal mode, but would be seen in export,
-- so it has to be cleared before renderYScaleArea is written on top:
clearLeftArea = do
rectangle 0 0 yScaleAreaWidth (fromIntegral h)
op <- getOperator
setOperator OperatorClear
fill
setOperator op
drawAll = do
translate yScaleAreaWidth (fromIntegral xScaleAreaHeight)
drawTraces
translate 0 (- fromIntegral xScaleAreaHeight)
drawXScale
translate (-yScaleAreaWidth) 0
clearLeftArea
translate 0 (fromIntegral xScaleAreaHeight)
drawYScale
in (w, h, drawAll)
saveAsPDF :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO ()
saveAsPDF filename hecs params yScaleArea = do
(xoffset, _) <- liftIO $ widgetGetSize yScaleArea
let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea
withPDFSurface filename (fromIntegral w') (fromIntegral h') $ \surface ->
renderWith surface drawAll
saveAsPNG :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO ()
saveAsPNG filename hecs params yScaleArea = do
(xoffset, _) <- liftIO $ widgetGetSize yScaleArea
let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea
withImageSurface FormatARGB32 w' h' $ \surface -> do
renderWith surface drawAll
surfaceWriteToPNG surface filename
threadscope-0.2.2/GUI/ViewerColours.hs 0000644 0000000 0000000 00000005733 12044651254 016005 0 ustar 00 0000000 0000000 -------------------------------------------------------------------------------
--- $Id: ViewerColours.hs#2 2009/07/18 22:48:30 REDMOND\\satnams $
--- $Source: //depot/satnams/haskell/ThreadScope/ViewerColours.hs $
-------------------------------------------------------------------------------
module GUI.ViewerColours (Color, module GUI.ViewerColours) where
import Graphics.UI.Gtk
import Graphics.Rendering.Cairo
-------------------------------------------------------------------------------
-- Colours
runningColour :: Color
runningColour = darkGreen
gcColour :: Color
gcColour = orange
gcStartColour, gcWorkColour, gcIdleColour, gcEndColour :: Color
gcStartColour = orange
gcWorkColour = orange
gcIdleColour = white
gcEndColour = orange
createThreadColour :: Color
createThreadColour = lightBlue
seqGCReqColour :: Color
seqGCReqColour = cyan
parGCReqColour :: Color
parGCReqColour = darkBlue
migrateThreadColour :: Color
migrateThreadColour = darkRed
threadWakeupColour :: Color
threadWakeupColour = green
shutdownColour :: Color
shutdownColour = darkBrown
labelTextColour :: Color
labelTextColour = white
bookmarkColour :: Color
bookmarkColour = Color 0xff00 0x0000 0xff00 -- pinkish
fizzledDudsColour, createdConvertedColour, overflowedColour :: Color
fizzledDudsColour = grey
createdConvertedColour = darkGreen
overflowedColour = red
userMessageColour :: Color
userMessageColour = darkRed
outerPercentilesColour :: Color
outerPercentilesColour = lightGrey
-------------------------------------------------------------------------------
black :: Color
black = Color 0 0 0
grey :: Color
grey = Color 0x8000 0x8000 0x8000
lightGrey :: Color
lightGrey = Color 0xD000 0xD000 0xD000
gtkBorderGrey :: Color
gtkBorderGrey = Color 0xF200 0xF100 0xF000
red :: Color
red = Color 0xFFFF 0 0
green :: Color
green = Color 0 0xFFFF 0
darkGreen :: Color
darkGreen = Color 0x0000 0x6600 0x0000
blue :: Color
blue = Color 0 0 0xFFFF
cyan :: Color
cyan = Color 0 0xFFFF 0xFFFF
magenta :: Color
magenta = Color 0xFFFF 0 0xFFFF
lightBlue :: Color
lightBlue = Color 0x6600 0x9900 0xFF00
darkBlue :: Color
darkBlue = Color 0 0 0xBB00
purple :: Color
purple = Color 0x9900 0x0000 0xcc00
darkPurple :: Color
darkPurple = Color 0x6600 0 0x6600
darkRed :: Color
darkRed = Color 0xcc00 0x0000 0x0000
orange :: Color
orange = Color 0xE000 0x7000 0x0000 -- orange
profileBackground :: Color
profileBackground = Color 0xFFFF 0xFFFF 0xFFFF
tickColour :: Color
tickColour = Color 0x3333 0x3333 0xFFFF
darkBrown :: Color
darkBrown = Color 0x6600 0 0
yellow :: Color
yellow = Color 0xff00 0xff00 0x3300
white :: Color
white = Color 0xffff 0xffff 0xffff
-------------------------------------------------------------------------------
setSourceRGBAhex :: Color -> Double -> Render ()
setSourceRGBAhex (Color r g b) t
= setSourceRGBA (fromIntegral r/0xFFFF) (fromIntegral g/0xFFFF)
(fromIntegral b/0xFFFF) t
-------------------------------------------------------------------------------
threadscope-0.2.2/GUI/Main.hs 0000644 0000000 0000000 00000036524 12044651254 014063 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
module GUI.Main (runGUI) where
-- Imports for GTK
import qualified Graphics.UI.Gtk as Gtk
import System.Glib.GError (failOnGError)
-- Imports from Haskell library
import Text.Printf
import Control.Monad
#ifndef mingw32_HOST_OS
import System.Posix
#endif
import Control.Concurrent
import qualified Control.Concurrent.Chan as Chan
import Control.Exception
import Prelude hiding (catch)
import Data.Array
import Data.Maybe
import Paths_threadscope
-- Imports for ThreadScope
import qualified GUI.MainWindow as MainWindow
import GUI.Types
import Events.HECs hiding (Event)
import GUI.Dialogs
import Events.ReadEvents
import GUI.EventsView
import GUI.SummaryView
import GUI.StartupInfoView
import GUI.Histogram
import GUI.Timeline
import GUI.TraceView
import GUI.BookmarkView
import GUI.KeyView
import GUI.SaveAs
import qualified GUI.ConcurrencyControl as ConcurrencyControl
import qualified GUI.ProgressView as ProgressView
import qualified GUI.GtkExtras as GtkExtras
-------------------------------------------------------------------------------
data UIEnv = UIEnv {
mainWin :: MainWindow.MainWindow,
eventsView :: EventsView,
startupView :: StartupInfoView,
summaryView :: SummaryView,
histogramView :: HistogramView,
timelineWin :: TimelineView,
traceView :: TraceView,
bookmarkView :: BookmarkView,
keyView :: KeyView,
eventQueue :: Chan Event,
concCtl :: ConcurrencyControl.ConcurrencyControl
}
data EventlogState
= NoEventlogLoaded
| EventlogLoaded {
mfilename :: Maybe FilePath, --test traces have no filepath
hecs :: HECs,
selection :: TimeSelection,
cursorPos :: Int
}
postEvent :: Chan Event -> Event -> IO ()
postEvent = Chan.writeChan
getEvent :: Chan Event -> IO Event
getEvent = Chan.readChan
data Event
= EventOpenDialog
| EventExportDialog
| EventLaunchWebsite
| EventLaunchTutorial
| EventAboutDialog
| EventQuit
| EventFileLoad FilePath
| EventTestLoad String
| EventFileReload
| EventFileExport FilePath FileExportFormat
-- | EventStateClear
| EventSetState HECs (Maybe FilePath) String Int Double
| EventShowSidebar Bool
| EventShowEvents Bool
| EventTimelineJumpStart
| EventTimelineJumpEnd
| EventTimelineJumpCursor
| EventTimelineScrollLeft
| EventTimelineScrollRight
| EventTimelineZoomIn
| EventTimelineZoomOut
| EventTimelineZoomToFit
| EventTimelineLabelsMode Bool
| EventTimelineShowBW Bool
| EventCursorChangedIndex Int
| EventCursorChangedSelection TimeSelection
| EventTracesChanged [Trace]
| EventBookmarkAdd
| EventBookmarkRemove Int
| EventBookmarkEdit Int String
| EventUserError String SomeException
-- can add more specific ones if necessary
constructUI :: IO UIEnv
constructUI = failOnGError $ do
builder <- Gtk.builderNew
Gtk.builderAddFromFile builder =<< getDataFileName "threadscope.ui"
eventQueue <- Chan.newChan
let post = postEvent eventQueue
mainWin <- MainWindow.mainWindowNew builder MainWindow.MainWindowActions {
mainWinOpen = post EventOpenDialog,
mainWinExport = post EventExportDialog,
mainWinQuit = post EventQuit,
mainWinViewSidebar = post . EventShowSidebar,
mainWinViewEvents = post . EventShowEvents,
mainWinViewReload = post EventFileReload,
mainWinWebsite = post EventLaunchWebsite,
mainWinTutorial = post EventLaunchTutorial,
mainWinAbout = post EventAboutDialog,
mainWinJumpStart = post EventTimelineJumpStart,
mainWinJumpEnd = post EventTimelineJumpEnd,
mainWinJumpCursor = post EventTimelineJumpCursor,
mainWinScrollLeft = post EventTimelineScrollLeft,
mainWinScrollRight = post EventTimelineScrollRight,
mainWinJumpZoomIn = post EventTimelineZoomIn,
mainWinJumpZoomOut = post EventTimelineZoomOut,
mainWinJumpZoomFit = post EventTimelineZoomToFit,
mainWinDisplayLabels = post . EventTimelineLabelsMode,
mainWinViewBW = post . EventTimelineShowBW
}
timelineWin <- timelineViewNew builder TimelineViewActions {
timelineViewSelectionChanged = post . EventCursorChangedSelection
}
eventsView <- eventsViewNew builder EventsViewActions {
eventsViewCursorChanged = post . EventCursorChangedIndex
}
startupView <- startupInfoViewNew builder
summaryView <- summaryViewNew builder
histogramView <- histogramViewNew builder
traceView <- traceViewNew builder TraceViewActions {
traceViewTracesChanged = post . EventTracesChanged
}
bookmarkView <- bookmarkViewNew builder BookmarkViewActions {
bookmarkViewAddBookmark = post EventBookmarkAdd,
bookmarkViewRemoveBookmark = post . EventBookmarkRemove,
bookmarkViewGotoBookmark = \ts -> do
post (EventCursorChangedSelection (PointSelection ts))
post EventTimelineJumpCursor,
bookmarkViewEditLabel = \n v -> post (EventBookmarkEdit n v)
}
keyView <- keyViewNew builder
concCtl <- ConcurrencyControl.start
return UIEnv{..}
-------------------------------------------------------------------------------
data LoopDone = LoopDone
eventLoop :: UIEnv -> EventlogState -> IO ()
eventLoop uienv@UIEnv{..} eventlogState = do
event <- getEvent eventQueue
next <- dispatch event eventlogState
#if __GLASGOW_HASKELL__ <= 612
-- workaround for a wierd exception handling bug in ghc-6.12
`catch` \e -> throwIO (e :: SomeException)
#endif
case next of
Left LoopDone -> return ()
Right eventlogState' -> eventLoop uienv eventlogState'
where
dispatch :: Event -> EventlogState -> IO (Either LoopDone EventlogState)
dispatch EventQuit _ = return (Left LoopDone)
dispatch EventOpenDialog _ = do
openFileDialog mainWin $ \filename ->
post (EventFileLoad filename)
continue
dispatch (EventFileLoad filename) _ = do
async "loading the eventlog" $
loadEvents (Just filename) (registerEventsFromFile filename)
--TODO: set state to be empty during loading
continue
dispatch (EventTestLoad testname) _ = do
async "loading the test eventlog" $
loadEvents Nothing (registerEventsFromTrace testname)
--TODO: set state to be empty during loading
continue
dispatch EventFileReload EventlogLoaded{mfilename = Just filename} = do
async "reloading the eventlog" $
loadEvents (Just filename) (registerEventsFromFile filename)
--TODO: set state to be empty during loading
continue
dispatch EventFileReload EventlogLoaded{mfilename = Nothing} =
continue
-- dispatch EventClearState _
dispatch (EventSetState hecs mfilename name nevents timespan) _ =
-- We have to draw this ASAP, before the user manages to move
-- the mouse away from the window, or the window is left
-- in a partially drawn state.
ConcurrencyControl.fullSpeed concCtl $ do
MainWindow.setFileLoaded mainWin (Just name)
MainWindow.setStatusMessage mainWin $
printf "%s (%d events, %.3fs)" name nevents timespan
let mevents = Just $ hecEventArray hecs
eventsViewSetEvents eventsView mevents
startupInfoViewSetEvents startupView mevents
summaryViewSetEvents summaryView mevents
histogramViewSetHECs histogramView (Just hecs)
traceViewSetHECs traceView hecs
traces' <- traceViewGetTraces traceView
timelineWindowSetHECs timelineWin (Just hecs)
timelineWindowSetTraces timelineWin traces'
-- We set user 'traceMarker' events as initial bookmarks.
let usrMarkers = extractUserMarkers hecs
bookmarkViewClear bookmarkView
sequence_ [ bookmarkViewAdd bookmarkView ts label
| (ts, label) <- usrMarkers ]
timelineWindowSetBookmarks timelineWin (map fst usrMarkers)
if nevents == 0
then continueWith NoEventlogLoaded
else continueWith EventlogLoaded
{ mfilename = mfilename
, hecs = hecs
, selection = PointSelection 0
, cursorPos = 0
}
dispatch EventExportDialog
EventlogLoaded {mfilename} = do
exportFileDialog mainWin (fromMaybe "" mfilename) $ \filename' format ->
post (EventFileExport filename' format)
continue
dispatch (EventFileExport filename format)
EventlogLoaded {hecs} = do
viewParams <- timelineGetViewParameters timelineWin
let viewParams' = viewParams {
detail = 1,
bwMode = False,
labelsMode = False
}
let yScaleArea = timelineGetYScaleArea timelineWin
case format of
FormatPDF ->
saveAsPDF filename hecs viewParams' yScaleArea
FormatPNG ->
saveAsPNG filename hecs viewParams' yScaleArea
continue
dispatch EventLaunchWebsite _ = do
GtkExtras.launchProgramForURI "http://www.haskell.org/haskellwiki/ThreadScope"
continue
dispatch EventLaunchTutorial _ = do
GtkExtras.launchProgramForURI "http://www.haskell.org/haskellwiki/ThreadScope_Tour"
continue
dispatch EventAboutDialog _ = do
aboutDialog mainWin
continue
dispatch (EventShowSidebar visible) _ = do
MainWindow.sidebarSetVisibility mainWin visible
continue
dispatch (EventShowEvents visible) _ = do
MainWindow.eventsSetVisibility mainWin visible
continue
dispatch EventTimelineJumpStart _ = do
timelineScrollToBeginning timelineWin
eventsViewScrollToLine eventsView 0
continue
dispatch EventTimelineJumpEnd EventlogLoaded{hecs} = do
timelineScrollToEnd timelineWin
let (_,end) = bounds (hecEventArray hecs)
eventsViewScrollToLine eventsView end
continue
dispatch EventTimelineJumpCursor EventlogLoaded{cursorPos} = do
timelineCentreOnCursor timelineWin --TODO: pass selection here
eventsViewScrollToLine eventsView cursorPos
continue
dispatch EventTimelineScrollLeft _ = do
timelineScrollLeft timelineWin
continue
dispatch EventTimelineScrollRight _ = do
timelineScrollRight timelineWin
continue
dispatch EventTimelineZoomIn _ = do
timelineZoomIn timelineWin
continue
dispatch EventTimelineZoomOut _ = do
timelineZoomOut timelineWin
continue
dispatch EventTimelineZoomToFit _ = do
timelineZoomToFit timelineWin
continue
dispatch (EventTimelineLabelsMode labelsMode) _ = do
timelineSetLabelsMode timelineWin labelsMode
continue
dispatch (EventTimelineShowBW showBW) _ = do
timelineSetBWMode timelineWin showBW
continue
dispatch (EventCursorChangedIndex cursorPos') EventlogLoaded{hecs} = do
let cursorTs' = eventIndexToTimestamp hecs cursorPos'
selection' = PointSelection cursorTs'
timelineSetSelection timelineWin selection'
eventsViewSetCursor eventsView cursorPos' Nothing
continueWith eventlogState {
selection = selection',
cursorPos = cursorPos'
}
dispatch (EventCursorChangedSelection selection'@(PointSelection cursorTs'))
EventlogLoaded{hecs} = do
let cursorPos' = timestampToEventIndex hecs cursorTs'
timelineSetSelection timelineWin selection'
eventsViewSetCursor eventsView cursorPos' Nothing
histogramViewSetInterval histogramView Nothing
summaryViewSetInterval summaryView Nothing
continueWith eventlogState {
selection = selection',
cursorPos = cursorPos'
}
dispatch (EventCursorChangedSelection selection'@(RangeSelection start end))
EventlogLoaded{hecs} = do
let cursorPos' = timestampToEventIndex hecs start
mrange = Just (cursorPos', timestampToEventIndex hecs end)
timelineSetSelection timelineWin selection'
eventsViewSetCursor eventsView cursorPos' mrange
histogramViewSetInterval histogramView (Just (start, end))
summaryViewSetInterval summaryView (Just (start, end))
continueWith eventlogState {
selection = selection',
cursorPos = cursorPos'
}
dispatch (EventTracesChanged traces) _ = do
timelineWindowSetTraces timelineWin traces
continue
dispatch EventBookmarkAdd EventlogLoaded{selection} = do
case selection of
PointSelection a -> bookmarkViewAdd bookmarkView a ""
RangeSelection a b -> do bookmarkViewAdd bookmarkView a ""
bookmarkViewAdd bookmarkView b ""
--TODO: should have a way to add/set a single bookmark for the timeline
-- rather than this hack where we ask the bookmark view for the whole lot.
ts <- bookmarkViewGet bookmarkView
timelineWindowSetBookmarks timelineWin (map fst ts)
continue
dispatch (EventBookmarkRemove n) _ = do
bookmarkViewRemove bookmarkView n
--TODO: should have a way to add/set a single bookmark for the timeline
-- rather than this hack where we ask the bookmark view for the whole lot.
ts <- bookmarkViewGet bookmarkView
timelineWindowSetBookmarks timelineWin (map fst ts)
continue
dispatch (EventBookmarkEdit n v) _ = do
bookmarkViewSetLabel bookmarkView n v
continue
dispatch (EventUserError doing exception) _ = do
let headline = "There was a problem " ++ doing ++ "."
explanation = show exception
errorMessageDialog mainWin headline explanation
continue
dispatch _ NoEventlogLoaded = continue
loadEvents mfilename registerEvents = do
ConcurrencyControl.fullSpeed concCtl $
ProgressView.withProgress mainWin $ \progress -> do
(hecs, name, nevents, timespan) <- registerEvents progress
-- This is a desperate hack to avoid the "segfault on reload" bug
-- http://trac.haskell.org/ThreadScope/ticket/1
-- It should be enough to let other threads finish and so avoid
-- re-entering gtk C code (see ticket for the dirty details).
--
-- Unfortunately it halts drawing of the loaded events if the user
-- manages to move the mouse away from the window during the delay.
-- threadDelay 100000 -- 1/10th of a second
post (EventSetState hecs mfilename name nevents timespan)
return ()
async doing action =
forkIO (action `catch` \e -> post (EventUserError doing e))
post = postEvent eventQueue
continue = continueWith eventlogState
continueWith = return . Right
-------------------------------------------------------------------------------
runGUI :: Maybe (Either FilePath String) -> IO ()
runGUI initialTrace = do
Gtk.initGUI
uiEnv <- constructUI
let post = postEvent (eventQueue uiEnv)
case initialTrace of
Nothing -> return ()
Just (Left filename) -> post (EventFileLoad filename)
Just (Right traceName) -> post (EventTestLoad traceName)
doneVar <- newEmptyMVar
forkIO $ do
res <- try $ eventLoop uiEnv NoEventlogLoaded
Gtk.mainQuit
putMVar doneVar (res :: Either SomeException ())
#ifndef mingw32_HOST_OS
installHandler sigINT (Catch $ post EventQuit) Nothing
#endif
-- Enter Gtk+ main event loop.
Gtk.mainGUI
-- Wait for child event loop to terminate
-- This lets us wait for any exceptions.
either throwIO return =<< takeMVar doneVar
threadscope-0.2.2/GUI/EventsView.hs 0000644 0000000 0000000 00000027676 12044651254 015306 0 ustar 00 0000000 0000000 module GUI.EventsView (
EventsView,
eventsViewNew,
EventsViewActions(..),
eventsViewSetEvents,
eventsViewGetCursor,
eventsViewSetCursor,
eventsViewScrollToLine,
) where
import GHC.RTS.Events
import Graphics.UI.Gtk
import qualified GUI.GtkExtras as GtkExt
import Control.Monad.Reader
import Data.Array
import Data.IORef
import Numeric
-------------------------------------------------------------------------------
data EventsView = EventsView {
drawArea :: !Widget,
adj :: !Adjustment,
stateRef :: !(IORef ViewState)
}
data EventsViewActions = EventsViewActions {
eventsViewCursorChanged :: Int -> IO ()
}
data ViewState = ViewState {
lineHeight :: !Double,
eventsState :: !EventsState
}
data EventsState
= EventsEmpty
| EventsLoaded {
cursorPos :: !Int,
mrange :: !(Maybe (Int, Int)),
eventsArr :: Array Int CapEvent
}
-------------------------------------------------------------------------------
eventsViewNew :: Builder -> EventsViewActions -> IO EventsView
eventsViewNew builder EventsViewActions{..} = do
stateRef <- newIORef undefined
let getWidget cast = builderGetObject builder cast
drawArea <- getWidget castToWidget "eventsDrawingArea"
vScrollbar <- getWidget castToVScrollbar "eventsVScroll"
adj <- get vScrollbar rangeAdjustment
-- make the background white
widgetModifyBg drawArea StateNormal (Color 0xffff 0xffff 0xffff)
widgetSetCanFocus drawArea True
--TODO: needs to be reset on each style change ^^
-----------------------------------------------------------------------------
-- Line height
-- Calculate the height of each line based on the current font
let getLineHeight = do
pangoCtx <- widgetGetPangoContext drawArea
fontDesc <- contextGetFontDescription pangoCtx
metrics <- contextGetMetrics pangoCtx fontDesc emptyLanguage
return $ ascent metrics + descent metrics --TODO: padding?
-- We cache the height of each line
initialLineHeight <- getLineHeight
-- but have to update it when the font changes
on drawArea styleSet $ \_ -> do
lineHeight' <- getLineHeight
modifyIORef stateRef $ \viewstate -> viewstate { lineHeight = lineHeight' }
-----------------------------------------------------------------------------
writeIORef stateRef ViewState {
lineHeight = initialLineHeight,
eventsState = EventsEmpty
}
let eventsView = EventsView {..}
-----------------------------------------------------------------------------
-- Drawing
on drawArea exposeEvent $ liftIO $ do
drawEvents eventsView =<< readIORef stateRef
return True
-----------------------------------------------------------------------------
-- Key navigation
on drawArea keyPressEvent $ do
let scroll by = liftIO $ do
ViewState{eventsState, lineHeight} <- readIORef stateRef
pagesize <- get adj adjustmentPageSize
let pagejump = max 1 (truncate (pagesize / lineHeight) - 1)
case eventsState of
EventsEmpty -> return ()
EventsLoaded{cursorPos, eventsArr} ->
eventsViewCursorChanged cursorPos'
where
cursorPos' = clampBounds range (by pagejump end cursorPos)
range@(_,end) = bounds eventsArr
return True
key <- eventKeyName
case key of
"Up" -> scroll (\_page _end pos -> pos-1)
"Down" -> scroll (\_page _end pos -> pos+1)
"Page_Up" -> scroll (\ page _end pos -> pos-page)
"Page_Down" -> scroll (\ page _end pos -> pos+page)
"Home" -> scroll (\_page _end _pos -> 0)
"End" -> scroll (\_page end _pos -> end)
"Left" -> return True
"Right" -> return True
_ -> return False
-----------------------------------------------------------------------------
-- Scrolling
set adj [ adjustmentLower := 0 ]
on drawArea sizeAllocate $ \_ ->
updateScrollAdjustment eventsView =<< readIORef stateRef
let hitpointToLine :: ViewState -> Double -> Double -> Maybe Int
hitpointToLine ViewState{eventsState = EventsEmpty} _ _ = Nothing
hitpointToLine ViewState{eventsState = EventsLoaded{eventsArr}, lineHeight}
yOffset eventY
| hitLine > maxIndex = Nothing
| otherwise = Just hitLine
where
hitLine = truncate ((yOffset + eventY) / lineHeight)
maxIndex = snd (bounds eventsArr)
on drawArea buttonPressEvent $ tryEvent $ do
(_,y) <- eventCoordinates
liftIO $ do
viewState <- readIORef stateRef
yOffset <- get adj adjustmentValue
widgetGrabFocus drawArea
case hitpointToLine viewState yOffset y of
Nothing -> return ()
Just n -> eventsViewCursorChanged n
on drawArea scrollEvent $ do
dir <- eventScrollDirection
liftIO $ do
val <- get adj adjustmentValue
upper <- get adj adjustmentUpper
pagesize <- get adj adjustmentPageSize
step <- get adj adjustmentStepIncrement
case dir of
ScrollUp -> set adj [ adjustmentValue := val - step ]
ScrollDown -> set adj [ adjustmentValue := min (val + step)
(upper - pagesize) ]
_ -> return ()
return True
onValueChanged adj $
widgetQueueDraw drawArea
-----------------------------------------------------------------------------
return eventsView
-------------------------------------------------------------------------------
eventsViewSetEvents :: EventsView -> Maybe (Array Int CapEvent) -> IO ()
eventsViewSetEvents eventWin@EventsView{drawArea, stateRef} mevents = do
viewState <- readIORef stateRef
let eventsState' = case mevents of
Nothing -> EventsEmpty
Just events -> EventsLoaded {
cursorPos = 0,
mrange = Nothing,
eventsArr = events
}
viewState' = viewState { eventsState = eventsState' }
writeIORef stateRef viewState'
updateScrollAdjustment eventWin viewState'
widgetQueueDraw drawArea
-------------------------------------------------------------------------------
eventsViewGetCursor :: EventsView -> IO (Maybe Int)
eventsViewGetCursor EventsView{stateRef} = do
ViewState{eventsState} <- readIORef stateRef
case eventsState of
EventsEmpty -> return Nothing
EventsLoaded{cursorPos} -> return (Just cursorPos)
eventsViewSetCursor :: EventsView -> Int -> Maybe (Int, Int) -> IO ()
eventsViewSetCursor eventsView@EventsView{drawArea, stateRef} n mrange = do
viewState@ViewState{eventsState} <- readIORef stateRef
case eventsState of
EventsEmpty -> return ()
EventsLoaded{eventsArr} -> do
let n' = clampBounds (bounds eventsArr) n
writeIORef stateRef viewState {
eventsState = eventsState { cursorPos = n', mrange }
}
eventsViewScrollToLine eventsView n'
widgetQueueDraw drawArea
eventsViewScrollToLine :: EventsView -> Int -> IO ()
eventsViewScrollToLine EventsView{adj, stateRef} n = do
ViewState{lineHeight} <- readIORef stateRef
-- make sure that the range [n..n+1] is within the current page:
adjustmentClampPage adj
(fromIntegral n * lineHeight)
(fromIntegral (n+1) * lineHeight)
-------------------------------------------------------------------------------
updateScrollAdjustment :: EventsView -> ViewState -> IO ()
updateScrollAdjustment EventsView{drawArea, adj}
ViewState{lineHeight, eventsState} = do
(_,windowHeight) <- widgetGetSize drawArea
let numLines = case eventsState of
EventsEmpty -> 0
EventsLoaded{eventsArr} -> snd (bounds eventsArr) + 1
linesHeight = fromIntegral numLines * lineHeight
upper = max linesHeight (fromIntegral windowHeight)
pagesize = fromIntegral windowHeight
set adj [
adjustmentUpper := upper,
adjustmentPageSize := pagesize,
adjustmentStepIncrement := pagesize * 0.2,
adjustmentPageIncrement := pagesize * 0.9
]
val <- get adj adjustmentValue
when (val > upper - pagesize) $
set adj [ adjustmentValue := max 0 (upper - pagesize) ]
-------------------------------------------------------------------------------
drawEvents :: EventsView -> ViewState -> IO ()
drawEvents _ ViewState {eventsState = EventsEmpty} = return ()
drawEvents EventsView{drawArea, adj}
ViewState {lineHeight, eventsState = EventsLoaded{..}} = do
yOffset <- get adj adjustmentValue
pageSize <- get adj adjustmentPageSize
-- calculate which lines are visible
let lower = truncate (yOffset / lineHeight)
upper = ceiling ((yOffset + pageSize) / lineHeight)
-- the array indexes [begin..end] inclusive
-- are partially or fully visible
begin = lower
end = min upper (snd (bounds eventsArr))
win <- widgetGetDrawWindow drawArea
style <- get drawArea widgetStyle
focused <- get drawArea widgetIsFocus
let state | focused = StateSelected
| otherwise = StateActive
pangoCtx <- widgetGetPangoContext drawArea
layout <- layoutEmpty pangoCtx
layoutSetEllipsize layout EllipsizeEnd
(width,clipHeight) <- widgetGetSize drawArea
let clipRect = Rectangle 0 0 width clipHeight
let -- With average char width, timeWidth is enough for 24 hours of logs
-- (way more than TS can handle, currently). Aligns nicely with
-- current timeline_yscale_area width, too.
-- TODO: take timeWidth from the yScaleDrawingArea width
-- TODO: perhaps make the timeWidth area grey, too?
-- TODO: perhaps limit scroll to the selected interval (perhaps not strictly, but only so that the interval area does not completely vanish from the visible area)?
timeWidth = 105
columnGap = 20
descrWidth = width - timeWidth - columnGap
sequence_
[ do when (inside || selected) $
GtkExt.stylePaintFlatBox
style win
state1 ShadowNone
clipRect
drawArea ""
0 (round y) width (round lineHeight)
-- The event time
layoutSetText layout (showEventTime event)
layoutSetAlignment layout AlignRight
layoutSetWidth layout (Just (fromIntegral timeWidth))
GtkExt.stylePaintLayout
style win
state2 True
clipRect
drawArea ""
0 (round y)
layout
-- The event description text
layoutSetText layout (showEventDescr event)
layoutSetAlignment layout AlignLeft
layoutSetWidth layout (Just (fromIntegral descrWidth))
GtkExt.stylePaintLayout
style win
state2 True
clipRect
drawArea ""
(timeWidth + columnGap) (round y)
layout
| n <- [begin..end]
, let y = fromIntegral n * lineHeight - yOffset
event = eventsArr ! n
inside = maybe False (\ (s, e) -> s <= n && n <= e) mrange
selected = cursorPos == n
(state1, state2)
| inside = (StatePrelight, StatePrelight)
| selected = (state, state)
| otherwise = (state, StateNormal)
]
where
showEventTime (CapEvent _cap (Event time _spec)) =
showFFloat (Just 6) (fromIntegral time / 1000000) "s"
showEventDescr (CapEvent cap (Event _time spec)) =
(case cap of
Nothing -> ""
Just c -> "HEC " ++ show c ++ ": ")
++ case spec of
UnknownEvent{ref} -> "unknown event; " ++ show ref
Message msg -> msg
UserMessage msg -> msg
_ -> showEventInfo spec
-------------------------------------------------------------------------------
clampBounds :: Ord a => (a, a) -> a -> a
clampBounds (lower, upper) x
| x <= lower = lower
| x > upper = upper
| otherwise = x
threadscope-0.2.2/GUI/Timeline/ 0000755 0000000 0000000 00000000000 12044651254 014377 5 ustar 00 0000000 0000000 threadscope-0.2.2/GUI/Timeline/CairoDrawing.hs 0000644 0000000 0000000 00000006262 12044651254 017312 0 ustar 00 0000000 0000000 -------------------------------------------------------------------------------
--- $Id: CairoDrawing.hs#3 2009/07/18 22:48:30 REDMOND\\satnams $
--- $Source: //depot/satnams/haskell/ThreadScope/CairoDrawing.hs $
-------------------------------------------------------------------------------
module GUI.Timeline.CairoDrawing
where
import Graphics.Rendering.Cairo
import qualified Graphics.Rendering.Cairo as C
import Control.Monad
-------------------------------------------------------------------------------
{-# INLINE draw_line #-}
draw_line :: (Integral a, Integral b, Integral c, Integral d) =>
(a, b) -> (c, d) -> Render ()
draw_line (x0, y0) (x1, y1)
= do move_to (x0, y0)
lineTo (fromIntegral x1) (fromIntegral y1)
stroke
{-# INLINE move_to #-}
move_to :: (Integral a, Integral b) => (a, b) -> Render ()
move_to (x, y)
= moveTo (fromIntegral x) (fromIntegral y)
{-# INLINE rel_line_to #-}
rel_line_to :: (Integral a, Integral b) => (a, b) -> Render ()
rel_line_to (x, y)
= relLineTo (fromIntegral x) (fromIntegral y)
-------------------------------------------------------------------------------
{-# INLINE draw_rectangle #-}
draw_rectangle :: (Integral x, Integral y, Integral w, Integral h)
=> x -> y -> w -> h
-> Render ()
draw_rectangle x y w h = do
rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
C.fill
-------------------------------------------------------------------------------
{-# INLINE draw_outlined_rectangle #-}
draw_outlined_rectangle :: (Integral x, Integral y, Integral w, Integral h)
=> x -> y -> w -> h
-> Render ()
draw_outlined_rectangle x y w h = do
rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
fillPreserve
setLineWidth 1
setSourceRGBA 0 0 0 0.7
stroke
-------------------------------------------------------------------------------
{-# INLINE draw_rectangle_opt #-}
draw_rectangle_opt :: (Integral x, Integral y, Integral w, Integral h)
=> Bool -> x -> y -> w -> h
-> Render ()
draw_rectangle_opt opt x y w h
= draw_rectangle_opt' opt (fromIntegral x) (fromIntegral y)
(fromIntegral w) (fromIntegral h)
draw_rectangle_opt' :: Bool -> Double -> Double -> Double -> Double
-> Render ()
draw_rectangle_opt' opt x y w h
= do rectangle x y (1.0 `max` w) h
C.fill
when opt $ do
setLineWidth 1
setSourceRGBA 0 0 0 0.7
rectangle x y w h
stroke
-------------------------------------------------------------------------------
{-# INLINE draw_rectangle_outline #-}
draw_rectangle_outline :: (Integral x, Integral y, Integral w, Integral h)
=> x -> y -> w -> h
-> Render ()
draw_rectangle_outline x y w h = do
setLineWidth 2
rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
stroke
-------------------------------------------------------------------------------
clearWhite :: Render ()
clearWhite = do
save
setOperator OperatorSource
setSourceRGBA 0xffff 0xffff 0xffff 0xffff
paint
restore
threadscope-0.2.2/GUI/Timeline/Render.hs 0000644 0000000 0000000 00000040162 12044651254 016155 0 ustar 00 0000000 0000000 module GUI.Timeline.Render (
renderView,
renderTraces,
updateXScaleArea,
renderYScaleArea,
updateYScaleArea,
calculateTotalTimelineHeight,
toWholePixels,
) where
import GUI.Timeline.Types
import GUI.Timeline.Render.Constants
import GUI.Timeline.Ticks
import GUI.Timeline.HEC
import GUI.Timeline.Sparks
import GUI.Timeline.Activity
import Events.HECs
import GUI.Types
import GUI.ViewerColours
import GUI.Timeline.CairoDrawing
import Graphics.UI.Gtk
import Graphics.Rendering.Cairo
import Data.IORef
import Control.Monad
-------------------------------------------------------------------------------
-- | This function redraws the currently visible part of the
-- main trace canvas plus related canvases.
--
renderView :: TimelineState
-> ViewParameters
-> HECs -> TimeSelection -> [Timestamp]
-> Region -> IO ()
renderView TimelineState{timelineDrawingArea, timelineVAdj, timelinePrevView}
params hecs selection bookmarks exposeRegion = do
-- Get state information from user-interface components
(w, _) <- widgetGetSize timelineDrawingArea
vadj_value <- adjustmentGetValue timelineVAdj
prev_view <- readIORef timelinePrevView
rect <- regionGetClipbox exposeRegion
win <- widgetGetDrawWindow timelineDrawingArea
renderWithDrawable win $ do
let renderToNewSurface = do
new_surface <- withTargetSurface $ \surface ->
liftIO $ createSimilarSurface surface ContentColor w (height params)
renderWith new_surface $ do
clearWhite
renderTraces params hecs rect
return new_surface
surface <-
case prev_view of
Nothing -> renderToNewSurface
Just (old_params, surface)
| old_params == params
-> return surface
| width old_params == width params &&
height old_params == height params
-> do
if old_params { hadjValue = hadjValue params } == params
-- only the hadjValue changed
&& abs (hadjValue params - hadjValue old_params) <
fromIntegral (width params) * scaleValue params
-- and the views overlap...
then
scrollView surface old_params params hecs
else do
renderWith surface $ do
clearWhite; renderTraces params hecs rect
return surface
| otherwise
-> do surfaceFinish surface
renderToNewSurface
liftIO $ writeIORef timelinePrevView (Just (params, surface))
region exposeRegion
clip
setSourceSurface surface 0 (-vadj_value)
-- ^^ this is where we adjust for the vertical scrollbar
setOperator OperatorSource
paint
renderBookmarks bookmarks params
drawSelection params selection
-------------------------------------------------------------------------------
-- Render the bookmarks
renderBookmarks :: [Timestamp] -> ViewParameters -> Render ()
renderBookmarks bookmarks vp@ViewParameters{height} = do
setLineWidth 1
setSourceRGBAhex bookmarkColour 1.0
sequence_
[ do moveTo x 0
lineTo x (fromIntegral height)
stroke
| bookmark <- bookmarks
, let x = timestampToView vp bookmark ]
-------------------------------------------------------------------------------
drawSelection :: ViewParameters -> TimeSelection -> Render ()
drawSelection vp@ViewParameters{height} (PointSelection x) = do
setLineWidth 3
setOperator OperatorOver
setSourceRGBAhex blue 1.0
moveTo xv 0
lineTo xv (fromIntegral height)
stroke
where
xv = timestampToView vp x
drawSelection vp@ViewParameters{height} (RangeSelection x x') = do
setLineWidth 1.5
setOperator OperatorOver
setSourceRGBAhex blue 0.25
rectangle xv 0 (xv' - xv) (fromIntegral height)
fill
setSourceRGBAhex blue 1.0
moveTo xv 0
lineTo xv (fromIntegral height)
moveTo xv' 0
lineTo xv' (fromIntegral height)
stroke
where
xv = timestampToView vp x
xv' = timestampToView vp x'
-------------------------------------------------------------------------------
-- We currently have two different way of converting from logical units
-- (ie timestamps in micro-seconds) to device units (ie pixels):
-- * the first is to set the cairo context to the appropriate scale
-- * the second is to do the conversion ourself
--
-- While in principle the first is superior due to the simplicity: cairo
-- lets us use Double as the logical unit and scaling factor. In practice
-- however cairo does not support the full Double range because internally
-- it makes use of a 32bit fixed point float format. With very large scaling
-- factors we end up with artifacts like lines disappearing.
--
-- So sadly we will probably have to convert to using the second method.
-- | Use cairo to convert from logical units (timestamps) to device units
--
withViewScale :: ViewParameters -> Render () -> Render ()
withViewScale ViewParameters{scaleValue, hadjValue} inner = do
save
scale (1/scaleValue) 1.0
translate (-hadjValue) 0
inner
restore
-- | Manually convert from logical units (timestamps) to device units.
--
timestampToView :: ViewParameters -> Timestamp -> Double
timestampToView ViewParameters{scaleValue, hadjValue} ts =
(fromIntegral ts - hadjValue) / scaleValue
-------------------------------------------------------------------------------
-- This function draws the current view of all the HECs with Cairo.
renderTraces :: ViewParameters -> HECs -> Rectangle
-> Render ()
renderTraces params@ViewParameters{..} hecs (Rectangle rx _ry rw _rh) = do
let scale_rx = fromIntegral rx * scaleValue
scale_rw = fromIntegral rw * scaleValue
scale_width = fromIntegral width * scaleValue
startPos :: Timestamp
startPos = fromIntegral $ truncate (scale_rx + hadjValue)
endPos :: Timestamp
endPos = minimum [
ceiling (hadjValue + scale_width),
ceiling (hadjValue + scale_rx + scale_rw),
hecLastEventTime hecs
]
-- For spark traces, round the start time down, and the end time up,
-- to a slice boundary:
start = (startPos `div` slice) * slice
end = ((endPos + slice) `div` slice) * slice
(slice, prof) = treesProfile scaleValue start end hecs
withViewScale params $ do
-- Render the vertical rulers across all the traces.
renderVRulers scaleValue startPos endPos height XScaleTime
-- This function helps to render a single HEC.
-- Traces are rendered even if the y-region falls outside visible area.
-- OTOH, trace rendering function tend to drawn only the visible
-- x-region of the graph.
let renderTrace trace y = do
save
translate 0 (fromIntegral y)
case trace of
TraceHEC c ->
let (dtree, etree, _) = hecTrees hecs !! c
in renderHEC params startPos endPos
(perfNames hecs) (dtree, etree)
TraceInstantHEC c ->
let (_, etree, _) = hecTrees hecs !! c
in renderInstantHEC params startPos endPos
(perfNames hecs) etree
TraceCreationHEC c ->
renderSparkCreation params slice start end (prof !! c)
TraceConversionHEC c ->
renderSparkConversion params slice start end (prof !! c)
TracePoolHEC c ->
let maxP = maxSparkPool hecs
in renderSparkPool params slice start end (prof !! c) maxP
TraceHistogram ->
renderSparkHistogram params hecs
TraceGroup _ -> error "renderTrace"
TraceActivity ->
renderActivity params hecs startPos endPos
restore
histTotalHeight = histogramHeight + histXScaleHeight
-- Now render all the HECs.
zipWithM_ renderTrace viewTraces
(traceYPositions labelsMode histTotalHeight viewTraces)
-------------------------------------------------------------------------------
-- parameters differ only in the hadjValue, we can scroll ...
scrollView :: Surface
-> ViewParameters -> ViewParameters
-> HECs
-> Render Surface
scrollView surface old new hecs = do
-- scrolling on the same surface seems not to work, I get garbled results.
-- Not sure what the best way to do this is.
-- let new_surface = surface
new_surface <- withTargetSurface $ \surface ->
liftIO $ createSimilarSurface surface ContentColor
(width new) (height new)
renderWith new_surface $ do
let scale = scaleValue new
old_hadj = hadjValue old
new_hadj = hadjValue new
w = fromIntegral (width new)
h = fromIntegral (height new)
off = (old_hadj - new_hadj) / scale
-- liftIO $ printf "scrollView: old: %f, new %f, dist = %f (%f pixels)\n"
-- old_hadj new_hadj (old_hadj - new_hadj) off
-- copy the content from the old surface to the new surface,
-- shifted by the appropriate amount.
setSourceSurface surface off 0
if old_hadj > new_hadj
then rectangle off 0 (w - off) h -- scroll right.
else rectangle 0 0 (w + off) h -- scroll left.
fill
let rect | old_hadj > new_hadj
= Rectangle 0 0 (ceiling off) (height new)
| otherwise
= Rectangle (truncate (w + off)) 0 (ceiling (-off)) (height new)
case rect of
Rectangle x y w h -> rectangle (fromIntegral x) (fromIntegral y)
(fromIntegral w) (fromIntegral h)
setSourceRGBA 0xffff 0xffff 0xffff 0xffff
fill
renderTraces new hecs rect
surfaceFinish surface
return new_surface
--------------------------------------------------------------------------------
-- | Update the X scale widget, based on the state of all timeline areas.
-- For simplicity, unlike for the traces, we redraw the whole area
-- and not only the newly exposed area. This is comparatively very cheap.
updateXScaleArea :: TimelineState -> Timestamp -> IO ()
updateXScaleArea TimelineState{..} lastTx = do
win <- widgetGetDrawWindow timelineXScaleArea
(width, _) <- widgetGetSize timelineDrawingArea
(_, xScaleAreaHeight) <- widgetGetSize timelineXScaleArea
scaleValue <- readIORef scaleIORef
-- Snap the view to whole pixels, to avoid blurring.
hadjValue0 <- adjustmentGetValue timelineAdj
let hadjValue = toWholePixels scaleValue hadjValue0
off y = y + xScaleAreaHeight - 17
renderWithDrawable win $
renderXScale scaleValue hadjValue lastTx width off XScaleTime
return ()
--------------------------------------------------------------------------------
-- | Render the Y scale area (an axis, ticks and a label for each graph),
-- based on view parameters and hecs.
renderYScaleArea :: ViewParameters -> HECs -> DrawingArea -> Render ()
renderYScaleArea ViewParameters{maxSpkValue, labelsMode, viewTraces,
histogramHeight, minterval}
hecs yScaleArea = do
let maxP = maxSparkPool hecs
maxH = fromIntegral $ maxYHistogram hecs
(xoffset, _) <- liftIO $ widgetGetSize yScaleArea
drawYScaleArea
maxSpkValue maxP maxH minterval (fromIntegral xoffset) 0
labelsMode histogramHeight viewTraces yScaleArea
-- | Update the Y scale widget, based on the state of all timeline areas
-- and on traces (only for graph labels and relative positions).
updateYScaleArea :: TimelineState -> Double -> Double -> Maybe Interval
-> Bool -> [Trace] -> IO ()
updateYScaleArea TimelineState{..} maxSparkPool maxYHistogram minterval
labelsMode traces = do
win <- widgetGetDrawWindow timelineYScaleArea
maxSpkValue <- readIORef maxSpkIORef
vadj_value <- adjustmentGetValue timelineVAdj
(xoffset, _) <- widgetGetSize timelineYScaleArea
renderWithDrawable win $
drawYScaleArea maxSpkValue maxSparkPool maxYHistogram minterval
(fromIntegral xoffset) vadj_value labelsMode stdHistogramHeight traces
timelineYScaleArea
-- | Render the Y scale area, by rendering an axis, ticks and a label
-- for each graph-like trace in turn (and only labels for other traces).
drawYScaleArea :: Double -> Double -> Double -> Maybe Interval -> Double
-> Double -> Bool -> Int -> [Trace] -> DrawingArea
-> Render ()
drawYScaleArea maxSpkValue maxSparkPool maxYHistogram minterval xoffset
vadj_value labelsMode histogramHeight traces yScaleArea = do
let histTotalHeight = histogramHeight + histXScaleHeight
ys = map (subtract (round vadj_value)) $
traceYPositions labelsMode histTotalHeight traces
pcontext <- liftIO $ widgetCreatePangoContext yScaleArea
zipWithM_
(drawSingleYScale
maxSpkValue maxSparkPool maxYHistogram minterval xoffset
histogramHeight pcontext)
traces ys
-- | Render a single Y scale axis, set of ticks and label, or only a label,
-- if the trace is not a graph.
drawSingleYScale :: Double -> Double -> Double -> Maybe Interval -> Double -> Int
-> PangoContext -> Trace -> Int
-> Render ()
drawSingleYScale maxSpkValue maxSparkPool maxYHistogram minterval xoffset
histogramHeight pcontext trace y = do
setSourceRGBAhex black 1
move_to (ox, y + 8)
layout <- liftIO $ layoutText pcontext (showTrace minterval trace)
liftIO $ do
layoutSetWidth layout (Just $ xoffset - 50)
-- Note: the following does not always work, see the HACK in Timeline.hs
layoutSetAttributes layout [AttrSize minBound maxBound 8,
AttrFamily minBound maxBound "sans serif"]
showLayout layout
case traceMaxSpark maxSpkValue maxSparkPool maxYHistogram trace of
Just v ->
renderYScale
(traceHeight histogramHeight trace) 1 v (xoffset - 13) (fromIntegral y)
Nothing -> return () -- not a graph-like trace
--------------------------------------------------------------------------------
-- | Calculate Y positions of all traces.
traceYPositions :: Bool -> Int -> [Trace] -> [Int]
traceYPositions labelsMode histTotalHeight traces =
scanl (\a b -> a + (height b) + extra + tracePad) firstTraceY traces
where
height b = traceHeight histTotalHeight b
extra = if labelsMode then hecLabelExtra else 0
traceHeight :: Int -> Trace -> Int
traceHeight _ TraceHEC{} = hecTraceHeight
traceHeight _ TraceInstantHEC{} = hecInstantHeight
traceHeight _ TraceCreationHEC{} = hecSparksHeight
traceHeight _ TraceConversionHEC{} = hecSparksHeight
traceHeight _ TracePoolHEC{} = hecSparksHeight
traceHeight h TraceHistogram = h
traceHeight _ TraceGroup{} = error "traceHeight"
traceHeight _ TraceActivity = activityGraphHeight
-- | Calculate the total Y span of all traces.
calculateTotalTimelineHeight :: Bool -> Int -> [Trace] -> Int
calculateTotalTimelineHeight labelsMode histTotalHeight traces =
last (traceYPositions labelsMode histTotalHeight traces)
-- | Produce a descriptive label for a trace.
showTrace :: Maybe Interval -> Trace -> String
showTrace _ (TraceHEC n) =
"HEC " ++ show n
showTrace _ (TraceInstantHEC n) =
"HEC " ++ show n ++ "\nInstant"
showTrace _ (TraceCreationHEC n) =
"\nHEC " ++ show n ++ "\n\nSpark creation rate (spark/ms)"
showTrace _ (TraceConversionHEC n) =
"\nHEC " ++ show n ++ "\n\nSpark conversion rate (spark/ms)"
showTrace _ (TracePoolHEC n) =
"\nHEC " ++ show n ++ "\n\nSpark pool size"
showTrace Nothing TraceHistogram =
"Sum of spark times\n(" ++ mu ++ "s)"
showTrace Just{} TraceHistogram =
"Sum of selected spark times\n(" ++ mu ++ "s)"
showTrace _ TraceActivity =
"Activity"
showTrace _ TraceGroup{} = error "Render.showTrace"
-- | Calcaulate the maximal Y value for a graph-like trace, or Nothing.
traceMaxSpark :: Double -> Double -> Double -> Trace -> Maybe Double
traceMaxSpark maxS _ _ TraceCreationHEC{} = Just $ maxS * 1000
traceMaxSpark maxS _ _ TraceConversionHEC{} = Just $ maxS * 1000
traceMaxSpark _ maxP _ TracePoolHEC{} = Just $ maxP
traceMaxSpark _ _ maxH TraceHistogram = Just $ maxH
traceMaxSpark _ _ _ _ = Nothing
-- | Snap a value to a whole pixel, based on drawing scale.
toWholePixels :: Double -> Double -> Double
toWholePixels 0 _ = 0
toWholePixels scale x = fromIntegral (truncate (x / scale)) * scale
threadscope-0.2.2/GUI/Timeline/Activity.hs 0000644 0000000 0000000 00000012743 12044651254 016536 0 ustar 00 0000000 0000000 module GUI.Timeline.Activity (
renderActivity
) where
import GUI.Timeline.Render.Constants
import Events.HECs
import Events.EventTree
import Events.EventDuration
import GUI.Types
import GUI.ViewerColours
import Graphics.Rendering.Cairo
import Control.Monad
import Data.List
-- ToDo:
-- - we average over the slice, but the point is drawn at the beginning
-- of the slice rather than in the middle.
-----------------------------------------------------------------------------
renderActivity :: ViewParameters -> HECs -> Timestamp -> Timestamp
-> Render ()
renderActivity ViewParameters{..} hecs start0 end0 = do
let
slice = ceiling (fromIntegral activity_detail * scaleValue)
-- round the start time down, and the end time up, to a slice boundary
start = (start0 `div` slice) * slice
end = ((end0 + slice) `div` slice) * slice
hec_profs = map (actProfile slice start end)
(map (\ (t, _, _) -> t) (hecTrees hecs))
total_prof = map sum (transpose hec_profs)
-- liftIO $ printf "%s\n" (show (map length hec_profs))
-- liftIO $ printf "%s\n" (show (map (take 20) hec_profs))
drawActivity hecs start end slice total_prof
(if not bwMode then runningColour else black)
activity_detail :: Int
activity_detail = 4 -- in pixels
-- for each timeslice, the amount of time spent in the mutator
-- during that period.
actProfile :: Timestamp -> Timestamp -> Timestamp -> DurationTree -> [Timestamp]
actProfile slice start0 end0 t
= {- trace (show flat) $ -} chopped
where
-- do an extra slice at both ends
start = if start0 < slice then start0 else start0 - slice
end = end0 + slice
flat = flatten start t []
chopped0 = chop 0 start flat
chopped | start0 < slice = 0 : chopped0
| otherwise = chopped0
flatten :: Timestamp -> DurationTree -> [DurationTree] -> [DurationTree]
flatten _start DurationTreeEmpty rest = rest
flatten start t@(DurationSplit s split e l r _run _) rest
| e <= start = rest
| end <= s = rest
| start >= split = flatten start r rest
| end <= split = flatten start l rest
| e - s > slice = flatten start l $ flatten start r rest
| otherwise = t : rest
flatten _start t@(DurationTreeLeaf _) rest
= t : rest
chop :: Timestamp -> Timestamp -> [DurationTree] -> [Timestamp]
chop sofar start _ts
| start >= end = if sofar > 0 then [sofar] else []
chop sofar start []
= sofar : chop 0 (start+slice) []
chop sofar start (t : ts)
| e <= start
= if sofar /= 0
then error "chop"
else chop sofar start ts
| s >= start + slice
= sofar : chop 0 (start + slice) (t : ts)
| e > start + slice
= (sofar + time_in_this_slice t) : chop 0 (start + slice) (t : ts)
| otherwise
= chop (sofar + time_in_this_slice t) start ts
where
(s, e)
| DurationTreeLeaf ev <- t = (startTimeOf ev, endTimeOf ev)
| DurationSplit s _ e _ _ _run _ <- t = (s, e)
mi = min (start + slice) e
ma = max start s
duration = if mi < ma then 0 else mi - ma
time_in_this_slice t = case t of
DurationTreeLeaf ThreadRun{} -> duration
DurationTreeLeaf _ -> 0
DurationSplit _ _ _ _ _ run _ ->
round (fromIntegral (run * duration) / fromIntegral (e-s))
DurationTreeEmpty -> error "time_in_this_slice"
drawActivity :: HECs -> Timestamp -> Timestamp -> Timestamp -> [Timestamp]
-> Color
-> Render ()
drawActivity hecs start end slice ts color = do
case ts of
[] -> return ()
t:ts -> do
-- liftIO $ printf "ts: %s\n" (show (t:ts))
-- liftIO $ printf "off: %s\n" (show (map off (t:ts) :: [Double]))
let dstart = fromIntegral start
dend = fromIntegral end
dslice = fromIntegral slice
dheight = fromIntegral activityGraphHeight
-- funky gradients don't seem to work:
-- withLinearPattern 0 0 0 dheight $ \pattern -> do
-- patternAddColorStopRGB pattern 0 0.8 0.8 0.8
-- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0
-- rectangle dstart 0 dend dheight
-- setSource pattern
-- fill
newPath
moveTo (dstart-dslice/2) (off t)
zipWithM_ lineTo (tail [dstart-dslice/2, dstart+dslice/2 ..]) (map off ts)
setSourceRGBAhex black 1.0
setLineWidth 1
strokePreserve
lineTo dend dheight
lineTo dstart dheight
setSourceRGBAhex color 1.0
fill
-- funky gradients don't seem to work:
-- save
-- withLinearPattern 0 0 0 dheight $ \pattern -> do
-- patternAddColorStopRGB pattern 0 0 1.0 0
-- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0
-- setSource pattern
-- -- identityMatrix
-- -- setFillRule FillRuleEvenOdd
-- fillPreserve
-- restore
save
forM_ [0 .. hecCount hecs - 1] $ \h -> do
let y = fromIntegral (floor (fromIntegral h * dheight / fromIntegral (hecCount hecs))) - 0.5
setSourceRGBAhex black 0.3
moveTo dstart y
lineTo dend y
dashedLine1
restore
where
off t = fromIntegral activityGraphHeight -
fromIntegral (t * fromIntegral activityGraphHeight) /
fromIntegral (fromIntegral (hecCount hecs) * slice)
-- | Draw a dashed line along the current path.
dashedLine1 :: Render ()
dashedLine1 = do
save
identityMatrix
let dash = fromIntegral ox
setDash [dash, dash] 0.0
setLineWidth 1
stroke
restore
threadscope-0.2.2/GUI/Timeline/Motion.hs 0000644 0000000 0000000 00000012113 12044651254 016176 0 ustar 00 0000000 0000000 module GUI.Timeline.Motion (
zoomIn, zoomOut, zoomToFit,
scrollLeft, scrollRight, scrollToBeginning, scrollToEnd, scrollTo, centreOnCursor,
vscrollDown, vscrollUp,
) where
import GUI.Timeline.Types
import GUI.Timeline.Sparks
import Events.HECs
import Graphics.UI.Gtk
import Data.IORef
import Control.Monad
-- import Text.Printf
-- import Debug.Trace
-------------------------------------------------------------------------------
-- Zoom in works by expanding the current view such that the
-- left hand edge of the original view remains at the same
-- position and the zoom in factor is 2.
-- For example, zoom into the time range 1.0 3.0
-- produces a new view with the time range 1.0 2.0
zoomIn :: TimelineState -> Timestamp -> IO ()
zoomIn = zoom (/2)
zoomOut :: TimelineState -> Timestamp -> IO ()
zoomOut = zoom (*2)
zoom :: (Double -> Double) -> TimelineState -> Timestamp -> IO ()
zoom factor TimelineState{timelineAdj, scaleIORef} cursor = do
scaleValue <- readIORef scaleIORef
-- TODO: we'd need HECs, as below, to fit maxScale to graphs at hand
let maxScale = 10000000000 -- big enough for hours of eventlogs
clampedFactor =
if factor scaleValue < 0.2 || factor scaleValue > maxScale
then id
else factor
newScaleValue = clampedFactor scaleValue
writeIORef scaleIORef newScaleValue
hadj_value <- adjustmentGetValue timelineAdj
hadj_pagesize <- adjustmentGetPageSize timelineAdj -- Get size of bar
let newPageSize = clampedFactor hadj_pagesize
adjustmentSetPageSize timelineAdj newPageSize
let cursord = fromIntegral cursor
when (cursord >= hadj_value && cursord < hadj_value + hadj_pagesize) $
adjustmentSetValue timelineAdj $
cursord - clampedFactor (cursord - hadj_value)
let pageshift = 0.9 * newPageSize
let nudge = 0.1 * newPageSize
adjustmentSetStepIncrement timelineAdj nudge
adjustmentSetPageIncrement timelineAdj pageshift
-------------------------------------------------------------------------------
zoomToFit :: TimelineState -> Maybe HECs -> IO ()
zoomToFit TimelineState{scaleIORef, maxSpkIORef,timelineAdj,
timelineDrawingArea} mb_hecs = do
case mb_hecs of
Nothing -> return ()
Just hecs -> do
let lastTx = hecLastEventTime hecs
upper = fromIntegral lastTx
lower = 0
(w, _) <- widgetGetSize timelineDrawingArea
let newScaleValue = upper / fromIntegral w
(sliceAll, profAll) = treesProfile newScaleValue 0 lastTx hecs
-- TODO: verify that no empty lists possible below
maxmap l = maximum (0 : map (maxSparkRenderedValue sliceAll) l)
maxAll = map maxmap profAll
newMaxSpkValue = maximum (0 : maxAll)
writeIORef scaleIORef newScaleValue
writeIORef maxSpkIORef newMaxSpkValue
-- Configure the horizontal scrollbar units to correspond to micro-secs.
adjustmentSetLower timelineAdj lower
adjustmentSetValue timelineAdj lower
adjustmentSetUpper timelineAdj upper
adjustmentSetPageSize timelineAdj upper
-- TODO: this seems suspicious:
adjustmentSetStepIncrement timelineAdj 0
adjustmentSetPageIncrement timelineAdj 0
-------------------------------------------------------------------------------
scrollLeft, scrollRight, scrollToBeginning, scrollToEnd :: TimelineState -> IO ()
scrollLeft = scroll (\val page l _ -> l `max` (val - page/2))
scrollRight = scroll (\val page _ u -> (u - page) `min` (val + page/2))
scrollToBeginning = scroll (\_ _ l _ -> l)
scrollToEnd = scroll (\_ _ _ u -> u)
scrollTo :: TimelineState -> Double -> IO ()
scrollTo s x = scroll (\_ _ _ _ -> x) s
centreOnCursor :: TimelineState -> Timestamp -> IO ()
centreOnCursor state cursor =
scroll (\_ page l _u -> max l (fromIntegral cursor - page/2)) state
scroll :: (Double -> Double -> Double -> Double -> Double)
-> TimelineState -> IO ()
scroll adjust TimelineState{timelineAdj} = do
hadj_value <- adjustmentGetValue timelineAdj
hadj_pagesize <- adjustmentGetPageSize timelineAdj
hadj_lower <- adjustmentGetLower timelineAdj
hadj_upper <- adjustmentGetUpper timelineAdj
let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper
newValue' = max hadj_lower (min (hadj_upper - hadj_pagesize) newValue)
adjustmentSetValue timelineAdj newValue'
vscrollDown, vscrollUp :: TimelineState -> IO ()
vscrollDown = vscroll (\val page _l u -> (u - page) `min` (val + page/8))
vscrollUp = vscroll (\val page l _u -> l `max` (val - page/8))
vscroll :: (Double -> Double -> Double -> Double -> Double)
-> TimelineState -> IO ()
vscroll adjust TimelineState{timelineVAdj} = do
hadj_value <- adjustmentGetValue timelineVAdj
hadj_pagesize <- adjustmentGetPageSize timelineVAdj
hadj_lower <- adjustmentGetLower timelineVAdj
hadj_upper <- adjustmentGetUpper timelineVAdj
let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper
adjustmentSetValue timelineVAdj newValue
adjustmentValueChanged timelineVAdj
-- -----------------------------------------------------------------------------
threadscope-0.2.2/GUI/Timeline/HEC.hs 0000644 0000000 0000000 00000025251 12044651254 015337 0 ustar 00 0000000 0000000 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 qualified Data.IntMap as IM
import Data.Maybe
import Control.Monad
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 = time 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 = time 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 spec 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 = time 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 (spec event)
return True
-------------------------------------------------------------------------------
threadscope-0.2.2/GUI/Timeline/Sparks.hs 0000644 0000000 0000000 00000022514 12044651254 016202 0 ustar 00 0000000 0000000 module GUI.Timeline.Sparks (
treesProfile,
maxSparkRenderedValue,
renderSparkCreation,
renderSparkConversion,
renderSparkPool,
renderSparkHistogram,
) where
import GUI.Timeline.Render.Constants
import Events.HECs
import Events.SparkTree
import qualified Events.SparkStats as SparkStats
import GUI.Types
import GUI.ViewerColours
import GUI.Timeline.Ticks
import Graphics.Rendering.Cairo
import Control.Monad
-- Rendering sparks. No approximation nor extrapolation is going on here.
-- The sample data, recalculated for a given slice size in sparkProfile,
-- before these functions are called, is straightforwardly rendered.
maxSparkRenderedValue :: Timestamp -> SparkStats.SparkStats -> Double
maxSparkRenderedValue duration c =
max (SparkStats.rateDud c +
SparkStats.rateCreated c +
SparkStats.rateOverflowed c)
(SparkStats.rateFizzled c +
SparkStats.rateConverted c +
SparkStats.rateGCd c)
/ fromIntegral duration
spark_detail :: Int
spark_detail = 4 -- in pixels
treesProfile :: Double -> Timestamp -> Timestamp -> HECs
-> (Timestamp, [[SparkStats.SparkStats]])
treesProfile scale start end hecs =
let slice = ceiling (fromIntegral spark_detail * scale)
pr trees = let (_, _, stree) = trees
in sparkProfile slice start end stree
in (slice, map pr (hecTrees hecs))
renderSparkCreation :: ViewParameters -> Timestamp -> Timestamp -> Timestamp
-> [SparkStats.SparkStats]
-> Render ()
renderSparkCreation params !slice !start !end prof = do
let f1 c = SparkStats.rateCreated c
f2 c = f1 c + SparkStats.rateDud c
f3 c = f2 c + SparkStats.rateOverflowed c
renderSpark params slice start end prof
f1 createdConvertedColour f2 fizzledDudsColour f3 overflowedColour
renderSparkConversion :: ViewParameters -> Timestamp -> Timestamp -> Timestamp
-> [SparkStats.SparkStats]
-> Render ()
renderSparkConversion params !slice !start !end prof = do
let f1 c = SparkStats.rateConverted c
f2 c = f1 c + SparkStats.rateFizzled c
f3 c = f2 c + SparkStats.rateGCd c
renderSpark params slice start end prof
f1 createdConvertedColour f2 fizzledDudsColour f3 gcColour
renderSparkPool :: ViewParameters -> Timestamp -> Timestamp -> Timestamp
-> [SparkStats.SparkStats]
-> Double -> Render ()
renderSparkPool ViewParameters{..} !slice !start !end prof !maxSparkPool = do
let f1 c = SparkStats.minPool c
f2 c = SparkStats.meanPool c
f3 c = SparkStats.maxPool c
addSparks outerPercentilesColour maxSparkPool f1 f2 start slice prof
addSparks outerPercentilesColour maxSparkPool f2 f3 start slice prof
outlineSparks maxSparkPool f2 start slice prof
outlineSparks maxSparkPool (const 0) start slice prof
renderHRulers hecSparksHeight start end
renderSpark :: ViewParameters -> Timestamp -> Timestamp -> Timestamp
-> [SparkStats.SparkStats]
-> (SparkStats.SparkStats -> Double) -> Color
-> (SparkStats.SparkStats -> Double) -> Color
-> (SparkStats.SparkStats -> Double) -> Color
-> Render ()
renderSpark ViewParameters{..} slice start end prof f1 c1 f2 c2 f3 c3 = do
-- maxSpkValue is maximal spark transition rate, so
-- maxSliceSpark is maximal number of sparks per slice for current data.
let maxSliceSpark = maxSpkValue * fromIntegral slice
outlineSparks maxSliceSpark f3 start slice prof
addSparks c1 maxSliceSpark (const 0) f1 start slice prof
addSparks c2 maxSliceSpark f1 f2 start slice prof
addSparks c3 maxSliceSpark f2 f3 start slice prof
renderHRulers hecSparksHeight start end
off :: Double -> (SparkStats.SparkStats -> Double)
-> SparkStats.SparkStats
-> Double
off maxSliceSpark f t =
let clipped = min 1 (f t / maxSliceSpark)
in fromIntegral hecSparksHeight * (1 - clipped)
outlineSparks :: Double
-> (SparkStats.SparkStats -> Double)
-> Timestamp -> Timestamp
-> [SparkStats.SparkStats]
-> Render ()
outlineSparks maxSliceSpark f start slice ts = do
case ts of
[] -> return ()
ts -> do
let dstart = fromIntegral start
dslice = fromIntegral slice
points = [dstart-dslice/2, dstart+dslice/2 ..]
t = zip points (map (off maxSliceSpark f) ts)
newPath
moveTo (dstart-dslice/2) (snd $ head t)
mapM_ (uncurry lineTo) t
setSourceRGBAhex black 1.0
setLineWidth 1
stroke
addSparks :: Color
-> Double
-> (SparkStats.SparkStats -> Double)
-> (SparkStats.SparkStats -> Double)
-> Timestamp -> Timestamp
-> [SparkStats.SparkStats]
-> Render ()
addSparks colour maxSliceSpark f0 f1 start slice ts = do
case ts of
[] -> return ()
ts -> do
-- liftIO $ printf "ts: %s\n" (show (map f1 (ts)))
-- liftIO $ printf "off: %s\n"
-- (show (map (off maxSliceSpark f1) (ts) :: [Double]))
let dstart = fromIntegral start
dslice = fromIntegral slice
points = [dstart-dslice/2, dstart+dslice/2 ..]
t0 = zip points (map (off maxSliceSpark f0) ts)
t1 = zip points (map (off maxSliceSpark f1) ts)
newPath
moveTo (dstart-dslice/2) (snd $ head t1)
mapM_ (uncurry lineTo) t1
mapM_ (uncurry lineTo) (reverse t0)
setSourceRGBAhex colour 1.0
fill
-- | Render the spark duration histogram together with it's X scale and
-- horizontal and vertical rulers.
renderSparkHistogram :: ViewParameters -> HECs -> Render ()
renderSparkHistogram ViewParameters{..} hecs =
let intDoub :: Integral a => a -> Double
intDoub = fromIntegral
inR :: Timestamp -> Bool
inR = case minterval of
Nothing -> const True
Just (from, to) -> \ t -> t >= from && t <= to
-- TODO: if xs is sorted, we can slightly optimize the filtering
inRange :: [(Timestamp, Int, Timestamp)] -> [(Int, (Timestamp, Int))]
inRange xs = [(logdur, (dur, 1))
| (start, logdur, dur) <- xs, inR start]
xs = durHistogram hecs
bars :: [(Double, Double, Int)]
bars = [(intDoub t, intDoub height, count)
| (t, (height, count)) <- histogramCounts $ inRange xs]
-- TODO: data processing up to this point could be done only at interval
-- changes (keeping @bars@ in ViewParameters and in probably also in IOref.
-- The rest has to be recomputed at each redraw, because resizing
-- the window modifies the way the graph is drawn.
-- TODO: at least pull the above out into a separate function.
-- Define general parameters for visualization.
width' = width - 5 -- add a little margin on the right
(w, h) = (intDoub width', intDoub histogramHeight)
(minX, maxX, maxY) = (intDoub (minXHistogram hecs),
intDoub (maxXHistogram hecs),
intDoub (maxYHistogram hecs))
nBars = max 5 (maxX - minX + 1)
segmentWidth = w / nBars
-- Define parameters for drawing the bars.
gapWidth = 10
barWidth = segmentWidth - gapWidth
sX x = gapWidth / 2 + (x - minX) * segmentWidth
sY y = y * h / (max 2 maxY)
plotRect (x, y, count) = do
-- Draw a single bar.
setSourceRGBAhex blue 1.0
rectangle (sX x) (sY maxY) barWidth (sY (-y))
fillPreserve
setSourceRGBA 0 0 0 0.7
setLineWidth 1
stroke
-- Print the number of sparks in the bar.
selectFontFace "sans serif" FontSlantNormal FontWeightNormal
setFontSize 10
let above = sY (-y) > -20
if above
then setSourceRGBAhex black 1.0
else setSourceRGBAhex white 1.0
moveTo (sX x + 3) (sY (maxY - y) + if above then -3 else 13)
showText (show count)
drawHist = forM_ bars plotRect
-- Define parameters for X scale.
off y = 16 - y
xScaleMode = XScaleLog minX segmentWidth
drawXScale = renderXScale 1 0 maxBound width' off xScaleMode
-- Define parameters for vertical rulers.
nB = round nBars
mult | nB <= 7 = 1
| nB `mod` 5 == 0 = 5
| nB `mod` 4 == 0 = 4
| nB `mod` 3 == 0 = 3
| nB `mod` 2 == 0 = nB `div` 2
| otherwise = nB
drawVRulers = renderVRulers 1 0 (fromIntegral width') histogramHeight
(XScaleLog undefined (segmentWidth * fromIntegral mult))
-- Define the horizontal rulers call.
drawHRulers = renderHRulers histogramHeight 0 (fromIntegral width')
in do
-- Start the drawing by wiping out timeline vertical rules
-- (for PNG/PDF that require clear, transparent background)
save
translate hadjValue 0
scale scaleValue 1
rectangle 0 (fromIntegral $ - tracePad) (fromIntegral width)
(fromIntegral $ histogramHeight + histXScaleHeight + 2 * tracePad)
setSourceRGBAhex white 1
op <- getOperator
setOperator OperatorAtop -- TODO: fixme: it paints white vertical rulers
fill
setOperator op
-- Draw the bars.
drawHist
-- Draw the rulers on top of the bars (they are partially transparent).
drawVRulers
drawHRulers
-- Move to the bottom and draw the X scale. The Y scale is drawn
-- independetly in another drawing area.
translate 0 (fromIntegral histogramHeight)
drawXScale
restore
threadscope-0.2.2/GUI/Timeline/Types.hs 0000644 0000000 0000000 00000002223 12044651254 016036 0 ustar 00 0000000 0000000 module GUI.Timeline.Types (
TimelineState(..),
TimeSelection(..),
) where
import GUI.Types
import Graphics.UI.Gtk
import Graphics.Rendering.Cairo
import Data.IORef
-----------------------------------------------------------------------------
data TimelineState = TimelineState {
timelineDrawingArea :: DrawingArea,
timelineYScaleArea :: DrawingArea,
timelineXScaleArea :: DrawingArea,
timelineAdj :: Adjustment,
timelineVAdj :: Adjustment,
timelinePrevView :: IORef (Maybe (ViewParameters, Surface)),
-- This scale value is used to map a micro-second value to a pixel unit.
-- To convert a timestamp value to a pixel value, multiply it by scale.
-- To convert a pixel value to a micro-second value, divide it by scale.
scaleIORef :: IORef Double,
-- Maximal number of sparks/slice measured after every zoom to fit.
maxSpkIORef :: IORef Double
}
data TimeSelection = PointSelection Timestamp
| RangeSelection Timestamp Timestamp
-----------------------------------------------------------------------------
threadscope-0.2.2/GUI/Timeline/Ticks.hs 0000644 0000000 0000000 00000026522 12044651254 016017 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
module GUI.Timeline.Ticks (
renderVRulers,
XScaleMode(..),
renderXScaleArea,
renderXScale,
renderHRulers,
renderYScale,
mu,
deZero,
) where
import Events.HECs
import GUI.Types
import GUI.Timeline.CairoDrawing
import GUI.ViewerColours
import Graphics.Rendering.Cairo
import Control.Monad
import Text.Printf
-- Minor, semi-major and major ticks are drawn and the absolute period of
-- the ticks is determined by the zoom level.
-- There are ten minor ticks to a major tick and a semi-major tick
-- occurs half way through a major tick (overlapping the corresponding
-- minor tick).
-- The timestamp values are in micro-seconds (1e-6) i.e.
-- a timestamp value of 1000000 represents 1s. The position on the drawing
-- canvas is in milliseconds (ms) (1e-3).
-- scaleValue is used to divide a timestamp value to yield a pixel value.
-- NOTE: the code below will crash if the timestampFor100Pixels is 0.
-- The zoom factor should be controlled to ensure that this never happens.
-- | Render vertical rulers (solid translucent lines), matching scale ticks.
renderVRulers :: Double -> Timestamp -> Timestamp -> Int -> XScaleMode
-> Render()
renderVRulers scaleValue startPos endPos height xScaleMode = do
let timestampFor100Pixels = truncate (100 * scaleValue)
snappedTickDuration :: Timestamp
snappedTickDuration =
10 ^ max 0 (truncate (logBase 10 (fromIntegral timestampFor100Pixels)
:: Double))
tickWidthInPixels :: Double
tickWidthInPixels = fromIntegral snappedTickDuration / scaleValue
firstTick :: Timestamp
firstTick = snappedTickDuration * (startPos `div` snappedTickDuration)
setSourceRGBAhex black 0.15
setLineWidth scaleValue
case xScaleMode of
XScaleTime ->
drawVRulers tickWidthInPixels scaleValue
(fromIntegral $ firstTick + snappedTickDuration)
(fromIntegral snappedTickDuration) endPos height
(1 + fromIntegral (startPos `div` snappedTickDuration))
XScaleLog _ dx ->
drawVRulers 1e1000 1 dx dx endPos height 1
-- | Render a single vertical ruler and then recurse.
drawVRulers :: Double -> Double -> Double -> Double
-> Timestamp -> Int -> Int -> Render ()
drawVRulers tickWidthInPixels scaleValue pos incr endPos height i =
if floor pos <= endPos then do
when (atMajorTick || atMidTick || tickWidthInPixels > 70) $ do
draw_line (veryRoundedPos, 0) (veryRoundedPos, height)
drawVRulers
tickWidthInPixels scaleValue (pos + incr) incr endPos height (i + 1)
else
return ()
where
-- Hack to sync with drawXTicks.
veryRoundedPos = round $
scaleValue * fromIntegral (floor (fromIntegral (round pos) / scaleValue))
atMidTick = i `mod` 5 == 0
atMajorTick = i `mod` 10 == 0
-- | Render the X scale, based on view parameters and hecs.
renderXScaleArea :: ViewParameters -> HECs -> Render ()
renderXScaleArea ViewParameters{width, scaleValue, hadjValue, xScaleAreaHeight}
hecs =
let lastTx = hecLastEventTime hecs
off y = y + xScaleAreaHeight - 17
in renderXScale scaleValue hadjValue lastTx width off XScaleTime
data XScaleMode = XScaleTime | XScaleLog Double Double deriving Eq
-- | Render the X (vertical) scale: render X axis and call ticks rendering.
-- TODO: refactor common parts with renderVRulers, in particlar to expose
-- that ruler positions match tick positions.
renderXScale :: Double -> Double -> Timestamp -> Int
-> (Int -> Int) -> XScaleMode
-> Render ()
renderXScale scaleValue hadjValue lastTx width off xScaleMode = do
let scale_width = fromIntegral width * scaleValue
startPos :: Timestamp
startPos = floor hadjValue
startLine :: Timestamp
startLine = floor $ hadjValue / scaleValue
endPos :: Timestamp
endPos = ceiling $ min (hadjValue + scale_width) (fromIntegral lastTx)
endLine :: Timestamp
endLine = ceiling $ min (hadjValue + scale_width) (fromIntegral lastTx)
/ scaleValue
save
translate (- fromIntegral startLine) 0
selectFontFace "sans serif" FontSlantNormal FontWeightNormal
setFontSize 12
setSourceRGBAhex black 1.0
-- setLineCap LineCapRound -- TODO: breaks rendering currently (see BrokenX.png)
setLineWidth 1.0
draw_line (startLine, off 16) (endLine, off 16)
let tFor100Pixels = truncate (100 * scaleValue)
snappedTickDuration :: Timestamp
snappedTickDuration =
10 ^ max 0 (truncate (logBase 10 (fromIntegral tFor100Pixels)
:: Double))
tickWidthInPixels :: Double
tickWidthInPixels = fromIntegral snappedTickDuration / scaleValue
firstTick :: Timestamp
firstTick = snappedTickDuration * (startPos `div` snappedTickDuration)
case xScaleMode of
XScaleTime ->
drawXTicks tickWidthInPixels scaleValue (fromIntegral firstTick)
(fromIntegral snappedTickDuration) endPos off xScaleMode
(fromIntegral (startPos `div` snappedTickDuration))
XScaleLog _ segmentWidth ->
drawXTicks 1e1000 1 0 segmentWidth endPos off xScaleMode 0
restore
-- | Render a single X scale tick and then recurse.
drawXTicks :: Double -> Double -> Double -> Double -> Timestamp
-> (Int -> Int) -> XScaleMode -> Int
-> Render ()
drawXTicks tickWidthInPixels scaleValue pos incr endPos off xScaleMode i =
if floor pos <= endPos then do
when (pos /= 0 || xScaleMode == XScaleTime) $
draw_line (floor $ fromIntegral x1 / scaleValue, off 16)
(floor $ fromIntegral x1 / scaleValue, off (16 - tickLength))
when (atMajorTick || atMidTick || tickWidthInPixels > 70) $ do
tExtent <- textExtents tickTimeText
let tExtentWidth = textExtentsWidth tExtent
move_to (floor $ fromIntegral textPosX / scaleValue, textPosY)
when (floor (pos + incr) <= endPos
&& (tExtentWidth + tExtentWidth / 3 < width || atMajorTick)) $
showText tickTimeText
drawXTicks
tickWidthInPixels scaleValue (pos + incr) incr endPos off xScaleMode (i+1)
else
return ()
where
atMidTick = xScaleMode == XScaleTime && i `mod` 5 == 0
atMajorTick = xScaleMode == XScaleTime && i `mod` 10 == 0
(textPosX, textPosY) =
if xScaleMode == XScaleTime
then (x1 + ceiling (scaleValue * 3), off (-3))
else (x1 + ceiling (scaleValue * 2), tickLength + 13)
tickLength | atMajorTick = 16
| atMidTick = 10
| otherwise = if xScaleMode == XScaleTime then 6 else 8
posTime = case xScaleMode of
XScaleTime -> round pos
XScaleLog minX _ -> round $ 2 ** (minX + pos / incr)
tickTimeText = showMultiTime posTime
width = if atMidTick then 5 * tickWidthInPixels
else tickWidthInPixels
-- We cheat at pos 0, to avoid half covering the tick by the grey label area.
lineWidth = scaleValue
x1 = round $ if pos == 0 && xScaleMode == XScaleTime then lineWidth else pos
-- | Display the micro-second time unit with an appropriate suffix
-- depending on the actual time value.
-- For times < 1e-6 the time is shown in micro-seconds.
-- For times >= 1e-6 and < 0.1 seconds the time is shown in ms
-- For times >= 0.5 seconds the time is shown in seconds
showMultiTime :: Timestamp -> String
showMultiTime pos =
if pos == 0 then "0s"
else if pos < 1000 then -- Show time as micro-seconds for times < 1e-6
reformatMS posf ++ (mu ++ "s") -- microsecond (1e-6s).
else if pos < 100000 then -- Show miliseonds for time < 0.1s
reformatMS (posf / 1000) ++ "ms" -- miliseconds 1e-3
else -- Show time in seconds
reformatMS (posf / 1000000) ++ "s"
where
posf :: Double
posf = fromIntegral pos
reformatMS :: Show a => a -> String
reformatMS pos = deZero (show pos)
-------------------------------------------------------------------------------
-- | Render horizontal rulers (dashed translucent lines),
-- matching scale ticks (visible in the common @incr@ value and starting at 0).
renderHRulers :: Int -> Timestamp -> Timestamp -> Render ()
renderHRulers hecSparksHeight start end = do
let dstart = fromIntegral start
dend = fromIntegral end
incr = fromIntegral hecSparksHeight / 10
-- dashed lines across the graphs
setSourceRGBAhex black 0.15
setLineWidth 1
save
forM_ [0, 5] $ \h -> do
let y = h * incr
moveTo dstart y
lineTo dend y
stroke
restore
-- | Render one of the Y (horizontal) scales: render the Y axis
-- and call ticks rendering.
renderYScale :: Int -> Double -> Double -> Double -> Double -> Render ()
renderYScale hecSparksHeight scaleValue maxSpark xoffset yoffset = do
let -- This is slightly off (by 1% at most), but often avoids decimal dot:
maxS = if maxSpark < 100
then maxSpark -- too small, would be visible on screen
else fromIntegral (2 * (ceiling maxSpark ` div` 2))
incr = fromIntegral hecSparksHeight / 10
save
newPath
moveTo (xoffset + 12) yoffset
lineTo (xoffset + 12) (yoffset + fromIntegral hecSparksHeight)
setSourceRGBAhex black 1.0
setLineCap LineCapRound
setLineWidth 1.0 -- TODO: it's not really 1 pixel, due to the scale
stroke
selectFontFace "sans serif" FontSlantNormal FontWeightNormal
setFontSize 12
scale scaleValue 1.0
setLineWidth 0.5 -- TODO: it's not really 0.5 pixels, due to the scale
drawYTicks maxS 0 incr xoffset yoffset 0
restore
-- | Render a single Y scale tick and then recurse.
drawYTicks :: Double -> Double -> Double -> Double -> Double -> Int -> Render ()
drawYTicks maxS pos incr xoffset yoffset i =
if i <= 10 then do
-- TODO: snap to pixels, currently looks semi-transparent
moveTo (xoffset + 12) (yoffset + majorTick - pos)
lineTo (xoffset + 12 - tickLength) (yoffset + majorTick - pos)
stroke
when (atMajorTick || atMidTick) $ do
tExtent <- textExtents tickText
(fewPixels, yPix) <- deviceToUserDistance 3 4
moveTo (xoffset - textExtentsWidth tExtent - fewPixels)
(yoffset + majorTick - pos + yPix)
when (atMidTick || atMajorTick) $
showText tickText
drawYTicks maxS (pos + incr) incr xoffset yoffset (i + 1)
else
return ()
where
atMidTick = i `mod` 5 == 0
atMajorTick = i `mod` 10 == 0
majorTick = 10 * incr
tickText = reformatV (fromIntegral i * maxS / 10)
tickLength | atMajorTick = 11
| atMidTick = 9
| otherwise = 6
reformatV :: Double -> String
reformatV v =
if v < 0.01 && v > 0
then eps
else deZero (printf "%.2f" v)
-------------------------------------------------------------------------------
-- | The \'micro\' symbol.
mu :: String
#if MIN_VERSION_cairo(0,12,0) && !MIN_VERSION_cairo(0,12,1)
-- this version of cairo doesn't handle Unicode properly.
-- Thus, we do the encoding by hand:
mu = "\194\181"
#else
-- Haskell cairo bindings 0.12.1 have proper Unicode support
mu = "\x00b5"
#endif
-- | The \'epsilon\' symbol.
eps :: String
#if MIN_VERSION_cairo(0,12,0) && !MIN_VERSION_cairo(0,12,1)
-- this version of cairo doesn't handle Unicode properly.
-- Thus, we do the encoding by hand:
eps = "\206\181"
#else
-- Haskell cairo bindings 0.12.1 have proper Unicode support
eps = "\x03b5"
#endif
-- | Remove all meaningless trailing zeroes.
deZero :: String -> String
deZero s
| '.' `elem` s =
reverse . dropWhile (=='.') . dropWhile (=='0') . reverse $ s
| otherwise = s
threadscope-0.2.2/GUI/Timeline/Render/ 0000755 0000000 0000000 00000000000 12044651254 015616 5 ustar 00 0000000 0000000 threadscope-0.2.2/GUI/Timeline/Render/Constants.hs 0000644 0000000 0000000 00000002607 12044651254 020133 0 ustar 00 0000000 0000000 module GUI.Timeline.Render.Constants (
ox, firstTraceY, tracePad,
hecTraceHeight, hecInstantHeight, hecSparksHeight,
hecBarOff, hecBarHeight, hecLabelExtra,
activityGraphHeight, stdHistogramHeight, histXScaleHeight,
ticksHeight, ticksPad
) where
-------------------------------------------------------------------------------
-- The standard gap in various graphs
ox :: Int
ox = 10
-- Origin for traces
firstTraceY :: Int
firstTraceY = 13
-- Gap betweem traces in the timeline view
tracePad :: Int
tracePad = 20
-- HEC bar height
hecTraceHeight, hecInstantHeight, hecBarHeight, hecBarOff, hecLabelExtra :: Int
hecTraceHeight = 40
hecInstantHeight = 25
hecBarHeight = 20
hecBarOff = 10
-- extra space to allow between HECs when labels are on.
-- ToDo: should be calculated somehow
hecLabelExtra = 80
-- Activity graph
activityGraphHeight :: Int
activityGraphHeight = 100
-- Height of the spark graphs.
hecSparksHeight :: Int
hecSparksHeight = activityGraphHeight
-- Histogram graph height when displayed with other traces (e.g., in PNG/PDF).
stdHistogramHeight :: Int
stdHistogramHeight = hecSparksHeight
-- The X scale of histogram has this constant height, as opposed
-- to the timeline X scale, which takes its height from the .ui file.
histXScaleHeight :: Int
histXScaleHeight = 30
-- Ticks
ticksHeight :: Int
ticksHeight = 20
ticksPad :: Int
ticksPad = 20