    {-# 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 = [(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 :: EventTypeNum
    num :: EventType -> 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 :: a -> a -> a
    combine a
    et1 a
    et2 | a
    et1 a -> a -> Bool
    forall a. Eq a => a -> a -> Bool
    == a
    et2 = a
    et1
          combine a
    _ a
    _ = [Char] -> a
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "can't merge event logs 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 {a}. Eq a => a -> a -> a
    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
    forall a b. a -> b -> b
    `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 :: 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 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 b a. (b -> a -> b) -> b -> [a] -> b
    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 = n }
        -- Threads start at 1.
        maxSpec (CreateThread Word32
    t) = MaxVars
    forall a. Monoid a => a
    mempty { mthread = t }
        maxSpec (CreateSparkThread Word32
    t) = MaxVars
    forall a. Monoid a => a
    mempty { mthread = t }
        -- Capsets start at 0.
        maxSpec (CapsetCreate Word32
    cs CapsetType
    _) = MaxVars
    forall a. Monoid a => a
    mempty {mcapset = cs + 1 }
        maxSpec EventInfo
    _  = MaxVars
    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 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 {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