diff --git a/GHC/RTS/Events.hs b/GHC/RTS/Events.hs new file mode 100644 --- /dev/null +++ b/GHC/RTS/Events.hs @@ -0,0 +1,398 @@ +{-# LANGUAGE CPP,BangPatterns,PatternGuards #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +{- + - Author: Donnie Jones, Simon Marlow + - Events.hs + - Parser functions for GHC RTS EventLog framework. + -} + +module GHC.RTS.Events ( + -- * The event log types + EventLog(..), + EventType(..), + Event(..), + EventTypeSpecificInfo(..), + ThreadStopStatus(..), + Header(..), + Data(..), + Timestamp, + ThreadId, + -- * Reading an event log from a file + readEventLogFromFile, + -- * Utilities + CapEvent(..), sortEvents, groupEvents + ) where + +{- Libraries. -} +import Data.Word (Word16, Word32, Word64) +import Data.Binary +import Data.Binary.Get +import Control.Monad +import Data.IntMap (IntMap) +import qualified Data.IntMap as M +import Control.Monad.Reader +import Control.Monad.Error +import qualified Data.ByteString.Lazy as L +import Data.Char +import Data.Function +import Data.List +import Data.Either + +#define EVENTLOG_CONSTANTS_ONLY +#include "EventLogFormat.h" + +{- Type synonyms. -} +type Filename = String + +-- EventType. +type EventTypeNum = Word16 +type EventTypeDescLen = Word32 +type EventTypeDesc = String +type EventTypeSize = Word16 +-- Event. +type EventDescription = String +type Timestamp = Word64 +type ThreadId = Word32 +type CapNo = Word16 +type Marker = Word32 + +{- + - Data type delcarations to build the GHC RTS data format, + - which is a (header, data) pair. + - + - Header contains EventTypes. + - Data contains Events. + -} +data EventLog = + EventLog { + header :: Header, + dat :: Data + } deriving Show + +newtype Header = Header { + eventTypes :: [EventType] + } deriving Show + +data Data = Data { + events :: [Event] + } deriving Show + +data EventType = + EventType { + num :: EventTypeNum, + desc :: EventTypeDesc, + size :: Maybe EventTypeSize -- ^ 'Nothing' indicates variable size + } deriving Show + +data Event = + Event { + ref :: {-# UNPACK #-}!EventTypeNum, + time :: {-# UNPACK #-}!Timestamp, + spec :: EventTypeSpecificInfo + } deriving Show + +data EventTypeSpecificInfo + = Startup { n_caps :: Int + } + | EventBlock { end_time :: Timestamp, + cap :: Int, + block_events :: [Event] + } + | CreateThread { thread :: {-# UNPACK #-}!ThreadId + } + | RunThread { thread :: {-# UNPACK #-}!ThreadId + } + | StopThread { thread :: {-# UNPACK #-}!ThreadId, + status :: ThreadStopStatus + } + | ThreadRunnable { thread :: {-# UNPACK #-}!ThreadId + } + | MigrateThread { thread :: {-# UNPACK #-}!ThreadId, + newCap :: {-# UNPACK #-}!Int + } + | RunSpark { thread :: {-# UNPACK #-}!ThreadId + } + | StealSpark { thread :: {-# UNPACK #-}!ThreadId, + victimCap :: {-# UNPACK #-}!Int + } + | CreateSparkThread { sparkThread :: {-# UNPACK #-}!ThreadId + } + | WakeupThread { thread :: {-# UNPACK #-}!ThreadId, + otherCap :: {-# UNPACK #-}!Int + } + | Shutdown { } + | RequestSeqGC { } + | RequestParGC { } + | StartGC { } + | EndGC { } + | Message { msg :: String } + | UnknownEvent + deriving Show + +--sync with ghc/includes/Constants.h +data ThreadStopStatus + = NoStatus + | HeapOverflow + | StackOverflow + | ThreadYielding + | ThreadBlocked + | ThreadFinished + | ForeignCall + deriving (Enum, Show) + +-- reader/Get monad that passes around the event types +type GetEvents a = ReaderT (IntMap EventType) (ErrorT String Get) a + +type GetHeader a = ErrorT String Get a + +getH :: Binary a => GetHeader a +getH = lift get + +getE :: Binary a => GetEvents a +getE = lift $ lift get + +------------------------------------------------------------------------------ +-- Binary instances + +getEventType :: GetHeader EventType +getEventType = do + etNum <- getH + size <- getH :: GetHeader EventTypeSize + let etSize = if size == 0xffff then Nothing else Just size + -- 0xffff indicates variable-sized event + etDescLen <- getH :: GetHeader EventTypeDescLen + etDesc <- getEtDesc (fromIntegral etDescLen) + etExtraLen <- getH :: GetHeader Word32 + _skip <- replicateM_ (fromIntegral etExtraLen) (lift getWord8) + ete <- getH :: GetHeader Marker + when (ete /= EVENT_ET_END) $ + throwError ("Event Type end marker not found.") + return (EventType etNum etDesc etSize) + where + getEtDesc :: Int -> GetHeader [Char] + getEtDesc s = replicateM s (getH :: GetHeader Char) + +getHeader :: GetHeader Header +getHeader = do + hdrb <- getH :: GetHeader Marker + when (hdrb /= EVENT_HEADER_BEGIN) $ + throwError "Header begin marker not found" + hetm <- getH :: GetHeader Marker + when (hetm /= EVENT_HET_BEGIN) $ + throwError "Header Event Type begin marker not found" + ets <- getEventTypes + emark <- getH :: GetHeader Marker + when (emark /= EVENT_HEADER_END) $ + throwError "Header end marker not found" + return (Header ets) + where + getEventTypes :: GetHeader [EventType] + getEventTypes = do + m <- getH :: GetHeader Marker + case () of + _ | m == EVENT_ET_BEGIN -> do + et <- getEventType + nextET <- getEventTypes + return (et : nextET) + | m == EVENT_HET_END -> + return [] + | otherwise -> + throwError "Malformed list of Event Types in header" + +getEvent :: GetEvents (Maybe Event) +getEvent = do + etRef <- getE + if (etRef == EVENT_DATA_END) + then return Nothing + else do !ts <- getE + spec <- getEvSpecInfo etRef + return (Just (Event etRef ts spec)) + +getEvSpecInfo :: EventTypeNum -> GetEvents EventTypeSpecificInfo +getEvSpecInfo num = case fromIntegral num :: Int of + + EVENT_STARTUP -> do -- (n_caps) + c <- getE :: GetEvents CapNo + return Startup{ n_caps = fromIntegral c } + + EVENT_BLOCK_MARKER -> do -- (size, end_time, cap) + block_size <- getE :: GetEvents Word32 + end_time <- getE :: GetEvents Timestamp + c <- getE :: GetEvents CapNo + lbs <- lift . lift $ getLazyByteString (fromIntegral block_size - 24) + etypemap <- ask + let e_events = runGet (runErrorT $ runReaderT getEventBlock etypemap) lbs + return EventBlock{ end_time=end_time, + cap= fromIntegral c, + block_events=case e_events of + Left s -> error s + Right es -> es } + + EVENT_CREATE_THREAD -> do -- (thread) + t <- getE + return CreateThread{thread=t} + + EVENT_RUN_THREAD -> do -- (thread) + t <- getE + return RunThread{thread=t} + + EVENT_STOP_THREAD -> do -- (thread, status) + t <- getE + s <- getE :: GetEvents Word16 + return StopThread{thread=t, status= toEnum (fromIntegral s)} + + EVENT_THREAD_RUNNABLE -> do -- (thread) + t <- getE + return ThreadRunnable{thread=t} + + EVENT_MIGRATE_THREAD -> do -- (thread, newCap) + t <- getE + nc <- getE :: GetEvents CapNo + return MigrateThread{thread=t,newCap=fromIntegral nc} + + EVENT_RUN_SPARK -> do -- (thread) + t <- getE + return RunSpark{thread=t} + + EVENT_STEAL_SPARK -> do -- (thread, victimCap) + t <- getE + vc <- getE :: GetEvents CapNo + return StealSpark{thread=t,victimCap=fromIntegral vc} + + EVENT_CREATE_SPARK_THREAD -> do -- (sparkThread) + st <- getE :: GetEvents ThreadId + return CreateSparkThread{sparkThread=st} + + EVENT_SHUTDOWN -> return Shutdown + + EVENT_THREAD_WAKEUP -> do -- (thread, other_cap) + t <- getE + oc <- getE :: GetEvents CapNo + return WakeupThread{thread=t,otherCap=fromIntegral oc} + + EVENT_REQUEST_SEQ_GC -> return RequestSeqGC + + EVENT_REQUEST_PAR_GC -> return RequestParGC + + EVENT_GC_START -> return StartGC + + EVENT_GC_END -> return EndGC + + EVENT_LOG_MSG -> do -- (msg) + num <- getE :: GetEvents Word16 + bytes <- replicateM (fromIntegral num) getE + return Message{ msg = map (chr . fromIntegral) (bytes :: [Word8]) } + + other -> do -- unrecognised event, just skip it + etypes <- ask + case M.lookup (fromIntegral other) etypes of + Nothing -> throwError ("getEvSpecInfo: undeclared event type: " ++ show other) + Just t -> do + bytes <- case size t of + Just n -> return n + Nothing -> getE :: GetEvents Word16 + skip <- lift . lift $ replicateM_ (fromIntegral bytes) getWord8 + return UnknownEvent + + +getData :: GetEvents Data +getData = do + db <- getE :: GetEvents Marker + when (db /= EVENT_DATA_BEGIN) $ throwError "Data begin marker not found" + getEvents [] + where + getEvents :: [Event] -> GetEvents Data + getEvents events = do + mb_e <- getEvent + case mb_e of + Nothing -> return (Data events) + Just e -> getEvents (e:events) + +getEventBlock :: GetEvents [Event] +getEventBlock = do + b <- lift . lift $ isEmpty + if b then return [] else do + mb_e <- getEvent + case mb_e of + Nothing -> return [] + Just e -> do + es <- getEventBlock + return (e:es) + +getEventLog :: ErrorT String Get EventLog +getEventLog = do + header <- getHeader + let imap = M.fromList [ (fromIntegral (num t),t) | t <- eventTypes header] + dat <- runReaderT getData imap + return (EventLog header dat) + +readEventLogFromFile :: FilePath -> IO (Either String EventLog) +readEventLogFromFile f = do + s <- L.readFile f + return $ runGet (do v <- runErrorT $ getEventLog + m <- isEmpty + m `seq` return v) s + +-- ----------------------------------------------------------------------------- +-- Utilities + +-- | An event annotated with the Capability that generated it, if any +data CapEvent + = CapEvent { ce_cap :: Maybe Int, + ce_event :: Event + } + +-- | Sort the raw event stream by time, annotating each event with the +-- capability that generated it. +sortEvents :: [Event] -> [CapEvent] +sortEvents raw = mergesort' (compare `on` (time . ce_event)) $ + [ map (CapEvent cap) es | (cap, es) <- groupEvents raw ] + -- sorting is made much faster by the way that the event stream is + -- divided into blocks of events. + -- - All events in a block belong to a particular capability + -- - The events in a block are ordered by time + -- - blocks for the same capability appear in time order in the event + -- stream and do not overlap. + -- + -- So to sort the events we make one list of events for each + -- capability (basically just concat . filter), and then + -- merge the resulting lists. + +groupEvents :: [Event] -> [(Maybe Int, [Event])] +groupEvents es = (Nothing, n_events) : + [ (Just (cap (head blocks)), concat (map block_events blocks)) + | blocks <- groups ] + where + (blocks, anon_events) = partitionEithers (map separate es) + where separate e | b@EventBlock{} <- spec e = Left b + | otherwise = Right e + + (cap_blocks, gbl_blocks) = partition (is_cap . cap) blocks + where is_cap c = fromIntegral c /= ((-1) :: Word16) + + groups = groupBy ((==) `on` cap) $ sortBy (compare `on` cap) cap_blocks + + -- There are two sources of events without a capability: events + -- in the raw stream not inside an EventBlock, and EventBlocks + -- with cap == -1. We have to merge those two streams. + n_events = merge (compare `on` time) anon_events + (concatMap block_events gbl_blocks) + +mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a] +mergesort' _ [] = [] +mergesort' _ [xs] = xs +mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss) + +merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]] +merge_pairs _ [] = [] +merge_pairs _ [xs] = [xs] +merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss + +merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +merge _ [] ys = ys +merge _ xs [] = xs +merge cmp (x:xs) (y:ys) + = case x `cmp` y of + GT -> y : merge cmp (x:xs) ys + _ -> x : merge cmp xs (y:ys) + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +The Glasgow Haskell Compiler License + +Copyright 2002, The University Court of the University of Glasgow. +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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/ShowGhcEvents.hs b/ShowGhcEvents.hs new file mode 100644 --- /dev/null +++ b/ShowGhcEvents.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE RecordWildCards #-} +module Main where + +import GHC.RTS.Events as Log +import System.Environment +import Text.Printf +import Data.List +import Data.Function +import Data.IntMap (IntMap) +import qualified Data.IntMap as M +import Data.Maybe +import System.IO +import System.Exit + +main = do + [file] <- getArgs + + log <- do e <- readEventLogFromFile file + case e of + Left s -> die ("Failed to parse " ++ file ++ ": " ++ s) + Right log -> return log + + printf "Event Types:\n" + let etypes = Log.eventTypes (Log.header log) + putStrLn (unlines (map ppEventType etypes)) + + let imap = M.fromList [ (fromIntegral (Log.num t),t) | t <- etypes ] + + let pes = Log.events (Log.dat log) + sorted = sortEvents (reverse pes) + -- the events come out reversed, and we want a stable sort + + printf "Events:\n" + putStrLn $ unlines $ map (ppEvent imap) $ sorted +-- putStrLn $ show $ length $ sorted + +unsortEvents :: [Event] -> [(Int,Event)] +unsortEvents es = ess + where + blocks = [ b | b@EventBlock{} <- map spec es ] + ess = [ (cap block, e) | block <- blocks, e <- block_events block ] + +die s = do hPutStrLn stderr s; exitWith (ExitFailure 1) + +ppEventType :: EventType -> String +ppEventType et = printf "%4d: %s (size %s)" (Log.num et) (Log.desc et) + (case Log.size et of Nothing -> "variable"; Just x -> show x) + +ppEvent :: IntMap EventType -> CapEvent -> String +ppEvent imap (CapEvent cap (Event ref time spec)) = + printf "%9d: " time ++ + (case cap of + Nothing -> "" + Just c -> printf "cap %d: " c) ++ + case spec of + UnknownEvent -> + printf (Log.desc (fromJust (M.lookup (fromIntegral ref) imap))) + + Message msg -> msg + + other -> + case spec of + Startup n_caps -> + printf "startup: %d capabilities" n_caps + EventBlock end_time cap block_events -> + printf "event block: cap %d, end time: %d\n" cap end_time + CreateThread thread -> + printf "creating thread %d" thread + RunThread thread -> + printf "running thread %d" thread + StopThread thread status -> + printf "stopping thread %d (%s)" thread (showThreadStopStatus status) + ThreadRunnable thread -> + printf "thread %d is runnable" thread + MigrateThread thread newCap -> + printf "migrating thread %d to cap %d" thread newCap + RunSpark thread -> + printf "running a local spark (thread %d)" thread + StealSpark thread victimCap -> + printf "thread %d stealing a spark from cap %d" thread victimCap + CreateSparkThread sparkThread -> + printf "creating spark thread %d" sparkThread + Shutdown -> + printf "shutting down" + WakeupThread thread otherCap -> + printf "waking up thread %d on cap %d" thread otherCap + RequestSeqGC -> + printf "requesting sequential GC" + RequestParGC -> + printf "requesting parallel GC" + StartGC -> + printf "starting GC" + EndGC -> + printf "finished GC" + +showThreadStopStatus :: ThreadStopStatus -> String +showThreadStopStatus HeapOverflow = "heap overflow" +showThreadStopStatus StackOverflow = "stack overflow" +showThreadStopStatus ThreadYielding = "thread yielding" +showThreadStopStatus ThreadBlocked = "thread blocked" +showThreadStopStatus ThreadFinished = "thread finished" +showThreadStopStatus ForeignCall = "making a foreign call" diff --git a/ghc-events.cabal b/ghc-events.cabal new file mode 100644 --- /dev/null +++ b/ghc-events.cabal @@ -0,0 +1,28 @@ +name: ghc-events +version: 0.0.1 +synopsis: Library and tool for parsing .eventlog files from GHC +description: Parses .eventlog files emitted by GHC 6.12.1 and later. + Includes the show-ghc-events tool to dump an event + log file as text. +category: Development, GHC, Debug, Profiling, Trace +license: BSD3 +license-file: LICENSE +author: Donnie Jones , + Simon Marlow +maintainer: Simon Marlow +build-type: Simple +tested-with: GHC == 6.10.2, GHC == 6.11.20090221 +cabal-version: >= 1.6 + +library { + build-depends: base == 4.*, + mtl == 1.1.*, + containers == 0.2.*, + binary == 0.5.*, + bytestring == 0.9.* + exposed-modules: GHC.RTS.Events +} + +executable show-ghc-events { + main-is: ShowGhcEvents.hs +}