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)