module GHC.RTS.Events.Merge (mergeEventLogs) where
import GHC.RTS.Events
import Data.Monoid
import Data.List (foldl')
import Data.Word (Word32, Word16)
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"
mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn f [] ys = ys
mergeOn f xs [] = xs
mergeOn f (x:xs) (y:ys) | f x <= f y = x : mergeOn f xs (y:ys)
| otherwise = y : mergeOn f (x:xs) ys
data MaxVars = MaxVars { mcapset :: !Word32
, mcap :: !Int
, mthread :: !ThreadId }
instance Monoid MaxVars where
mempty = MaxVars 0 0 1
mappend (MaxVars a b c) (MaxVars x y z) = MaxVars (max a x) (max b y) (max c z)
mconcat = foldl' mappend mempty
isCap :: Int -> Bool
isCap x = fromIntegral x /= ((1) :: Word16)
maxVars :: [Event] -> MaxVars
maxVars = mconcat . map (maxSpec . spec)
where
maxSpec (Startup n) = mempty { mcap = n 1 }
maxSpec (CreateThread t) = mempty { mthread = t }
maxSpec (CreateSparkThread t) = mempty { mthread = t }
maxSpec (CapsetCreate cs _) = mempty {mcapset = cs }
maxSpec (EventBlock _ _ es) = maxVars es
maxSpec _ = mempty
sh :: Num a => a -> a -> a
sh x y = x + y + 1
shift :: MaxVars -> [Event] -> [Event]
shift mv@(MaxVars mcs mc mt) = map (\(Event t s) -> Event t $ shift' s)
where
shift' (EventBlock et c bs) = EventBlock et (msh c) $ shift mv bs
where msh x = if isCap x then sh mc x else x
shift' (CreateThread t) = CreateThread $ sh mt t
shift' (RunThread t) = RunThread $ sh mt t
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' (CapsetCreate cs cst) = CapsetCreate (sh mcs cs) cst
shift' (CapsetDelete cs) = CapsetDelete (sh mcs cs)
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' x = x