{-# LANGUAGE CPP #-}
module GHC.RTS.Events.Merge (mergeEventLogs) where

import GHC.RTS.Events
import Data.Monoid
import Data.List (foldl')
import qualified Data.Map as M
import Data.Word (Word32)
import Prelude

-- 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 # 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 -> EventLog -> EventLog
mergeEventLogs (EventLog Header
h1 (Data [Event]
xs)) (EventLog Header
h2 (Data [Event]
ys)) =
  let headerMap :: [EventType] -> Map EventTypeNum EventType
headerMap = [(EventTypeNum, EventType)] -> Map EventTypeNum EventType
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(EventTypeNum, EventType)] -> Map EventTypeNum EventType)
-> ([EventType] -> [(EventTypeNum, EventType)])
-> [EventType]
-> Map EventTypeNum EventType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EventType -> (EventTypeNum, EventType))
-> [EventType] -> [(EventTypeNum, EventType)]
forall a b. (a -> b) -> [a] -> [b]
map (\ et :: EventType
et@EventType {EventTypeNum
num :: EventType -> EventTypeNum
num :: EventTypeNum
num} -> (EventTypeNum
num, EventType
et))
      m1 :: Map EventTypeNum EventType
m1 = [EventType] -> Map EventTypeNum EventType
headerMap ([EventType] -> Map EventTypeNum EventType)
-> [EventType] -> Map EventTypeNum EventType
forall a b. (a -> b) -> a -> b
$ Header -> [EventType]
eventTypes Header
h1
      m2 :: Map EventTypeNum EventType
m2 = [EventType] -> Map EventTypeNum EventType
headerMap ([EventType] -> Map EventTypeNum EventType)
-> [EventType] -> Map EventTypeNum EventType
forall a b. (a -> b) -> a -> b
$ Header -> [EventType]
eventTypes Header
h2
      combine :: p -> p -> p
combine p
et1 p
et2 | p
et1 p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
et2 = p
et1
      combine p
_ p
_ = [Char] -> p
forall a. HasCallStack => [Char] -> a
error [Char]
"can't merge eventlogs with inconsistent headers"
      m :: Map EventTypeNum EventType
m = (EventType -> EventType -> EventType)
-> Map EventTypeNum EventType
-> Map EventTypeNum EventType
-> Map EventTypeNum EventType
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith EventType -> EventType -> EventType
forall p. Eq p => p -> p -> p
combine Map EventTypeNum EventType
m1 Map EventTypeNum EventType
m2
      h :: Header
h = [EventType] -> Header
Header ([EventType] -> Header) -> [EventType] -> Header
forall a b. (a -> b) -> a -> b
$ Map EventTypeNum EventType -> [EventType]
forall k a. Map k a -> [a]
M.elems Map EventTypeNum EventType
m
  in Header
h Header -> Header -> Bool
forall a. Eq a => a -> a -> Bool
== Header
h Bool -> EventLog -> EventLog
`seq`  -- Detect inconsistency ASAP.
     Header -> Data -> EventLog
EventLog Header
h (Data -> EventLog) -> ([Event] -> Data) -> [Event] -> EventLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Data
Data ([Event] -> Data) -> ([Event] -> [Event]) -> [Event] -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> Timestamp) -> [Event] -> [Event] -> [Event]
forall b a. Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn Event -> Timestamp
evTime [Event]
xs ([Event] -> EventLog) -> [Event] -> EventLog
forall a b. (a -> b) -> a -> b
$ MaxVars -> [Event] -> [Event]
shift ([Event] -> MaxVars
maxVars [Event]
xs) [Event]
ys

mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn :: (a -> b) -> [a] -> [a] -> [a]
mergeOn a -> b
_ [] [a]
ys = [a]
ys
mergeOn a -> b
_ [a]
xs [] = [a]
xs
mergeOn a -> b
f (a
x:[a]
xs) (a
y:[a]
ys) | a -> b
f a
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= a -> b
f a
y = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> b) -> [a] -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn a -> b
f [a]
xs (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
                        | Bool
otherwise  = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> b) -> [a] -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn a -> b
f (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [a]
ys

-- TODO: rename, since these are not maximal values, but numbers of used values
data MaxVars = MaxVars { MaxVars -> Word32
mcapset :: !Word32
                       , MaxVars -> Int
mcap :: !Int
                       , MaxVars -> Word32
mthread :: !ThreadId }
-- TODO introduce parallel RTS process and machine var.s

#if MIN_VERSION_base(4,11,0)
instance Semigroup MaxVars where
    <> :: MaxVars -> MaxVars -> MaxVars
(<>) = MaxVars -> MaxVars -> MaxVars
forall a. Monoid a => a -> a -> a
mappend
#endif

instance Monoid MaxVars where
    mempty :: MaxVars
mempty  = Word32 -> Int -> Word32 -> MaxVars
MaxVars Word32
0 Int
0 Word32
0
    mappend :: MaxVars -> MaxVars -> MaxVars
mappend (MaxVars Word32
a Int
b Word32
c) (MaxVars Word32
x Int
y Word32
z) =
      Word32 -> Int -> Word32 -> MaxVars
MaxVars (Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
a Word32
x) (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y) (Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
c Word32
z)
    -- avoid space leaks:
    mconcat :: [MaxVars] -> MaxVars
mconcat = (MaxVars -> MaxVars -> MaxVars) -> MaxVars -> [MaxVars] -> MaxVars
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' MaxVars -> MaxVars -> MaxVars
forall a. Monoid a => a -> a -> a
mappend MaxVars
forall a. Monoid a => a
mempty

-- 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 :: [Event] -> MaxVars
maxVars = [MaxVars] -> MaxVars
forall a. Monoid a => [a] -> a
mconcat ([MaxVars] -> MaxVars)
-> ([Event] -> [MaxVars]) -> [Event] -> MaxVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> MaxVars) -> [Event] -> [MaxVars]
forall a b. (a -> b) -> [a] -> [b]
map (EventInfo -> MaxVars
maxSpec (EventInfo -> MaxVars) -> (Event -> EventInfo) -> Event -> MaxVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> EventInfo
evSpec)
 where
    -- only checking binding sites right now, sufficient?
    maxSpec :: EventInfo -> MaxVars
maxSpec (Startup Int
n) = MaxVars
forall a. Monoid a => a
mempty { mcap :: Int
mcap = Int
n }
    -- Threads start at 1.
    maxSpec (CreateThread Word32
t) = MaxVars
forall a. Monoid a => a
mempty { mthread :: Word32
mthread = Word32
t }
    maxSpec (CreateSparkThread Word32
t) = MaxVars
forall a. Monoid a => a
mempty { mthread :: Word32
mthread = Word32
t }
    -- Capsets start at 0.
    maxSpec (CapsetCreate Word32
cs CapsetType
_) = MaxVars
forall a. Monoid a => a
mempty {mcapset :: Word32
mcapset = Word32
cs Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1 }
    maxSpec EventInfo
_  = MaxVars
forall a. Monoid a => a
mempty

sh :: Num a => a -> a -> a
sh :: a -> a -> a
sh a
x a
y = a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
y

updateSpec :: (EventInfo -> EventInfo) -> Event -> Event
updateSpec :: (EventInfo -> EventInfo) -> Event -> Event
updateSpec EventInfo -> EventInfo
f (Event {evTime :: Event -> Timestamp
evTime = Timestamp
t, evSpec :: Event -> EventInfo
evSpec = EventInfo
s, evCap :: Event -> Maybe Int
evCap = Maybe Int
cap}) =
    Event :: Timestamp -> EventInfo -> Maybe Int -> Event
Event {evTime :: Timestamp
evTime = Timestamp
t, evSpec :: EventInfo
evSpec = EventInfo -> EventInfo
f EventInfo
s, evCap :: Maybe Int
evCap = Maybe Int
cap}

shift :: MaxVars -> [Event] -> [Event]
shift :: MaxVars -> [Event] -> [Event]
shift (MaxVars Word32
mcs Int
mc Word32
mt) = (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map ((EventInfo -> EventInfo) -> Event -> Event
updateSpec EventInfo -> EventInfo
shift')
 where
    -- -1 marks a block that isn't attached to a particular capability
    shift' :: EventInfo -> EventInfo
shift' (CreateThread Word32
t) = Word32 -> EventInfo
CreateThread (Word32 -> EventInfo) -> Word32 -> EventInfo
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mt Word32
t
    shift' (RunThread Word32
t) = Word32 -> EventInfo
RunThread (Word32 -> EventInfo) -> Word32 -> EventInfo
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mt Word32
t
    shift' (StopThread Word32
t ThreadStopStatus
s) = Word32 -> ThreadStopStatus -> EventInfo
StopThread (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mt Word32
t) ThreadStopStatus
s
    shift' (ThreadRunnable Word32
t) = Word32 -> EventInfo
ThreadRunnable (Word32 -> EventInfo) -> Word32 -> EventInfo
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mt Word32
t
    shift' (MigrateThread Word32
t Int
c) = Word32 -> Int -> EventInfo
MigrateThread (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mt Word32
t) (Int -> Int -> Int
forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (WakeupThread Word32
t Int
c) = Word32 -> Int -> EventInfo
WakeupThread (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mt Word32
t) (Int -> Int -> Int
forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (ThreadLabel Word32
t Text
l) = Word32 -> Text -> EventInfo
ThreadLabel (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mt Word32
t) Text
l
    shift' (CreateSparkThread Word32
t) = Word32 -> EventInfo
CreateSparkThread (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mt Word32
t)
    shift' (SparkSteal Int
c) = Int -> EventInfo
SparkSteal (Int -> Int -> Int
forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (TaskCreate Timestamp
tk Int
c KernelThreadId
tid) = Timestamp -> Int -> KernelThreadId -> EventInfo
TaskCreate Timestamp
tk (Int -> Int -> Int
forall a. Num a => a -> a -> a
sh Int
mc Int
c) KernelThreadId
tid
    shift' (TaskMigrate Timestamp
tk Int
c1 Int
c2) = Timestamp -> Int -> Int -> EventInfo
TaskMigrate Timestamp
tk (Int -> Int -> Int
forall a. Num a => a -> a -> a
sh Int
mc Int
c1) (Int -> Int -> Int
forall a. Num a => a -> a -> a
sh Int
mc Int
c2)
    shift' (CapCreate Int
c) = Int -> EventInfo
CapCreate (Int -> Int -> Int
forall a. Num a => a -> a -> a
sh Int
mc Int
c)  -- TODO: correct?
    shift' (CapDelete Int
c) = Int -> EventInfo
CapDelete (Int -> Int -> Int
forall a. Num a => a -> a -> a
sh Int
mc Int
c)  -- TODO: correct?
    shift' (CapDisable Int
c) = Int -> EventInfo
CapDisable (Int -> Int -> Int
forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (CapEnable Int
c) = Int -> EventInfo
CapEnable (Int -> Int -> Int
forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (CapsetCreate Word32
cs CapsetType
cst) = Word32 -> CapsetType -> EventInfo
CapsetCreate (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) CapsetType
cst
    shift' (CapsetDelete Word32
cs) = Word32 -> EventInfo
CapsetDelete (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs)
    shift' (CapsetAssignCap Word32
cs Int
c) = Word32 -> Int -> EventInfo
CapsetAssignCap (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) (Int -> Int -> Int
forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (CapsetRemoveCap Word32
cs Int
c) = Word32 -> Int -> EventInfo
CapsetRemoveCap (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) (Int -> Int -> Int
forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (RtsIdentifier Word32
cs Text
rts) = Word32 -> Text -> EventInfo
RtsIdentifier (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) Text
rts
    shift' (ProgramArgs Word32
cs [Text]
as) = Word32 -> [Text] -> EventInfo
ProgramArgs (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) [Text]
as
    shift' (ProgramEnv Word32
cs [Text]
es) = Word32 -> [Text] -> EventInfo
ProgramEnv (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) [Text]
es
    shift' (OsProcessPid Word32
cs Word32
pid) = Word32 -> Word32 -> EventInfo
OsProcessPid (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) Word32
pid
    shift' (OsProcessParentPid Word32
cs Word32
ppid) = Word32 -> Word32 -> EventInfo
OsProcessParentPid (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) Word32
ppid
    shift' (WallClockTime Word32
cs Timestamp
sec Word32
nsec) = Word32 -> Timestamp -> Word32 -> EventInfo
WallClockTime (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) Timestamp
sec Word32
nsec
    shift' EventInfo
x = EventInfo
x
    -- TODO extend by new shift for Eden events