ghc-events 0.4.0.1 → 0.4.2.0

raw patch · 10 files changed

+395/−65 lines, 10 filesdep ~binarydep ~mtlnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: binary, mtl

API changes (from Hackage documentation)

Files

• AUTHORS +0/−2
• GHC/RTS/EventLogFormat.h +21/−3
• GHC/RTS/EventTypes.hs +43/−3
• GHC/RTS/Events.hs +122/−12
• GHC/RTS/Events/Analysis.hs +1/−2
• GHC/RTS/Events/Analysis/Capability.hs +114/−5
• GHC/RTS/Events/Merge.hs +49/−14
• GhcEvents.hs +28/−2
• LICENSE +5/−5
• ghc-events.cabal +12/−17

@@ -1,2 +0,0 @@-Donnie Jones <donnie@darthik.com>-Simon Marlow <marlowsd@gmail.com>

@@ -1,6 +1,6 @@ /* -----------------------------------------------------------------------------  *- * (c) The GHC Team, 2008-2009+ * (c) The GHC Team, 2008-2012  *  * Event log format  *@@ -158,8 +158,12 @@                                          par_n_threads,                                          par_max_copied, par_tot_copied) */ #define EVENT_GC_GLOBAL_SYNC      54 /* ()                     */+#define EVENT_TASK_CREATE         55 /* (taskID, cap, tid)       */+#define EVENT_TASK_MIGRATE        56 /* (taskID, cap, new_cap)   */+#define EVENT_TASK_DELETE         57 /* (taskID)                 */+#define EVENT_USER_MARKER         58 /* (marker_name) */ -/* Range 55 - 59 is available for new GHC and common events */+/* Range 59 - 59 is available for new GHC and common events. */  /* Range 60 - 80 is used by eden for parallel tracing  * see http://www.mathematik.uni-marburg.de/~eden/@@ -167,12 +171,14 @@  /* Range 100 - 139 is reserved for Mercury, see below. */ +/* Range 140 - 159 is reserved for Perf events, see below. */+ /*  * The highest event code +1 that ghc itself emits. Note that some event  * ranges higher than this are reserved but not currently emitted by ghc.  * This must match the size of the EventDesc[] array in EventLog.c  */-#define NUM_GHC_EVENT_TAGS        55+#define NUM_GHC_EVENT_TAGS        59   /* DEPRECATED EVENTS: */@@ -216,6 +222,18 @@ #define EVENT_MER_RELEASE_CONTEXT       110 /* (context id) */ #define EVENT_MER_ENGINE_SLEEPING       111 /* () */ #define EVENT_MER_CALLING_MAIN          113 /* () */+++/*+ * These event types are parsed from hardware performance counters logs,+ * such as the Linux Performance Counters data available through+ * the perf subsystem.+ */++#define EVENT_PERF_NAME           140 /* (perf_num, name) */+#define EVENT_PERF_COUNTER        141 /* (perf_num, tid, period) */+#define EVENT_PERF_TRACEPOINT     142 /* (perf_num, tid) */+  /*  * Status values for EVENT_STOP_THREAD

