ghc-events (empty) → 0.0.1
raw patch · 5 files changed
+563/−0 lines, 5 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, containers, mtl
Files
- GHC/RTS/Events.hs +398/−0
- LICENSE +31/−0
- Setup.lhs +4/−0
- ShowGhcEvents.hs +102/−0
- ghc-events.cabal +28/−0
+ GHC/RTS/Events.hs view
@@ -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)+
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ ShowGhcEvents.hs view
@@ -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"
+ ghc-events.cabal view
@@ -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 <donnie@darthik.com>, + Simon Marlow <marlowsd@gmail.com>+maintainer: Simon Marlow <marlowsd@gmail.com>+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+}