{-# 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 event logs (for newer GHCs).
-- Such merge is not associative so we either need to take many arguments
-- or cope with event logs 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 = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ Header -> [EventType]
eventTypes Header
h1
      m2 :: Map EventTypeNum EventType
m2 = [EventType] -> Map EventTypeNum EventType
headerMap forall a b. (a -> b) -> a -> b
$ Header -> [EventType]
eventTypes Header
h2
      combine :: a -> a -> a
combine a
et1 a
et2 | a
et1 forall a. Eq a => a -> a -> Bool
== a
et2 = a
et1
      combine a
_ a
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"can't merge event logs with inconsistent headers"
      m :: Map EventTypeNum EventType
m = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall {a}. Eq a => a -> a -> a
combine Map EventTypeNum EventType
m1 Map EventTypeNum EventType
m2
      h :: Header
h = [EventType] -> Header
Header forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems Map EventTypeNum EventType
m
  in Header
h forall a. Eq a => a -> a -> Bool
== Header
h seq :: forall a b. a -> b -> b
`seq`  -- Detect inconsistency ASAP.
     Header -> Data -> EventLog
EventLog Header
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Data
Data forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn Event -> Timestamp
evTime [Event]
xs 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 :: forall b a. Ord b => (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 forall a. Ord a => a -> a -> Bool
<= a -> b
f a
y = a
x forall a. a -> [a] -> [a]
: forall b a. Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn a -> b
f [a]
xs (a
yforall a. a -> [a] -> [a]
:[a]
ys)
                        | Bool
otherwise  = a
y forall a. a -> [a] -> [a]
: forall b a. Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn a -> b
f (a
xforall 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
(<>) = 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 (forall a. Ord a => a -> a -> a
max Word32
a Word32
x) (Int
b forall a. Num a => a -> a -> a
+ Int
y) (forall a. Ord a => a -> a -> a
max Word32
c Word32
z)
    -- avoid space leaks:
    mconcat :: [MaxVars] -> MaxVars
mconcat = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Monoid a => a -> a -> a
mappend 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 = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (EventInfo -> MaxVars
maxSpec 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) = forall a. Monoid a => a
mempty { mcap :: Int
mcap = Int
n }
    -- Threads start at 1.
    maxSpec (CreateThread Word32
t) = forall a. Monoid a => a
mempty { mthread :: Word32
mthread = Word32
t }
    maxSpec (CreateSparkThread Word32
t) = forall a. Monoid a => a
mempty { mthread :: Word32
mthread = Word32
t }
    -- Capsets start at 0.
    maxSpec (CapsetCreate Word32
cs CapsetType
_) = forall a. Monoid a => a
mempty {mcapset :: Word32
mcapset = Word32
cs forall a. Num a => a -> a -> a
+ Word32
1 }
    maxSpec EventInfo
_  = forall a. Monoid a => a
mempty

sh :: Num a => a -> a -> a
sh :: forall a. Num a => a -> a -> a
sh a
x a
y = a
x 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 {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) = 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 forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> a
sh Word32
mt Word32
t
    shift' (RunThread Word32
t) = Word32 -> EventInfo
RunThread forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> a
sh Word32
mt Word32
t
    shift' (StopThread Word32
t ThreadStopStatus
s) = Word32 -> ThreadStopStatus -> EventInfo
StopThread (forall a. Num a => a -> a -> a
sh Word32
mt Word32
t) ThreadStopStatus
s
    shift' (ThreadRunnable Word32
t) = Word32 -> EventInfo
ThreadRunnable forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> a
sh Word32
mt Word32
t
    shift' (MigrateThread Word32
t Int
c) = Word32 -> Int -> EventInfo
MigrateThread (forall a. Num a => a -> a -> a
sh Word32
mt Word32
t) (forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (WakeupThread Word32
t Int
c) = Word32 -> Int -> EventInfo
WakeupThread (forall a. Num a => a -> a -> a
sh Word32
mt Word32
t) (forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (ThreadLabel Word32
t Text
l) = Word32 -> Text -> EventInfo
ThreadLabel (forall a. Num a => a -> a -> a
sh Word32
mt Word32
t) Text
l
    shift' (CreateSparkThread Word32
t) = Word32 -> EventInfo
CreateSparkThread (forall a. Num a => a -> a -> a
sh Word32
mt Word32
t)
    shift' (SparkSteal Int
c) = Int -> EventInfo
SparkSteal (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 (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 (forall a. Num a => a -> a -> a
sh Int
mc Int
c1) (forall a. Num a => a -> a -> a
sh Int
mc Int
c2)
    shift' (CapCreate Int
c) = Int -> EventInfo
CapCreate (forall a. Num a => a -> a -> a
sh Int
mc Int
c)  -- TODO: correct?
    shift' (CapDelete Int
c) = Int -> EventInfo
CapDelete (forall a. Num a => a -> a -> a
sh Int
mc Int
c)  -- TODO: correct?
    shift' (CapDisable Int
c) = Int -> EventInfo
CapDisable (forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (CapEnable Int
c) = Int -> EventInfo
CapEnable (forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (CapsetCreate Word32
cs CapsetType
cst) = Word32 -> CapsetType -> EventInfo
CapsetCreate (forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) CapsetType
cst
    shift' (CapsetDelete Word32
cs) = Word32 -> EventInfo
CapsetDelete (forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs)
    shift' (CapsetAssignCap Word32
cs Int
c) = Word32 -> Int -> EventInfo
CapsetAssignCap (forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) (forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (CapsetRemoveCap Word32
cs Int
c) = Word32 -> Int -> EventInfo
CapsetRemoveCap (forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) (forall a. Num a => a -> a -> a
sh Int
mc Int
c)
    shift' (RtsIdentifier Word32
cs Text
rts) = Word32 -> Text -> EventInfo
RtsIdentifier (forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) Text
rts
    shift' (ProgramArgs Word32
cs [Text]
as) = Word32 -> [Text] -> EventInfo
ProgramArgs (forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) [Text]
as
    shift' (ProgramEnv Word32
cs [Text]
es) = Word32 -> [Text] -> EventInfo
ProgramEnv (forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) [Text]
es
    shift' (OsProcessPid Word32
cs Word32
pid) = Word32 -> Word32 -> EventInfo
OsProcessPid (forall a. Num a => a -> a -> a
sh Word32
mcs Word32
cs) Word32
pid
    shift' (OsProcessParentPid Word32
cs Word32
ppid) = Word32 -> Word32 -> EventInfo
OsProcessParentPid (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 (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