@@ -2,7 +2,8 @@  module GHC.RTS.EventTypes where -import Data.Word (Word16, Word32, Word64)+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Binary  -- EventType. type EventTypeNum = Word16@@ -19,7 +20,16 @@ type RawThreadStopStatus = Word16 type StringId = Word32 type Capset   = Word32+type PerfEventTypeNum = Word32+type TaskId = Word64+type PID = Word32 +newtype KernelThreadId = KernelThreadId { kernelThreadId :: Word64 }+  deriving (Eq, Ord, Show)+instance Binary KernelThreadId where+  put (KernelThreadId tid) = put tid+  get = fmap KernelThreadId get+ -- These types are used by Mercury events. type ParConjDynId = Word64 type ParConjStaticId = StringId@@ -48,10 +58,16 @@     + sz_time + sz_cap) sz_pid :: EventTypeSize sz_pid = 4+sz_taskid :: EventTypeSize+sz_taskid = 8+sz_kernel_tid :: EventTypeSize+sz_kernel_tid = 8 sz_th_stop_status :: EventTypeSize sz_th_stop_status = 2 sz_string_id :: EventTypeSize sz_string_id = 4+sz_perf_num :: EventTypeSize+sz_perf_num = 4  -- Sizes for Mercury event fields. sz_par_conj_dyn_id :: EventTypeSize@@ -148,6 +164,17 @@   | SparkFizzle        { }   | SparkGC            { } +  -- tasks+  | TaskCreate         { taskId :: TaskId,+                         cap :: {-# UNPACK #-}!Int,+                         tid :: {-# UNPACK #-}!KernelThreadId+                       }+  | TaskMigrate        { taskId :: TaskId,+                         cap :: {-# UNPACK #-}!Int,+                         new_cap :: {-# UNPACK #-}!Int+                       }+  | TaskDelete         { taskId :: TaskId }+   -- garbage collection   | RequestSeqGC       { }   | RequestParGC       { }@@ -218,10 +245,10 @@                        , env    :: [String]                        }   | OsProcessPid       { capset :: {-# UNPACK #-}!Capset-                       , pid    :: {-# UNPACK #-}!Word32+                       , pid    :: {-# UNPACK #-}!PID                        }   | OsProcessParentPid { capset :: {-# UNPACK #-}!Capset-                       , ppid   :: {-# UNPACK #-}!Word32+                       , ppid   :: {-# UNPACK #-}!PID                        }   | WallClockTime      { capset :: {-# UNPACK #-}!Capset                        , sec    :: {-# UNPACK #-}!Word64@@ -231,6 +258,7 @@   -- messages   | Message            { msg :: String }   | UserMessage        { msg :: String }+  | UserMarker         { markername :: String }    -- These events have been added for Mercury's benifit but are generally   -- useful.@@ -272,6 +300,18 @@     }   | MerCapSleeping   | MerCallingMain++  -- perf events+  | PerfName           { perfNum :: {-# UNPACK #-}!PerfEventTypeNum+                       , name    :: String+                       }+  | PerfCounter        { perfNum :: {-# UNPACK #-}!PerfEventTypeNum+                       , tid     :: {-# UNPACK #-}!KernelThreadId+                       , period  :: {-# UNPACK #-}!Word64+                       }+  | PerfTracepoint     { perfNum :: {-# UNPACK #-}!PerfEventTypeNum+                       , tid     :: {-# UNPACK #-}!KernelThreadId+                       }    deriving Show 

@@ -1,8 +1,6 @@ {-# LANGUAGE CPP,BangPatterns,PatternGuards #-} {-# OPTIONS_GHC -funbox-strict-fields -fwarn-incomplete-patterns #-} {-- - Authors: Donnie Jones, Simon Marlow, Paul Bone, Duncan Coutts- - Events.hs  -   Parser functions for GHC RTS EventLog framework.  -} @@ -18,6 +16,8 @@        CapsetType(..),        Timestamp,        ThreadId,+       TaskId,+       KernelThreadId(..),         -- * Reading and writing event logs        readEventLogFromFile,@@ -29,7 +29,11 @@         -- * Printing        showEventInfo, showThreadStopStatus,-       ppEventLog, ppEventType, ppEvent+       ppEventLog, ppEventType, ppEvent,++       -- * Perf events+       nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT,+       sz_perf_num, sz_kernel_tid   ) where  {- Libraries. -}@@ -263,7 +267,6 @@       return WallClockTime{capset=cs,sec=s,nsec=ns}   )), -  (VariableSizeParser EVENT_LOG_MSG (do -- (msg)       num <- getE :: GetEvents Word16       string <- getString num@@ -274,6 +277,11 @@       string <- getString num       return UserMessage{ msg = string }    )),+    (VariableSizeParser EVENT_USER_MARKER (do -- (markername)+      num <- getE :: GetEvents Word16+      string <- getString num+      return UserMarker{ markername = string }+   )),  (VariableSizeParser EVENT_PROGRAM_ARGS (do -- (capset, [arg])       num <- getE :: GetEvents Word16       cs <- getE@@ -405,6 +413,25 @@  (simpleEvent EVENT_SPARK_FIZZLE   SparkFizzle),  (simpleEvent EVENT_SPARK_GC       SparkGC), + (FixedSizeParser EVENT_TASK_CREATE (sz_taskid + sz_cap + sz_kernel_tid) (do  -- (taskID, cap, tid)+      taskId <- getE :: GetEvents TaskId+      cap    <- getE :: GetEvents CapNo+      tid    <- getE :: GetEvents KernelThreadId+      return TaskCreate{ taskId, cap = fromIntegral cap, tid }+   )),+ (FixedSizeParser EVENT_TASK_MIGRATE (sz_taskid + sz_cap*2) (do  -- (taskID, cap, new_cap)+      taskId  <- getE :: GetEvents TaskId+      cap     <- getE :: GetEvents CapNo+      new_cap <- getE :: GetEvents CapNo+      return TaskMigrate{ taskId, cap = fromIntegral cap+                                , new_cap = fromIntegral new_cap+                        }+   )),+ (FixedSizeParser EVENT_TASK_DELETE (sz_taskid) (do  -- (taskID)+      taskId <- getE :: GetEvents TaskId+      return TaskDelete{ taskId }+   )),+  (FixedSizeParser EVENT_THREAD_WAKEUP (sz_tid + sz_cap) (do  -- (thread, other_cap)       t <- getE       oc <- getE :: GetEvents CapNo@@ -544,6 +571,28 @@   ] +perfParsers = [+ (VariableSizeParser EVENT_PERF_NAME (do -- (perf_num, name)+      num     <- getE :: GetEvents Word16+      perfNum <- getE+      name    <- getString (num - sz_perf_num)+      return PerfName{perfNum, name}+   )),++ (FixedSizeParser EVENT_PERF_COUNTER (sz_perf_num + sz_kernel_tid + 8) (do -- (perf_num, tid, period)+      perfNum <- getE+      tid     <- getE+      period  <- getE+      return PerfCounter{perfNum, tid, period}+  )),++ (FixedSizeParser EVENT_PERF_TRACEPOINT (sz_perf_num + sz_kernel_tid) (do -- (perf_num, tid)+      perfNum <- getE+      tid     <- getE+      return PerfTracepoint{perfNum, tid}+  ))+ ]+ getData :: GetEvents Data getData = do    db <- getE :: GetEvents Marker@@ -586,8 +635,8 @@         -}         event_parsers = if is_ghc_6                             then standardParsers ++ ghc6Parsers-                            else standardParsers ++ ghc7Parsers ++-                                mercuryParsers+                            else standardParsers ++ ghc7Parsers+                                 ++ mercuryParsers ++ perfParsers         parsers = mkEventTypeParsers imap event_parsers     dat <- runReaderT getData (EventParsers parsers)     return (EventLog header dat)@@ -703,6 +752,14 @@           printf "spark fizzled"         SparkGC ->           printf "spark GCed"+        TaskCreate taskId cap tid ->+          printf "task 0x%x created on cap %d with OS kernel thread %d"+                 taskId cap (kernelThreadId tid)+        TaskMigrate taskId cap new_cap ->+          printf "task 0x%x migrated from cap %d to cap %d"+                 taskId cap new_cap+        TaskDelete taskId ->+          printf "task 0x%x deleted" taskId         Shutdown ->           printf "shutting down"         WakeupThread thread otherCap ->@@ -747,6 +804,8 @@           msg         UserMessage msg ->           msg+        UserMarker markername ->+          printf "marker: %s" markername         CapsetCreate cs ct ->           printf "created capset %d of type %s" cs (show ct)         CapsetDelete cs ->@@ -799,6 +858,14 @@           "Capability going to sleep"         MerCallingMain ->           "About to call the program entry point"+        PerfName{perfNum, name} ->+          printf "perf event %d named \"%s\"" perfNum name+        PerfCounter{perfNum, tid, period} ->+          printf "perf event counter %d incremented by %d in OS thread %d"+                 perfNum (period + 1) (kernelThreadId tid)+        PerfTracepoint{perfNum, tid} ->+          printf "perf event tracepoint %d reached in OS thread %d"+                 perfNum (kernelThreadId tid)  showThreadStopStatus :: ThreadStopStatus -> String showThreadStopStatus HeapOverflow   = "heap overflow"@@ -926,10 +993,14 @@     SparkSteal    {} -> EVENT_SPARK_STEAL     SparkFizzle   {} -> EVENT_SPARK_FIZZLE     SparkGC       {} -> EVENT_SPARK_GC+    TaskCreate  {} -> EVENT_TASK_CREATE+    TaskMigrate {} -> EVENT_TASK_MIGRATE+    TaskDelete  {} -> EVENT_TASK_DELETE     Message {} -> EVENT_LOG_MSG     Startup {} -> EVENT_STARTUP     EventBlock {} -> EVENT_BLOCK_MARKER     UserMessage {} -> EVENT_USER_MSG+    UserMarker  {} -> EVENT_USER_MARKER     GCIdle {} -> EVENT_GC_IDLE     GCWork {} -> EVENT_GC_WORK     GCDone {} -> EVENT_GC_DONE@@ -968,7 +1039,15 @@     MerReleaseThread _ -> EVENT_MER_RELEASE_CONTEXT     MerCapSleeping -> EVENT_MER_ENGINE_SLEEPING     MerCallingMain -> EVENT_MER_CALLING_MAIN+    PerfName       {} -> nEVENT_PERF_NAME+    PerfCounter    {} -> nEVENT_PERF_COUNTER+    PerfTracepoint {} -> nEVENT_PERF_TRACEPOINT +nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT :: EventTypeNum+nEVENT_PERF_NAME = EVENT_PERF_NAME+nEVENT_PERF_COUNTER = EVENT_PERF_COUNTER+nEVENT_PERF_TRACEPOINT = EVENT_PERF_TRACEPOINT+ putEvent :: Event -> PutEvents () putEvent (Event t spec) = do     putType (eventTypeNum spec)@@ -1097,13 +1176,26 @@ putEventSpec GlobalSyncGC = do     return () +putEventSpec (TaskCreate taskId cap tid) = do+    putE taskId+    putCap cap+    putE tid++putEventSpec (TaskMigrate taskId cap new_cap) = do+    putE taskId+    putCap cap+    putCap new_cap++putEventSpec (TaskDelete taskId) = do+    putE taskId+ putEventSpec GCStatsGHC{..} = do     putE heapCapset-    putE gen+    putE (fromIntegral gen :: Word16)     putE copied     putE slop     putE frag-    putE parNThreads+    putE (fromIntegral parNThreads :: Word32)     putE parMaxCopied     putE parTotCopied @@ -1121,7 +1213,7 @@  putEventSpec HeapInfoGHC{..} = do     putE heapCapset-    putE gens+    putE (fromIntegral gens :: Word16)     putE maxHeapSize     putE allocAreaSize     putE mblockSize@@ -1159,19 +1251,19 @@     putCap cp  putEventSpec (RtsIdentifier cs rts) = do-    putE (fromIntegral (length rts) + 4 :: Word16)+    putE (fromIntegral (length rts) + sz_capset :: Word16)     putE cs     putEStr rts  putEventSpec (ProgramArgs cs as) = do     let as' = unsep as-    putE (fromIntegral (length as') + 4 :: Word16)+    putE (fromIntegral (length as') + sz_capset :: Word16)     putE cs     mapM_ putE as'  putEventSpec (ProgramEnv cs es) = do     let es' = unsep es-    putE (fromIntegral (length es') + 4 :: Word16)+    putE (fromIntegral (length es') + sz_capset :: Word16)     putE cs     mapM_ putE es' @@ -1196,6 +1288,10 @@     putE (fromIntegral (length s) :: Word16)     mapM_ putE s +putEventSpec (UserMarker s) = do+    putE (fromIntegral (length s) :: Word16)+    mapM_ putE s+ putEventSpec (UnknownEvent {}) = error "putEventSpec UnknownEvent"  putEventSpec (InternString str id) = do@@ -1240,6 +1336,20 @@  putEventSpec MerCapSleeping = return () putEventSpec MerCallingMain = return ()++putEventSpec PerfName{..} = do+    putE (fromIntegral (length name) + sz_perf_num :: Word16)+    putE perfNum+    mapM_ putE name++putEventSpec PerfCounter{..} = do+    putE perfNum+    putE tid+    putE period++putEventSpec PerfTracepoint{..} = do+    putE perfNum+    putE tid  -- [] == [] -- [x] == x\0

@@ -64,7 +64,7 @@   | otherwise = Right s  -- | The `validate` function takes a machine and a list of inputs. The machine--- is started from its initial state and run agains the inputs in turn.+-- is started from its initial state and run against the inputs in turn. -- It returns the state and input on failure, and just the state on success. validate :: Machine s i -> [i] -> Either (s, i) s validate m = foldl (>>=) (Right (initial m)) . map (flip (step m))@@ -280,4 +280,3 @@             Nothing -> return m           else return m     return (m', r')-

@@ -2,6 +2,8 @@   ( capabilityThreadPoolMachine   , capabilityThreadRunMachine   , capabilityThreadIndexer+  , capabilityTaskPoolMachine+  , capabilityTaskOSMachine   )  where @@ -40,13 +42,13 @@    where     insertThread :: ThreadId -> Int -> Map ThreadId Int -> Maybe (Map ThreadId Int)     insertThread threadId capId m-      | threadId `elem` M.keys m = Nothing -- The thread already exists-      | otherwise                = Just $ M.insert threadId capId m+      | threadId `M.member` m = Nothing -- The thread already exists+      | otherwise             = Just $ M.insert threadId capId m      deleteThread :: ThreadId -> Map ThreadId Int -> Maybe (Map ThreadId Int)     deleteThread threadId m-      | notElem threadId . M.keys $ m = Nothing -- The thread doesn't exist-      | otherwise                     = Just $ M.delete threadId m+      | threadId `M.notMember` m = Nothing -- The thread doesn't exist+      | otherwise                = Just $ M.delete threadId m  -- | This state machine tracks threads running on capabilities, only one thread -- may run on a capability at a time.@@ -76,7 +78,7 @@    where     runThread :: Int -> ThreadId -> Map Int ThreadId -> Maybe (Map Int ThreadId)     runThread capId threadId m-      | M.member capId m          = Nothing -- A thread is already on this cap+      | capId `M.member` m        = Nothing -- A thread is already on this cap       | threadId `elem` M.elems m = Nothing -- This thread is already on a cap       | otherwise                 = Just $ M.insert capId threadId m     stopThread :: ThreadId -> Map Int ThreadId -> Maybe (Map Int ThreadId)@@ -98,3 +100,110 @@   _                             -> mThreadId  where   mThreadId = ce_cap capEvent >>= (\capId -> M.lookup capId m)++-- | This state machine tracks Haskell tasks, represented by TaskId,+-- residing on capabilities.+-- Each Haskell task can only reside on one capability, but can be migrated+-- between them.+capabilityTaskPoolMachine :: Machine (Map TaskId Int) CapEvent+capabilityTaskPoolMachine = Machine+  { initial = M.empty+  , final   = const False+  , alpha   = capabilityTaskPoolMachineAlpha+  , delta   = capabilityTaskPoolMachineDelta+  }+ where+  capabilityTaskPoolMachineAlpha capEvent = case spec . ce_event $ capEvent of+     TaskCreate{}  -> True+     TaskDelete{}  -> True+     TaskMigrate{} -> True+     _             -> False++  capabilityTaskPoolMachineDelta mapping capEvent = do+    case spec . ce_event $ capEvent of+      TaskCreate {taskId, cap}           -> insertTask taskId cap mapping+      TaskDelete {taskId}                -> deleteTask taskId Nothing mapping+      TaskMigrate {taskId, cap, new_cap} ->+        deleteTask taskId (Just cap) mapping >>=+          insertTask taskId new_cap+      _                                  -> Nothing+   where+    insertTask :: TaskId -> Int -> Map TaskId Int+               -> Maybe (Map TaskId Int)+    insertTask taskId cap m+      | taskId `M.member` m = Nothing  -- The task already exists.+      | otherwise           = Just $ M.insert taskId cap m++    deleteTask :: TaskId -> Maybe Int -> Map TaskId Int+               -> Maybe (Map TaskId Int)+    deleteTask taskId expectedcap m+      | Just oldcap <- M.lookup taskId m+      , maybe True (==oldcap) expectedcap+      = Just $ M.delete taskId m+      | otherwise+      = Nothing  -- The task doesn't exist, or does but with an unexpected cap.++-- | This state machine tracks Haskell tasks (represented by the KernelThreadId+-- of their OS thread) residing on capabilities and additionally+-- tracks the (immutable) assignment of OS thread ids (KernelThreadId)+-- to tasks ids (TaskId).+-- Each Haskell task can only reside on one capability, but can be migrated+-- between them.+--+-- Invariant for the @(Map KernelThreadId Int, Map TaskId KernelThreadId)@ +-- type: the second map is an injection (verified by the machine +-- in 'insertTaskOS') and the following sets are equal: +-- keys of the fist map and values of the second+-- (follows from the construction of the maps by the machine).+--+-- The machine verifies as much as 'capabilityTaskPoolMachine' and additionally+-- the data invariant, and offers a richer verification profile.+capabilityTaskOSMachine :: Machine (Map KernelThreadId Int,+                                    Map TaskId KernelThreadId)+                                   CapEvent+capabilityTaskOSMachine = Machine+  { initial = (M.empty, M.empty)+  , final   = const False+  , alpha   = capabilityTaskOSMachineAlpha+  , delta   = capabilityTaskOSMachineDelta+  }+ where+  capabilityTaskOSMachineAlpha capEvent = case spec . ce_event $ capEvent of+     TaskCreate{}  -> True+     TaskDelete{}  -> True+     TaskMigrate{} -> True+     _             -> False++  capabilityTaskOSMachineDelta mapping capEvent = do+    case spec . ce_event $ capEvent of+      TaskCreate {taskId, cap, tid} -> insertTaskOS taskId cap tid mapping+      TaskDelete {taskId}           -> deleteTaskOS taskId mapping+      TaskMigrate {taskId, new_cap} -> migrateTaskOS taskId new_cap mapping+      _                             -> Nothing+   where+    insertTaskOS :: TaskId -> Int -> KernelThreadId+                 -> (Map KernelThreadId Int, Map TaskId KernelThreadId)+                 -> Maybe (Map KernelThreadId Int, Map TaskId KernelThreadId)+    insertTaskOS taskId cap tid (m, ma)+      | taskId `M.member` ma = Nothing  -- The task already exists.+      | tid `M.member` m     = Nothing  -- The OS thread already exists.+      | otherwise            = Just (M.insert tid cap m,+                                     M.insert taskId tid ma)++    deleteTaskOS :: TaskId -> (Map KernelThreadId Int,+                               Map TaskId KernelThreadId)+                 -> Maybe (Map KernelThreadId Int, Map TaskId KernelThreadId)+    deleteTaskOS taskId (m, ma) =+      case M.lookup taskId ma of+        Nothing  -> Nothing  -- The task doesn't exist.+        Just tid -> Just (M.delete tid m,+                          M.delete taskId ma)++    migrateTaskOS :: TaskId -> Int -> (Map KernelThreadId Int,+                                       Map TaskId KernelThreadId)+                  -> Maybe (Map KernelThreadId Int, Map TaskId KernelThreadId)+    migrateTaskOS taskId new_cap (m, ma) =+      case M.lookup taskId ma of+        Nothing -> Nothing  -- The task doesn't exist.+        Just tid -> Just (M.insert tid new_cap m,+                          ma)  -- The assignment is immutable.

@@ -5,21 +5,37 @@ import GHC.RTS.Events import Data.Monoid import Data.List (foldl')+import qualified Data.Map as M import Data.Word (Word32, Word16) +-- TODO: add a merge mode where the events are synchronized using+-- the wall clock time event at the start of both eventlogs (for newer GHCs).+-- Such merge is not associative so we either need to take many arguments+-- or cope with eventlogs with many wall clock time events (assume they+-- are products of previous merges). To decide.+ {- GHC numbers caps and capsets in sequential order, starting at 0.  Threads are-similarly numbered, but start at 1.  In order to merge logs 'x' and 'y', we-find the maximum values of each variable type in 'x', then increment each-variable in 'y' that amount.  This guarantees that variables in each log don't-clash, and that the meaning of each reference to a thread/cap/capset is+similarly numbered, but start at 1.  In order to merge logs 'x' and 'y',+we find the # of occupied numbers for each variable type in 'x',+then increment each variable in 'y' by that amount.+We assume that if a number is occupied, so are all lower numbers.+This guarantees that variables in each log don't clash,+and that the meaning of each reference to a thread/cap/capset is preserved. -}  mergeEventLogs :: EventLog -> EventLog -> EventLog-mergeEventLogs (EventLog h1 (Data xs)) (EventLog h2 (Data ys)) | h1 == h2-  = EventLog h1 . Data . mergeOn time xs $ shift (maxVars xs) ys-mergeEventLogs _ _ = error "can't merge eventlogs with non-matching headers"+mergeEventLogs (EventLog h1 (Data xs)) (EventLog h2 (Data ys)) =+  let headerMap = M.fromList . map (\ et@EventType {num} -> (num, et))+      m1 = headerMap $ eventTypes h1+      m2 = headerMap $ eventTypes h2+      combine et1 et2 | et1 == et2 = et1+      combine _ _ = error "can't merge eventlogs with inconsistent headers"+      m = M.unionWith combine m1 m2+      h = Header $ M.elems m+  in h == h `seq`  -- Detect inconsistency ASAP.+     EventLog h . Data . mergeOn time xs $ shift (maxVars xs) ys  mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a] mergeOn f [] ys = ys@@ -27,14 +43,15 @@ mergeOn f (x:xs) (y:ys) | f x <= f y = x : mergeOn f xs (y:ys)                         | otherwise  = y : mergeOn f (x:xs) ys +-- TODO: rename, since these are not maximal values, but numbers of used values data MaxVars = MaxVars { mcapset :: !Word32                        , mcap :: !Int                        , mthread :: !ThreadId }  instance Monoid MaxVars where-    -- threads start at 1-    mempty  = MaxVars 0 0 1-    mappend (MaxVars a b c) (MaxVars x y z) = MaxVars (max a x) (max b y) (max c z)+    mempty  = MaxVars 0 0 0+    mappend (MaxVars a b c) (MaxVars x y z) =+      MaxVars (max a x) (b + y) (max c z)     -- avoid space leaks:     mconcat = foldl' mappend mempty @@ -43,19 +60,27 @@ isCap :: Int -> Bool isCap x = fromIntegral x /= ((-1) :: Word16) +-- For caps we find the maximum value by summing the @Startup@ declarations.+-- TODO: it's not trivial to add CapCreate since we don't know+-- if created caps are guaranteed to be numbered consecutively or not+-- (are they? is it asserted in GHC code somewhere?). We might instead+-- just scan all events mentioning a cap and take the maximum,+-- but it's a slower and much longer code, requiring constant maintenance. maxVars :: [Event] -> MaxVars maxVars = mconcat . map (maxSpec . spec)  where     -- only checking binding sites right now, sufficient?-    maxSpec (Startup n) = mempty { mcap = n - 1 }+    maxSpec (Startup n) = mempty { mcap = n }+    -- Threads start at 1.     maxSpec (CreateThread t) = mempty { mthread = t }     maxSpec (CreateSparkThread t) = mempty { mthread = t }-    maxSpec (CapsetCreate cs _) = mempty {mcapset = cs }+    -- Capsets start at 0.+    maxSpec (CapsetCreate cs _) = mempty {mcapset = cs + 1 }     maxSpec (EventBlock _ _ es) = maxVars es     maxSpec _  = mempty  sh :: Num a => a -> a -> a-sh x y = x + y + 1+sh x y = x + y  shift :: MaxVars -> [Event] -> [Event] shift mv@(MaxVars mcs mc mt) = map (\(Event t s) -> Event t $ shift' s)@@ -68,14 +93,24 @@     shift' (StopThread t s) = StopThread (sh mt t) s     shift' (ThreadRunnable t) = ThreadRunnable $ sh mt t     shift' (MigrateThread t c) = MigrateThread (sh mt t) (sh mc c)-    shift' (CreateSparkThread t) = CreateSparkThread (sh mt t)     shift' (WakeupThread t c) = WakeupThread (sh mt t) (sh mc c)+    shift' (ThreadLabel t l) = ThreadLabel (sh mt t) l+    shift' (CreateSparkThread t) = CreateSparkThread (sh mt t)+    shift' (SparkSteal c) = SparkSteal (sh mc c)+    shift' (TaskCreate tk c tid) = TaskCreate tk (sh mc c) tid+    shift' (TaskMigrate tk c1 c2) = TaskMigrate tk (sh mc c1) (sh mc c2)+    shift' (CapCreate c) = CapCreate (sh mc c)  -- TODO: correct?+    shift' (CapDelete c) = CapDelete (sh mc c)  -- TODO: correct?+    shift' (CapDisable c) = CapDisable (sh mc c)+    shift' (CapEnable c) = CapEnable (sh mc c)     shift' (CapsetCreate cs cst) = CapsetCreate (sh mcs cs) cst     shift' (CapsetDelete cs) = CapsetDelete (sh mcs cs)+    shift' (CapsetAssignCap cs c) = CapsetAssignCap (sh mcs cs) (sh mc c)     shift' (CapsetRemoveCap cs c) = CapsetRemoveCap (sh mcs cs) (sh mc c)     shift' (RtsIdentifier cs rts) = RtsIdentifier (sh mcs cs) rts     shift' (ProgramArgs cs as) = ProgramArgs (sh mcs cs) as     shift' (ProgramEnv cs es) = ProgramEnv (sh mcs cs) es     shift' (OsProcessPid cs pid) = OsProcessPid (sh mcs cs) pid     shift' (OsProcessParentPid cs ppid) = OsProcessParentPid (sh mcs cs) ppid+    shift' (WallClockTime cs sec nsec) = WallClockTime (sh mcs cs) sec nsec     shift' x = x

@@ -30,7 +30,7 @@  command ["show", "threads", file] = do     eventLog <- readLogOrDie file-    let eventTypeMap = buildEventTypeMap . eventTypes .  header $ eventLog+    let eventTypeMap = buildEventTypeMap . eventTypes . header $ eventLog     let capEvents = sortEvents . events . dat $ eventLog     let mappings  = rights . validates capabilityThreadRunMachine $ capEvents     let indexes = map (uncurry capabilityThreadIndexer) $ zip mappings capEvents@@ -45,7 +45,7 @@  command ["show", "caps", file] = do     eventLog <- readLogOrDie file-    let eventTypeMap = buildEventTypeMap . eventTypes .  header $ eventLog+    let eventTypeMap = buildEventTypeMap . eventTypes . header $ eventLog     let capEvents = sortEvents . events . dat $ eventLog     let indexes = map ce_cap capEvents     let capMap = M.fromListWith (++) . reverse $ zip indexes (map return capEvents)@@ -87,6 +87,18 @@     let result = validate capabilityThreadRunMachine capEvents     putStrLn $ showValidate show show result +command ["validate", "taskpool", file] = do+    eventLog <- readLogOrDie file+    let capEvents = sortEvents . events . dat $ eventLog+    let result = validate capabilityTaskPoolMachine capEvents+    putStrLn $ showValidate show show result++command ["validate", "tasks", file] = do+    eventLog <- readLogOrDie file+    let capEvents = sortEvents . events . dat $ eventLog+    let result = validate capabilityTaskOSMachine capEvents+    putStrLn $ showValidate show show result+ command ["validate", "sparks", file] = do     eventLog <- readLogOrDie file     let capEvents = sortEvents . events . dat $ eventLog@@ -117,6 +129,18 @@     let result = simulate capabilityThreadRunMachine capEvents     putStrLn . showProcess $ result +command ["simulate", "taskpool", file] = do+    eventLog <- readLogOrDie file+    let capEvents = sortEvents . events . dat $ eventLog+    let result = simulate capabilityTaskPoolMachine capEvents+    putStrLn . showProcess $ result++command ["simulate", "tasks", file] = do+    eventLog <- readLogOrDie file+    let capEvents = sortEvents . events . dat $ eventLog+    let result = simulate capabilityTaskOSMachine capEvents+    putStrLn . showProcess $ result+ command ["simulate", "sparks", file] = do     eventLog <- readLogOrDie file     let capEvents = sortEvents . events . dat $ eventLog@@ -168,11 +192,13 @@               , ("ghc-events validate threads <file>:",    "Validate thread states.")               , ("ghc-events validate threadpool <file>:", "Validate thread pool state.")               , ("ghc-events validate threadrun <file>:",  "Validate thread running state.")+              , ("ghc-events validate tasks <file>:",      "Validate task states.")               , ("ghc-events validate sparks <file>:",     "Validate spark thread states.")                , ("ghc-events simulate threads <file>:",    "Simulate thread states.")               , ("ghc-events simulate threadpool <file>:", "Simulate thread pool state.")               , ("ghc-events simulate threadrun <file>:",  "Simulate thread running state.")+              , ("ghc-events simulate tasks <file>:",      "Simulate task states.")               , ("ghc-events simulate sparks <file>:",     "Simulate spark thread states.")                , ("ghc-events profile threads <file>:",     "Profile thread states.")

@@ -1,21 +1,21 @@ The Glasgow Haskell Compiler License -Copyright 2002, The University Court of the University of Glasgow. -All rights reserved.+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. +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,

@@ -1,31 +1,24 @@ name:             ghc-events-version:          0.4.0.1+version:          0.4.2.0 synopsis:         Library and tool for parsing .eventlog files from GHC--description:- Parses @.eventlog@ files emitted by GHC 6.12.1 and later.- Includes the @ghc-events@ tool which dumps an event log file- as text.- .- Changes in 0.4.0.1:- .- * compiles with GHC 7.6.1-+description:      Parses .eventlog files emitted by GHC 6.12.1 and later.+                  Includes the ghc-events tool permitting, in particular,+                  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>,                   Paul Bone <pbone@csse.unimelb.edu.au>,-                  Duncan Coutts <duncan@well-typed.com>-                  Nicolas Wu <nick@well-typed.com>+                  Duncan Coutts <duncan@well-typed.com>,+                  Nicolas Wu <nick@well-typed.com>,+                  Mikolaj Konarski <mikolaj@well-typed.com> maintainer:       Simon Marlow <marlowsd@gmail.com> bug-reports:      http://trac.haskell.org/ThreadScope/ build-type:       Simple-tested-with:      GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1+tested-with:      GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1, GHC == 7.6.1 cabal-version:    >= 1.8 extra-source-files: GHC/RTS/EventLogFormat.h,-                    AUTHORS,                     test/*.eventlog  source-repository head@@ -34,9 +27,9 @@  library   build-depends:    base       == 4.*,-                    mtl        >= 1.1 && < 2.2,+                    mtl        >= 1.1 && < 3.0,                     containers >= 0.2 && < 0.6,-                    binary     == 0.5.*,+                    binary     >= 0.5 && < 0.7,                     bytestring >= 0.9.0,                     array      >= 0.2 && < 0.5   exposed-modules:  GHC.RTS.Events,@@ -47,6 +40,7 @@                     GHC.RTS.Events.Analysis.Thread   other-modules:    GHC.RTS.EventParserUtils,                     GHC.RTS.EventTypes+  include-dirs:     GHC/RTS   extensions:	    RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards  executable ghc-events@@ -58,3 +52,4 @@   type:             exitcode-stdio-1.0   main-is:          test/TestVersions.hs   build-depends:    base, mtl, containers, binary, bytestring, array+  extensions:	    RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards