EdenTV Project.
The Haskell-based viewer. Port to new GHC events.
\begin{code}
{-# OPTIONS -XNamedFieldPuns #-}
module RTSEventsParserOLD where
import Text.Printf
import qualified EdenTvType as E
import GHC.RTS.Events
import TinyZipper
import Data.Binary.Get
import Control.Monad
import Control.Monad.Error
import Data.ByteString.Lazy (ByteString)
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad
import Control.Monad.State
import Data.Maybe
--import Data.IntMap (IntMap)
--import qualified Data.IntMap as M
import Data.Either
import Data.Tree
import List
import qualified Data.HashMap as Hash
import qualified Control.Exception as C
import Debug.Trace
data Err a = Ok !a | Failed String
\end{code}
----------------------------------
--
-- Reader function
--
----------------------------------
We mimic the behaviour of the original reader function @toEvents@.
-- TraceParser.hs
data Err a = Ok !a | Failed String
toEvents :: [Char] -> Err Events
toEvents [] = Failed "File empty"
toEvents ts = Ok ...
-- EdenTvTypes.hs
type Events = (([Machine],[Process],[Thread]),[(MachineID,Double)],MessageList,(Seconds,Seconds,Double,Double),(Int,Int,Int))
-- loM loP loT machine starttimes msgs/heads min_t max_t maxMsgSize MaxLD #M #P #T
oh my...
------------------------------------
We need to read events from a bytestring!
-- GHC.RTS.Events says:
readEventLogFromFile :: FilePath -> IO (Either String EventLog)
readEventLogFromFile f = do
s <- L.readFile f
return $ runGet (do v <- runErrorT $ getEventLog
m <- isEmpty
m `seq` return v) s
\begin{code}
readGhcEventsSingle :: ByteString -> IO (Either String EventLog)
readGhcEventsSingle s = return $ runGet (do v <- runErrorT $ getEventLog
m <- isEmpty
m `seq` return v) $ s
\end{code}
Now we can read events from a bytestring!
\begin{code}
type RTSEvents = (E.MachineID, [Event])
readOne :: EventLog -> Either String RTSEvents
readOne evtlog = let ghcevents = map ce_event $ sortEvents (events $ dat evtlog)
mID = getMachineID ghcevents
in either (\err -> Left err) (\id -> Right (id, ghcevents)) mID
where getMachineID :: [Event] -> Either String E.MachineID
getMachineID ((Event{time, spec=CreateMachine{machine}}):_) =
Right $ fromIntegral machine
getMachineID (_:xs) = getMachineID xs
getMachineID [] = Left "readSingle: No Create Machine Event found"
\end{code}
As we can read events from a single stream, we can also read multiple event
files from a zip archive
\begin{code}
readAll :: FilePath -> IO (Either String [RTSEvents])
readAll zippath = do
files' <- readZip zippath
either (\err -> return $ Left err)
(\files -> do
eventlogs <- sequence $ map readGhcEventsSingle files
let (errparse, logs) = partitionEithers eventlogs
case null errparse of
True -> do
let (errevts, events) = partitionEithers $ map readOne logs
case null errevts of
False -> return $ Left "readAll: Events error"
True -> return $ Right events
False -> return $ Left "readAll: Parse error")
files'
{-
We need to catch Exceptions here, because getEventLog (GHC.RTS.Events) uses Lazy Bytestrings and
non-strict Get!
-}
parseRawFile :: FilePath -> IO (Either String [RTSEvents])
parseRawFile zipfile = C.catch (readAll zipfile) catchBadFile
where catchBadFile :: C.SomeException -> IO (Either String [RTSEvents])
catchBadFile e = return (Left "Parse: Bad File")
\end{code}
we want to know how long a message was processed
- when an EdenStartReceive Event is found we store the startTime and go on searching
for received Messages in this block, until the matching EdenEndReceive Event is found.
- for each process found in this block we store the process id and receive time, so that we can
seperate the blocks in Process view
\begin{code}
getReceiveLengths :: [(E.MachineID, Double)] -> [(E.MachineID, [Event])] -> [E.ReceiveLength]
getReceiveLengths syncTimes ((mID, events):otherMachines) = (process mID events) ++ (getReceiveLengths syncTimes otherMachines)
where process :: E.MachineID -> [Event] -> [((E.MachineID,[(Int,E.Seconds)]), E.Seconds, E.Seconds)]
process mID (event:events) = case (spec event) of
EdenStartReceive -> case endT of
(-1) -> process mID events -- skip faulty (no EdenEndReceive Event found)
_ -> ((mID, pID), startT, endT) : (process mID events) -- block ok, store and do next
where pID = getProcessID events -- scan for receiving processes and their receive times
startT = convertTimestampWithSync (toSyncTime syncTimes mID) (time event)
endT = getEndTime events
getEndTime :: [Event] -> E.Seconds
getEndTime (event:events) = case (spec event) of
EdenEndReceive -> convertTimestampWithSync (toSyncTime syncTimes mID) (time event)
_ -> getEndTime events
getEndTime [] = (-1)
eventTime e = convertTimestampWithSync (toSyncTime syncTimes mID) (time e)
getProcessID :: [Event] -> [(Int,E.Seconds)]
getProcessID (event:events) = case (spec event) of
ReceiveMessage RFork _ _ _ _ _ _ -> getProcessID events
CreateProcess p -> (fromIntegral p, eventTime event) : (getProcessID events)
ReceiveMessage _ _ _ _ _ _ _ -> (fromIntegral $ receiverProcess (spec event), eventTime event) : (getProcessID events)
EdenEndReceive -> []
_ -> getProcessID events
getProcessID [] = []
_ -> process mID events
process _ [] = []
getReceiveLengths _ [] = []
\end{code}
time in the tracefile is stored in ticks, which are not comparable between machines.
to match times between traces we calculate a realtime offset for each machine,
stored in a (ID,Seconds) List
This helper function retrieves the realtime offset for a given machine id.
\begin{code}
toSyncTime :: [(E.MachineID, Double)] -> E.MachineID -> Double
toSyncTime ((mId, t):machines) i
| mId == i = t
| otherwise = toSyncTime machines i
toSyncTime [] _ = 0
\end{code}
Now we need to create the Eden Events structure.
For this we insert the events one by one into the Structure,
until all Events are processed.
\begin{code}
traceRTSFile :: FilePath -> IO (Err E.Events)
traceRTSFile file = do
ghcevents' <- parseRawFile file
case ghcevents' of
Left err -> return (Failed err)
Right ghcevents -> do
return (Ok injectedEvents)
where
-- insert events in final structure and close open messages
processedEvents = closeOpenLists $ process ghcevents emptyoe
-- inject additional information
injectedEvents = injectLOMessages leftMessages $ injectProcMessages $ injectMaxStartupDifference (maxStartupDifference maxEnd) $ injectStartupDifferences diffStartups $ injectReceiveTimes rcvTimes processedEvents
------------------------------
-- 'additional information' --
------------------------------
leftMessages = snd (processLeftOvers ghcevents ([],[]))
-- startup differences -- used for 'better aligning' machines
diffStartups = startupDifferences ghcevents (maxStartupTimeOfTrace ghcevents)
-- receive length -- used to draw small rectangles to show how long it took to receive a message
rcvTimes = getReceiveLengths syncTimes ghcevents
-- used for rescaling of x-axis when we align to startup times
endTimes = endTimesOfTrace ghcevents
maxEnd = getMaxEndTime processedEvents
-- tracefile only contains timestamp with 'TICKS' of local machine
-- we use this table to convert TICKS to global time
syncTimes = getSyncTimes (mainTimeOfTrace ghcevents) ghcevents
-- we need to store to which process a thread belongs
luptable = createThreadLookupTable ghcevents
-- from old haskell EdenTV
-- initial events structure
emptyoe = (([],[],[]),[(0,firstTime)], fml firstTime, (firstTime, firstTime, 0, -1))
where firstTime = minCreateMachineTimeOfTrace ghcevents
getMaxEndTime ((lom,lop,lot),mst, maxSt, rcv,(min_t, m_t,_,mmsg,mld),nums) = m_t
-- mainTime is the realtime of the first machine
mainTimeOfTrace :: [(E.MachineID, [Event])] -> Double
mainTimeOfTrace ((1,machine):machines) = realtimeOfMachine machine
mainTimeOfTrace (_:machines) = mainTimeOfTrace machines
mainTimeOfTrace [] = 0
-- syncTimes are the offset of machine-realtimes to the 'mainTime'
getSyncTimes :: Double -> [(E.MachineID, [Event])] -> [(E.MachineID, Double)]
getSyncTimes mainTime ((mID,evts):machines) = ((mID,t): (getSyncTimes mainTime machines))
where t = (realtimeOfMachine evts) - mainTime
getSyncTimes _ [] = []
-- injects the max startup difference time into the final Events structure
-- needed because insertEvent doesn't cover startup difference times
injectMaxStartupDifference :: E.Seconds -> E.Events -> E.Events
injectMaxStartupDifference time ((lom,lop,lot),mst, maxSt, rcv,(min_t, m_t,_,mmsg,mld),nums) = ((lom,lop,lot),mst,maxSt,rcv,(min_t,m_t,time,mmsg,mld),nums)
-- the maximal difference of startup times
-- used to re-calculate the latest time of all events
maxStartupDifference :: E.Seconds -> E.Seconds
maxStartupDifference maxE = let difftimes = zipWith (\(_, diffs) (_,end) -> if diffs + end > maxE then (diffs+end)-maxE else 0) (snd diffStartups) endTimes
in seq difftimes $ maximum difftimes
-- times of last event of all machines
endTimesOfTrace :: [(E.MachineID, [Event])] -> [(E.MachineID, E.Seconds)]
endTimesOfTrace evts = map endTime evts
where endTime (mID, evt) = (mID, convertTimestampWithSync (toSyncTime syncTimes mID) $ time $ last evt)
-- injects the receive times into the final Events structure
-- needed because insertEvent doesn't cover receive times
injectReceiveTimes :: [E.ReceiveLength] -> E.Events -> E.Events
injectReceiveTimes inj ((lom,lop,lot),mst, maxSt, (ml,aml,hml,pt, _ ),stats,nums) = ((lom,lop,lot),mst,maxSt,(ml,aml,hml,pt, inj ),stats,nums)
-- injects the left out Head Messages
-- needed because insertEvent throws them away
injectLOMessages :: [E.Message] -> E.Events -> E.Events
injectLOMessages inj ((lom,lop,lot),mst, maxSt, (ml,_,hml,pt, rcvl ),stats,nums) = ((lom,lop,lot),mst,maxSt,(ml,inj,hml,pt, rcvl ),stats,nums)
-- injects the startup differences into the final Events structure
-- needed because insertEvent doesn't cover startup differences
injectStartupDifferences :: (E.Seconds,[(Int,E.Seconds)]) -> E.Events -> E.Events
injectStartupDifferences inj ((lom,lop,lot),mst, _ ,(ml,aml,hml,pt, rcvl ),stats,nums) = ((lom,lop,lot),mst, inj,(ml,aml,hml,pt, rcvl ),stats,nums)
-- builds startup differences table of a trace
-- trace -> maxStartupTime of Trace -> (maxStartupTime, diffTable)
startupDifferences :: [(E.MachineID, [Event])] -> E.Seconds -> (E.Seconds, [(Int,E.Seconds)])
startupDifferences ((mId,evts):machines) maxS = let s = convertTimestampWithSync (toSyncTime syncTimes mId) (startupTimestampOfMachine evts)
in seq s (maxS,((mId,(maxS-s)): (startupDifferences' machines maxS)))
where startupDifferences' ((mId,evts):machines) maxS = let s = convertTimestampWithSync (toSyncTime syncTimes mId) (startupTimestampOfMachine evts)
in seq s ((mId,(maxS-s)): (startupDifferences' machines maxS))
startupDifferences' [] _ = []
startupDifferences [] _ = (0,[])
-- from old haskell EdenTV
-- creates initial MessageList
fml :: E.Seconds -> E.OpenMessageList
fml t = ([],[],([(1,[((1,1),E.OSM t (0,0) (-1) (-1) 85)],[((0,0),E.ORM t (1,1) (-1) (-1) 85 4)],[])],[((0,0),[])],Node (0,0) []),([],0,[]))
-- determines the earliest CreateMachine time from all Machines -- which is equivalent with the earliest event time
minCreateMachineTimeOfTrace :: [(E.MachineID, [Event])] -> E.Seconds
minCreateMachineTimeOfTrace = minimum . map (\(mID, machine) -> convertTimestampWithSync (fromMaybe 0 $ lookup mID syncTimes) (createmachineTimestampOfMachine machine))
-- determines the latest Startup time from all Machies
maxStartupTimeOfTrace :: [(E.MachineID, [Event])] -> E.Seconds
maxStartupTimeOfTrace = maximum . map (\(mID, machine) -> convertTimestampWithSync (fromMaybe 0 $ lookup mID syncTimes) (startupTimestampOfMachine machine))
-- extracts the CreateMachine Timestamp of a list of all Machine Events
createmachineTimestampOfMachine :: [Event] -> Timestamp
createmachineTimestampOfMachine ((Event {time, spec=CreateMachine{}}):xs) = time
createmachineTimestampOfMachine (_:xs) = createmachineTimestampOfMachine xs
createmachineTimestampOfMachine _ = error "No Machine created"
-- extracts the realtime of a list of all Machine Events
realtimeOfMachine :: [Event] -> Double
realtimeOfMachine ((Event {time, spec=CreateMachine{realtime}}):xs) = ((fromIntegral realtime)/10e7)-((fromIntegral time) / 10e8)
realtimeOfMachine (_:xs) = realtimeOfMachine xs
realtimeOfMachine _ = error "No realtime found"
-- extracts the Startup Timestamp of a list of all Machine Events
startupTimestampOfMachine :: [Event] -> Timestamp
startupTimestampOfMachine ((Event { time, spec=Startup { n_caps } }) :xs) = time
startupTimestampOfMachine (_:xs) = startupTimestampOfMachine xs
startupTimestampOfMachine _ = error "No Machine started"
-- walks over the list of machines (which contains all events for this machine) and inserts all events
-- in an accumulated OpenEvents structure
-- when no events are left, we are finished and just need to close open lists in the generated structure
process :: [(E.MachineID, [Event])] -> E.OpenEvents -> E.OpenEvents
process ((mID, (evt:evts)):machines) oe = let convertTimestamp = convertTimestampWithSync (toSyncTime syncTimes mID)
newOE = insertEvent convertTimestamp luptable (mID,evt) oe
in seq newOE $ process ((mID,evts):machines) newOE
process ((_,[]):machines) oe = process machines oe
process [] oe = oe
-- insertLeftOutMessages :: E.ProcessID -> E.OpenMessageEvent -> ([OpenMessage],[Message]) -> ([OpenMessage],[Message])
processLeftOvers :: [(E.MachineID, [Event])] -> ([E.OpenMessage],[E.Message]) -> ([E.OpenMessage],[E.Message])
processLeftOvers ((mID, (evt:evts)):machines) oe = let convertTimestamp = convertTimestampWithSync (toSyncTime syncTimes mID)
in case spec evt of
SendMessage{
mesTag,
senderProcess,
senderThread,
receiverMachine,
receiverProcess,
receiverInport} -> let newOE = insertLeftOutMessages (mID, (fromIntegral senderProcess))
(E.OSM (convertTimestamp (time evt)) (fromIntegral receiverMachine, fromIntegral receiverProcess) (fromIntegral senderThread) (fromIntegral receiverInport) (readTag mesTag))
oe
in processLeftOvers ((mID,evts):machines) newOE
ReceiveMessage{
mesTag,
receiverProcess,
receiverInport,
senderMachine,
senderProcess,
senderThread,
messageSize} -> let newOE = insertLeftOutMessages ((fromIntegral senderMachine), (fromIntegral senderProcess))
(E.ORM (convertTimestamp (time evt)) (mID, fromIntegral receiverProcess) (fromIntegral senderThread) (fromIntegral receiverInport) (readTag mesTag) (fromIntegral messageSize))
oe
in processLeftOvers ((mID,evts):machines) newOE
_ -> processLeftOvers ((mID,evts):machines) oe
processLeftOvers ((_,[]):machines) oe = processLeftOvers machines oe
processLeftOvers [] oe = oe
-- Manually build Process Table
-- and ProcMessages (needed because wrong results
-- when those messages are processed in a 'wrong' order, and
-- finding the right order is just as complex as this)
sendRForks = map (\(mID, evts) -> (mID, filter (isSendRFork) evts)) ghcevents
isSendRFork :: Event -> Bool
isSendRFork evt = case spec evt of
SendMessage{mesTag=RFork} -> True
_ -> False
rcv_crtRForks = map (\(mID, evts) -> (mID, filter (\evt -> case spec evt of ReceiveMessage{mesTag=RFork} -> True; CreateProcess{} -> True; _ -> False) evts)) ghcevents
injectProcMessages :: E.Events -> E.Events
injectProcMessages ((lom,lop,lot),mst, inj ,(ml,aml,hml,pt, rcvl ),stats,nums) = ((lom,lop,lot),mst, inj,(ml++procMessages,aml,hml,processTree, rcvl ),stats,nums)
childTable :: [(E.ProcessID, [E.ProcessID])]
procMessages :: [E.Message]
(childTable,procMessages) = createChildTable sendRForks rcv_crtRForks [] []
processTree :: E.ProcessTree
processTree = unfoldTree buildTree ((1,1), fromJust (lookup (1,1) childTable))
buildTree :: (E.ProcessID, [E.ProcessID]) -> (E.ProcessID, [(E.ProcessID, [E.ProcessID])])
buildTree (pid, pids) = (pid, map (\p -> let mps = lookup p childTable
in case mps of
Nothing -> (p, [])
Just ps -> (p, ps)) pids)
createChildTable :: [(E.MachineID, [Event])] -> [(E.MachineID, [Event])] -> [(E.ProcessID, [E.ProcessID])] -> [E.Message] -> ([(E.ProcessID, [E.ProcessID])], [E.Message])
createChildTable ((mID, evt:evts):machines) rcvers table procMsgs=
let SendMessage{senderProcess,receiverMachine} = spec evt
senderProc = (mID, fromIntegral sProc)
receiverMach = fromIntegral receiverMachine
sMach = fromIntegral mID
sProc = senderProcess
sTime = convertTimestampWithSync (toSyncTime syncTimes mID) (time evt)
Just rcvEvents = lookup receiverMach rcvers
(childId, remainingEvents, child) = nextChildId rcvEvents
childProcess = (receiverMach, childId)
newRcvers = updateReceivers receiverMach rcvers remainingEvents
newTable = addChild table senderProc childProcess
newProcMsgs = child:procMsgs
addChild :: [(E.ProcessID, [E.ProcessID])] -> E.ProcessID -> E.ProcessID -> [(E.ProcessID, [E.ProcessID])]
addChild (cur@(pid, childs):pids) father child
| pid == father = ((pid, (child:childs)):pids)
| otherwise = cur : (addChild pids father child)
addChild [] father child = [(father, [child])]
updateReceivers :: E.MachineID -> [(E.MachineID, [Event])] -> [Event] -> [(E.MachineID, [Event])]
updateReceivers i (mach@(mID, evts):machines) update
| mID == i = ((mID, update):machines)
| otherwise = mach : (updateReceivers i machines update)
updateReceivers _ [] _ = error "not updated"
nextChildId (e:es) = case spec e of
ReceiveMessage{senderMachine,senderProcess,
messageSize} -> if senderMachine == sMach && senderProcess == sProc
then let (Event{spec=CreateProcess{process}}, rest) = getNextAndRemove (\evt -> case spec evt of CreateProcess{} -> True; _ -> False) es
childId = fromIntegral process
channelID = (senderProc, 0, (receiverMach, childId),0)
rTime = convertTimestampWithSync (toSyncTime syncTimes receiverMach) (time e)
child = E.MSG channelID sTime rTime 85 (fromIntegral messageSize)
in (childId, rest, child)
else let (id, rest, child) = nextChildId es
in (id, e:rest, child)
_ -> let (id, rest, child) = nextChildId es
in (id, e:rest, child)
nextChildId [] = error "next child not found"
getNextAndRemove :: (a -> Bool) -> [a] -> (a, [a])
getNextAndRemove p (x:xs)
| p x = (x,xs)
| otherwise = let (y,ys) = getNextAndRemove p xs
in (y,x:ys)
getNextAndRemove _ [] = (error "next not found", [])
in createChildTable ((mID, evts):machines) newRcvers newTable newProcMsgs
createChildTable ((mID, []):machines) rcvers table procMsgs = createChildTable machines rcvers table procMsgs
createChildTable [] ecv table procMsgs = (table,procMsgs)
-- converts a timestamp in TICKS to Seconds with respect to a realtime offset 'sync'
convertTimestampWithSync :: E.Seconds -> Timestamp -> E.Seconds
convertTimestampWithSync sync x = sync + (fromIntegral x / 10e8)
readTag :: MessageTag -> Int
readTag tag = case tag of
-- Log.Ready -> 80
-- Log.NewPE -> 81
-- Log.PETIDS -> 82
-- Log.Finish -> 83
-- Log.Fail -> 84
RFork -> 85
Connect -> 86
DataMes -> 87
Head -> 88
Constr -> 89
Part -> 90
-- Log.Packet -> 92
Terminate -> 91
_ -> -1
type ThreadLookupMap = Hash.HashMap E.MachineID (Hash.HashMap Int Int)
createThreadLookupMap :: [(E.MachineID, [Event])] -> ThreadLookupMap
createThreadLookupMap list = let table = createThreadLookupTable list
hashv1 = map (\(mID, x) -> (mID, Hash.fromList x)) table
in Hash.fromList hashv1
createThreadLookupTable :: [(E.MachineID, [Event])] -> [(E.MachineID, [(Int, Int)])]
createThreadLookupTable ((mId, es):xs) = (mId, createTable es) : createThreadLookupTable xs
where createTable :: [Event] -> [(Int, Int)]
createTable ((Event{time,spec=AssignThreadToProcess{thread,process}}):es) = ((fromIntegral thread, fromIntegral process): createTable es)
createTable (_:es) = createTable es
createTable [] = []
createThreadLookupTable [] = []
type Lookuptable = [(E.MachineID, [(Int, Int)])]
lookupProcess :: Lookuptable -> E.MachineID -> Int -> Int
lookupProcess ((machine, es):ts) sMachine sThread = if machine == sMachine then lookupProcess' es sThread else lookupProcess ts sMachine sThread
where lookupProcess' lst@((x,y):xs) z = if x == z then y else lookupProcess' xs z
lookupProcess' [] z = error ("Thread not found" ++ (show sMachine) ++ " " ++ (show z))
lookupProcess [] sMachine sThread = error ("--Thread not found" ++ (show sMachine) ++ " " ++ (show sThread))
insertLeftOutMessages :: E.ProcessID -> E.OpenMessageEvent -> ([E.OpenMessage],[E.Message]) -> ([E.OpenMessage],[E.Message])
insertLeftOutMessages sp newMessage ocMsgs@(openMsgList, closedMessages)
| or [(tag == 88),(tag == 87)] = let ((_,sp'),(_,rp')) = (sp, rp)
in if (min sp' rp') >= 0
then seq oml (seq cml (oml,cml))
else ocMsgs
| otherwise = ocMsgs
where (time, rp@(rm,_),out,inp,tag,size) = case newMessage of
E.ORM t p o i r s -> (t,p,o,i,r,s)
E.OSM t p o i r -> (t,p,o,i,r,0)
(oml,cml) = searchID openMsgList
searchID :: [E.OpenMessage] -> ([E.OpenMessage], [E.Message])
searchID oml@(om@(iB,msgs):oms)
| sp > iB = seq cms' (seq oms' (om:oms',cms')) -- go on
| sp == iB = if null newOms -- OMList found => look for matching message
then (oms,newCms)
else ((iB, newOms):oms,newCms)
| otherwise = ((sp,[newMessage]):oml,closedMessages) -- no OMList for threadId found
where (oms',cms') = searchID oms -- recurse
(newOms,newCms) = insertOrReplace msgs -- try to find matching OpenMessage
insertOrReplace :: [E.OpenMessageEvent] -> ([E.OpenMessageEvent], [E.Message])
insertOrReplace (o:os) = case closeMessage o newMessage of
Nothing -> seq os' (o:os', cls')
Just c -> (os, c:closedMessages)
where (os',cls') = insertOrReplace os
insertOrReplace [] = ([newMessage],closedMessages)
closeMessage :: E.OpenMessageEvent -> E.OpenMessageEvent -> Maybe E.Message
closeMessage (E.OSM t1 p1 o1 i1 r1) (E.ORM t2 p2 o2 i2 r2 s2)
| and [p1==p2, o1==o2, i1==i2, r1==r2] = Just (E.MSG (sp,o1,p1,i1) t1 t2 r1 s2)
| otherwise = Nothing
closeMessage (E.ORM t2 p2 o2 i2 r2 s2) (E.OSM t1 p1 o1 i1 r1)
| and [p1==p2, o1==o2, i1==i2, r1==r2] = Just (E.MSG (sp,o1,p1,i1) t1 t2 r1 s2)
| otherwise = Nothing
closeMessage _ _ = Nothing
searchID [] = ([(sp, [newMessage])], closedMessages)
-- legacy code of old haskell EdenTV
-- modified to work with new Tracefile Format
insertEvent :: (Timestamp -> E.Seconds) -> Lookuptable -> (E.MachineID, Event) -> E.OpenEvents -> E.OpenEvents
insertEvent convertTimestamp lutable (mId, Event{time, spec}) oldEvents@(oEvts@(ms,ps,ts),mts,ocMsgs,(minTime,maxTime,nP,maxLD))
| isMsgEvent = seq newMsgEvents ((newMs, newPs,ts),mts,newMsgEvents,(minTime,newMax,nP,maxLD)) -- process the event
| isTrdEvent = let (newTData, mPE) = newTrdEvents
(newPData, mME) = case mPE of
[] -> (ps, []) -- no virtual process event
pe -> insPEventList pe ps -- insert generated process event
newMData = case mME of
[] -> ms -- no virtual machine event
me -> insMEventList mId me ms -- insert generated machine event
in seq newMData ((newMData, newPData, newTData),mts,ocMsgs,(minTime,newMax,nP,maxLD))
| isPrcEvent = let (newPData,mME) = newPrcEvents
newMData = case mME of
Nothing -> ms -- no virtual machine event
Just me -> insMEvent mId me ms -- virtual machine event generated
in seq newMData ((newMData,newPData,ts),mts,newOcMsgs,(minTime,newMax,newNP,maxLD))
| isMchEvent = let newData = case gcEvents of
Nothing -> (newMchEvents, ps, ts)
Just (p,t) -> let newPE = insPeByMID mId p ps
newTE = insTeByMID mId t ts
in (newMchEvents, newPE, newTE)
in seq newData (newData,newMchTimes,ocMsgs,(min',max',nP,maxLD'))
| otherwise = oldEvents -- ignore unknown events
where
(isMsgEvent, newMsgEvents, newMs, newPs) = case spec of
SendMessage{mesTag=Connect} -> (False, undefined, undefined, undefined) -- ignore
SendMessage{
mesTag,
senderProcess,
senderThread,
receiverMachine,
receiverProcess,
receiverInport} -> (True, createNewMsgEvents (mId, fromIntegral senderProcess)
(E.OSM (convertTimestamp time) (fromIntegral receiverMachine, fromIntegral receiverProcess)
(fromIntegral senderThread) (fromIntegral receiverInport) (readTag mesTag)), nms, nps)
ReceiveMessage{
mesTag,
receiverProcess,
receiverInport,
senderMachine,
senderProcess,
senderThread,
messageSize} -> (True, createNewMsgEvents (fromIntegral senderMachine, fromIntegral senderProcess)
(E.ORM (convertTimestamp time) (mId, fromIntegral receiverProcess)
(fromIntegral senderThread) (fromIntegral receiverInport) (readTag mesTag) (fromIntegral messageSize)), nms, nps)
_ -> (False, undefined, undefined, undefined)
where createNewMsgEvents i event = insertMessage i event ocMsgs
proc = case spec of SendMessage _ p _ _ _ _ -> fromIntegral p; ReceiveMessage _ p _ _ _ _ _ -> fromIntegral p
(nms, nps) = increaseMsgCount (mId, proc) ms ps spec
(isTrdEvent,newTrdEvents) = case spec of
RunThread {
thread } -> (True, newEvents (E.RunThread (convertTimestamp time)))
AssignThreadToProcess {
thread,
process} -> (True, newEvents (E.NewThread (convertTimestamp time) (0))) -- #####hack outport? always zero in toSDDF
StopThread {
thread,
status} -> case status of
ThreadFinished -> (True, newEvents (E.KillThread (convertTimestamp time)))
ThreadBlocked -> (True, newEvents (E.BlockThread (convertTimestamp time) (0) (1))) -- ####hack inport? reason?
_ -> (True, newEvents (E.SuspendThread (convertTimestamp time)))
WakeupThread {
thread,
otherCap} -> (True, newEvents (E.DeblockThread (convertTimestamp time)))
_ -> (False, undefined)
where proc = lookupProcess lutable mId thre -- hack
thre = fromIntegral (thread spec) -- hack
newEvents evt = insertThreadEvent ((mId, proc), thre) evt ts
(isPrcEvent,newPrcEvents,newOcMsgs,newNP) = case spec of
CreateProcess {
process} -> (True, newEvents (E.NewProcess (convertTimestamp time)), ocMsgs, nP + 1)
KillProcess {
process} -> (True, newEvents (E.KillProcess (convertTimestamp time) (0,0,0)), delFromProcList (mId,fromIntegral process) ocMsgs, nP)
_ -> (False, undefined, undefined, undefined)
where newEvents evt = insPEvent (mId, fromIntegral (process spec)) evt ps
(isMchEvent,newMchEvents,newMchTimes,maxLD',gcEvents) = case spec of
CreateMachine{} -> (True, newEvents (E.StartMachine (convertTimestamp time)), (mId, convertTimestamp time):mts, maxLD, Nothing)
Startup{n_caps} -> (True, ms, mts, maxLD, Nothing)
KillMachine _ -> (True, newEvents (E.EndMachine (convertTimestamp time)), mts, maxLD, Nothing)
-- JB, WAS: 849 ->
--233 -> (True, newEvents (GCMachine getGCTime v2 v3 v4 v5), mts, max maxLD v5, -- hack todo GC
-- Just (GCProcess getGCTime v2 v3 v4 v5, GCThread getGCTime v2 v3 v4 v5))
_ -> (False, undefined, undefined, undefined, undefined)
where newEvents evt = insMEvent mId evt ms
-- compute new min/max times:
newMax = max (convertTimestamp time) maxTime
(min', max') = if (convertTimestamp time) > maxTime
then (minTime, (convertTimestamp time))
else (newMin, maxTime)
newMin :: E.Seconds
newMin = min (convertTimestamp time) minTime
insMEventList :: E.MachineID -> [E.MachineEvent] -> [E.Machine] -> [E.Machine]
insMEventList i (m:ms) lst = insMEvent i m (insMEventList i ms lst)
insMEventList _ _ lst = lst
insMEvent :: E.MachineID -> E.MachineEvent -> [E.Machine] -> [E.Machine]
insMEvent i1 evt lst@(e@(i2,allP,blkP,stat@(p,s,r),evts):es) -- insert in existing list of machines
| i2 > i1 = let es' = (insMEvent i1 evt es) in seq es' (e : es') -- go on
| i2 == i1 = let e' = insertHere in seq e' (e' : es) -- existing machine
| otherwise = (i1,0,0,(0,0,0),[evt]) : lst -- new machine => no processes
where insertHere = case evt of
E.MSuspendProcess sec -> let newEvts = case head evts of
E.SuspendedMachine _ -> evts
_ -> (E.SuspendedMachine sec):evts
in (i2,allP,blkP,stat,newEvts)
E.MRunProcess sec -> (i2,allP,blkP,stat,(E.RunningMachine sec):evts)
E.MBlockProcess sec -> let newBlkP = blkP + 1
newEvts = if newBlkP < allP
then (E.SuspendedMachine sec):evts
else (E.BlockedMachine sec):evts
in (i2,allP,newBlkP,stat,newEvts)
E.GCMachine _ _ _ _ _ -> (i2,allP,blkP,stat,evt:evts)
E.MNewProcess sec -> let newAllP = allP + 1
newEvts = if blkP == allP -- test if evt may be skipped:
then (E.SuspendedMachine sec):evts
else evts
in (i2,allP + 1,blkP,(p+1,s,r),newEvts)
E.MKillRProcess sec -> let newAllP = allP - 1
newEvts = if newAllP > 0
then (E.SuspendedMachine sec):evts
else (E.IdleMachine sec):evts
in (i2,newAllP,blkP,stat,newEvts)
E.MKillSProcess sec -> let newAllP = allP - 1
newEvts = if newAllP > 0
then evts
else (E.IdleMachine sec):evts
in (i2,newAllP,blkP,stat,newEvts)
E.MKillBProcess sec -> let newAllP = allP - 1
newBlkP = blkP - 1
newEvts = if newAllP > 0
then evts
else (E.IdleMachine sec):evts
in (i2,newAllP,newBlkP,stat,newEvts)
E.MIdleProcess sec -> let newEvts = case head evts of
E.SuspendedMachine _ -> evts
_ -> (E.SuspendedMachine sec):evts
in (i2,allP,blkP,stat,newEvts)
E.EndMachine _ -> (i2,0,0,stat,evt:evts)
_ -> error ("insMEvent: unknown event: " ++ show evt)
insMEvent i1 evt [] = [(i1,0,0,(0,0,0),[evt])] -- brand new machine => no processes
insPEventList :: [(E.ProcessID,E.ProcessEvent)] -> [E.Process] -> ([E.Process],[E.MachineEvent])
insPEventList ((i,p):ps) lst = let (ps',mes) = insPEventList ps lst
(lst',me) = insPEvent i p ps'
in case me of
Nothing -> (lst',mes)
Just me -> (lst',me:mes)
insPEventList _ lst = (lst,[])
insPeByMID :: E.MachineID -> E.ProcessEvent -> [E.Process] -> [E.Process]
insPeByMID i evt lst@(e@((m,_),_,_,_,_):es)
| i == m = insertHere lst -- first process on machine i found, insert event
| otherwise = let es' = insPeByMID i evt es in seq es' (e:es') -- search on
where insertHere lst@(e@(i'@(m,_),a,b,s,evts):es)
| i == m = let es' = insertHere es in case take 1 evts of
[E.KillProcess _ _] -> seq es' ( e : es') -- process not alive
[E.BlockedProcess _] -> seq es' ((i',a,b,s,(E.BlockedProcess (convertTimestamp time):evt:evts)):es')
[E.SuspendedProcess _] -> seq es' ((i',a,b,s,(E.SuspendedProcess (convertTimestamp time):evt:evts)):es')
_ -> seq es' ((i',a,b,s,evt:evts) : es') -- not possible?
| otherwise = lst -- all processes on machine i worked up
insertHere [] = []
insPEvent :: E.ProcessID -> E.ProcessEvent -> [E.Process] -> ([E.Process],Maybe E.MachineEvent)
insPEvent i1 evt lst@(e@(i2,allT,blkT,stat@(t,s,r),evts):es)
| i1 < i2 = let (es',mEvt) = insPEvent i1 evt es in seq es' (seq mEvt (e : es', mEvt))
| i1 == i2 = (insertHere : es, vMachineEvent) {- case evt of -- a new entry for every new process
NewProcess sec -> ((i1,0,0,(0,0,0),[evt]):lst, Just (MNewProcess time))
_ -> (insertHere : es, vMachineEvent) -}
| otherwise = ((i1,0,0,(0,0,0),[evt]):lst,Just (E.MNewProcess (convertTimestamp time))) -- new Process => evt == NewProcess
where (insertHere,vMachineEvent) = case evt of
E.PNewThread sec -> let newAllT = allT + 1
in if blkT == allT -- was Process blocked?
then ((i1,newAllT,blkT,(t+1,s,r),(E.SuspendedProcess sec):evts), Just (E.MSuspendProcess sec))
else ((i1,newAllT,blkT,(t+1,s,r),evts),Nothing)
E.PKillRThread sec -> let newAllT = allT - 1
(newEvts,newMEvt) = if newAllT > 0
then if blkT < newAllT
then ((E.SuspendedProcess sec):evts, Just (E.MSuspendProcess sec))
else ((E.BlockedProcess sec):evts, Just (E.MBlockProcess sec))
else case evts of
(E.KillProcess _ _:_) -> (evts, Nothing)
_ -> ((E.IdleProcess sec):evts, Just (E.MIdleProcess sec))
in ((i1,newAllT,blkT,stat,newEvts),newMEvt)
E.PKillSThread sec -> let newAllT = allT - 1
(newEvts,newMEvt) = if newAllT > 0
then if blkT < newAllT
then (evts, Nothing)
else ((E.BlockedProcess sec):evts, Just (E.MBlockProcess sec))
else case evts of
(E.KillProcess _ _:_) -> (evts, Nothing)
_ -> ((E.IdleProcess sec):evts, Just (E.MIdleProcess sec))
in ((i1,newAllT,blkT,stat,newEvts), newMEvt)
E.PKillBThread sec -> let newAllT = allT - 1
newBlkT = blkT - 1
(newEvts,newMEvt) = if newAllT > 0
then (evts, Nothing)
else case evts of
(E.KillProcess _ _:_) -> (evts, Nothing)
_ -> ((E.IdleProcess sec):evts, Just (E.MIdleProcess sec))
in ((i1,newAllT,newBlkT,stat,newEvts), newMEvt)
E.PRunThread sec -> ((i1,allT,blkT,stat,(E.RunningProcess sec):evts),Just (E.MRunProcess sec))
E.PSuspendThread sec -> ((i1,allT,blkT,stat,(E.SuspendedProcess sec):evts), Just (E.MSuspendProcess sec))
E.PBlockThread sec -> let newBlkT = blkT + 1
(newEvts,newMEvt) = if newBlkT < allT
then ((E.SuspendedProcess sec):evts,Just (E.MSuspendProcess sec))
else ((E.BlockedProcess sec):evts,Just (E.MBlockProcess sec))
in ((i1,allT,newBlkT,stat,newEvts),newMEvt)
E.PDeblockThread sec -> let newBlkT = blkT - 1
(newEvts,newMEvt) = if newBlkT < allT -- was process blocked?
then ((E.SuspendedProcess sec):evts,Just (E.MSuspendProcess sec))
else (evts,Nothing)
in ((i1,allT,newBlkT,stat,newEvts),newMEvt)
E.NewProcess sec -> ((i1,0,0,(t,s,r),(evt:evts)),Just (E.MNewProcess sec))
E.LabelProcess sec _ -> ((i1,allT,blkT,stat,evt:evts),Nothing)
-- KillProcess holds the statistic information for the ending process
E.KillProcess sec _ -> let evt' = E.KillProcess sec (t,s,r)
in case evts of
(E.RunningProcess _:_) -> ((i1,0,0,(0,0,0),(evt':evts)),Just (E.MKillRProcess sec))
(E.BlockedProcess _:_) -> ((i1,0,0,(0,0,0),(evt':evts)),Just (E.MKillBProcess sec))
_ -> ((i1,0,0,(0,0,0),(evt':evts)),Just (E.MKillSProcess sec))
_ -> error ("unknown event: " ++ show evt)
insPEvent i1 evt [] = ([(i1,0,0,(0,0,0),[evt])],Just (E.MNewProcess (convertTimestamp time))) -- new Process => evt == NewProcess
insTeByMID :: E.MachineID -> E.ThreadEvent -> [E.OpenThread] -> [E.OpenThread]
insTeByMID i evt lst@(e@(m,(lti,lte),ts):es)
| i == m = (m,(((m,-1),-1),evt),insertHere ts):es -- machine i found, insert event into threads; the ((m,-1),-1)
-- inserts 'evt' the next time insTEvent is run.
| otherwise = let es' = insTeByMID i evt es in seq es' (e:es') -- search on
where insertHere (l@(i,evts):ls) = let ls' = insertHere ls
in case take 1 evts of
-- skip already killed threads:
[E.KillThread _] -> seq ls' (l:ls') -- Thread already dead
-- The following entry describes the last suspended thread. The SuspendThread-event hasn't yet
-- been inserted, it resides in 'lte':
[E.RunThread _] -> seq ls' ((i,E.setEventTime lte (convertTimestamp time):evt:lte:evts):ls')
-- other threads are blocked or suspended:
[lastEvent] -> seq ls' ((i,E.setEventTime lastEvent (convertTimestamp time):evt:evts):ls')
insertHere [] = []
insertThreadEvent :: E.ThreadID -> E.ThreadEvent -> [E.OpenThread] -> ([E.OpenThread], [(E.ProcessID,E.ProcessEvent)])
insertThreadEvent i@((m,_),_) evt tl@(t@(im,(lti,lte),ts):tls)
| m < im = let (tls', pEvt') = insertThreadEvent i evt tls -- look for corresponding machine
in seq tls' (seq pEvt' (t:tls',pEvt')) -- recurse
| m == im = case lte of
E.SuspendThread _ -> case evt of
E.RunThread _ -> if i == lti
then ((im,(i,E.DummyThread),ts):tls,[]) -- suppress flattering
else bothEvents
_ -> bothEvents
E.DummyThread -> case evt of
E.SuspendThread _ -> ((im,(i,evt),ts):tls, []) -- deter SuspendThread-Event
_ -> let (ts',pEvt') = insTEvent' i evt ts in ((im,(i,E.DummyThread),ts'):tls,[(t2pID i,pEvt')])
otherwise -> insertThreadEvent i evt tls
| otherwise = ((m,(i,E.DummyThread),[(i,[evt])]):tl,[(t2pID i,vProcessEvent evt [])]) -- new machine
where bothEvents = let (ts2,pEvt2) = insTEvent' lti lte ts
(ts3,pEvt3) = insTEvent' i evt ts2
in ((im,(i,E.DummyThread),ts3):tls,[(t2pID i,pEvt3),(t2pID lti,pEvt2)])
insertThreadEvent i@((m,_),_) evt [] = ([(m,(i,E.DummyThread),[(i,[evt])])],[(t2pID i,vProcessEvent evt [])])
insTEvent' :: E.ThreadID -> E.ThreadEvent -> [E.Thread] -> ([E.Thread],E.ProcessEvent)
insTEvent' i@((m,_),t) ne lst@(e@(ib@((im,_),it),evts):es)
| i' < ib' = let (es', mEvt') = (insTEvent' i ne es) in seq es' (seq mEvt' (e:es',mEvt'))
| i' == ib' = ((i,(ne:evts)):es, vProcessEvent ne evts)
| otherwise = ((i,[ne]):lst,vProcessEvent ne evts)
where
i' = (m,t)
ib' = (im,it)
insTEvent' i evt _ = ([(i,[evt])],vProcessEvent evt [])
vProcessEvent :: E.ThreadEvent -> [E.ThreadEvent] -> E.ProcessEvent
vProcessEvent evt evts = case evt of
E.KillThread sec -> case evts of
(E.BlockThread _ _ _:_) -> E.PKillBThread sec
(E.RunThread _ :_) -> E.PKillRThread sec
_ -> E.PKillSThread sec
E.RunThread sec -> E.PRunThread sec
E.SuspendThread sec -> E.PSuspendThread sec
E.BlockThread sec _ _ -> E.PBlockThread sec
E.DeblockThread sec -> E.PDeblockThread sec
E.NewThread _ _ -> E.PNewThread (convertTimestamp time)
increaseMsgCount :: E.ProcessID -> [E.Machine] -> [E.Process] ->
EventTypeSpecificInfo -> ([E.Machine], [E.Process])
increaseMsgCount pID@(mID,_) ml pl spec = (incM ml, incP pl)
where incM :: [E.Machine] -> [E.Machine]
incM (m@(i, aP, bP, (p,s,r), es):ms)
| i > mID = m : incM ms -- go on
| i == mID = case spec of
SendMessage _ _ _ _ _ _ -> ((i, aP, bP, (p, s+1, r), es):ms)
ReceiveMessage _ _ _ _ _ _ _ -> ((i, aP, bP, (p, s, r+1), es):ms)
otherwise -> m:ms -- should not occur
| otherwise = m:ms -- not found? nevermind...
incM _ = []
incP :: [E.Process] -> [E.Process]
incP (p@(i,aT,bT,(t,s,r),es):ps)
| i > pID = p : incP ps
| i == pID = case spec of
SendMessage _ _ _ _ _ _ -> ((i, aT, bT, (t, s+1, r), es):ps)
ReceiveMessage _ _ _ _ _ _ _ -> ((i, aT, bT, (t, s, r+1), es):ps)
otherwise -> p:ps -- should not occur
| otherwise = p:ps -- not found? nevermind...
incP _ = []
newProc :: E.ProcessID -> E.ProcessID -> E.ProcessList -> E.ProcessTree -> (E.ProcessList, E.ProcessTree)
newProc dad son pls pt = (addProcPath son (dadPath) pls, addChildPrc son dadPath pt)
where dadPath = []--TODO getPath dad pls ++ [dad]
getPath :: E.ProcessID -> E.ProcessList -> [E.ProcessID]
getPath pId (p@(i,path):ps)
| i < pId = getPath pId ps
| i == pId = path
| otherwise = error ("not impl: getPath, otherwise " ++ (show son) ++ " " ++ show (pId,pls))
getPath _ _ = []
addProcPath :: E.ProcessID -> [E.ProcessID] -> E.ProcessList -> E.ProcessList
addProcPath pId path pls@(p@(i,lst):ps)
| i < pId = let ps' = addProcPath pId path ps in seq ps' (p:ps')
| i == pId = (pId,path) : ps
| otherwise = (pId,path) : pls
addProcPath pId path _ = [(pId, path)]
addChildPrc :: E.ProcessID -> [E.ProcessID] -> E.ProcessTree -> E.ProcessTree
addChildPrc pId [p] (Node i pts) = Node i ((Node pId []):pts)
addChildPrc pId path@(p:ps) pt@(Node i pts)
| p == i = let pts' = stepDown ps pts in seq pts' (Node i pts')
| otherwise = error ("addChildPrc: wrong ProcessTree found (" ++ show p ++ "!=" ++ show i ++ ")")
where stepDown :: [E.ProcessID] -> [E.ProcessTree] -> [E.ProcessTree]
stepDown path@(p:ps) pts@(t@(Node i _):ts)
| i == p = let t' = addChildPrc pId path t in seq t' (t':ts)
| otherwise = let ts' = stepDown path ts in seq ts' (t:ts')
stepDown path [] = seq (putStrLn ("stepDown: path " ++ show path ++ " not found in Process Tree:" ++ show pt)) []
addChildPrc pId [] pt = pt
delFromProcList :: E.ProcessID -> E.OpenMessageList -> E.OpenMessageList
delFromProcList pId oml = oml
insertMessage :: E.ProcessID -> E.OpenMessageEvent -> E.OpenMessageList -> E.OpenMessageList
insertMessage sp newMessage ocMsgs@(openMsgList,closedMessages,partMsgs@(openPrcMsgs,prcTbl,prcTree),(headMessages,hSize,closedHeads))
| tag == 88 = let ohl' = addHeadMsg (sp, out, rp, inp) headMessages
in seq ohl' (openMsgList, closedMessages, partMsgs,(ohl', hSize, closedHeads))
| tag == 87 = let (ohl,chl,hs') = searchHeadMsg (sp,out,rp,inp) headMessages
in seq cml (seq chl (oml,cml,partMsgs,(ohl,max hs' hSize,chl)))
| tag == 85 = ocMsgs
| otherwise = let ((_,sp'),(_,rp')) = (sp,rp)
in if (min sp' rp') >= 0
then seq oml (seq cml (oml,cml,partMsgs,(headMessages,hSize,closedHeads)))
else ocMsgs
where (time, rp@(rm,_),out,inp,tag,size) = case newMessage of
E.ORM t p o i r s -> (t,p,o,i,r,s)
E.OSM t p o i r -> (t,p,o,i,r,0)
(oml,cml) = searchID openMsgList
addHeadMsg :: E.ChannelID -> [E.OpenHeadMessage] -> [E.OpenHeadMessage]
addHeadMsg cId hml@(h@(idB,s,i,hsm,hrm):hs)
| cId > idB = let hs' = addHeadMsg cId hs in seq hs' (h:hs') -- not found yet: search on
| cId == idB = case newMessage of
E.ORM _ _ _ _ _ _ -> case hrm of -- entry found, increase quantity and size
[firstMsg] -> (idB,(s+size),(i+1),hsm,time:hrm):hs -- second received Message
(lastMsg:fm) -> (idB,(s+size),(i+1),hsm, time:fm):hs -- replace last received Message
[] -> (idB,(s+size),(i+1),hsm, [time] ):hs -- first received Message
E.OSM _ _ _ _ _ -> case hsm of -- entry found, don't touch values
[firstMsg] -> (idB,s,i,time:hsm,hrm):hs
(lastMsg:fm) -> (idB,s,i,time:fm ,hrm):hs
[] -> (idB,s,i, [time] ,hrm):hs
| otherwise = case newMessage of
E.ORM _ _ _ _ _ _ -> (cId,size,1,[],[time]):hml -- insert new entry before h
E.OSM _ _ _ _ _ -> (cId,size,0,[time],[]):hml
addHeadMsg cId [] = case newMessage of
E.ORM _ _ _ _ _ _ -> [(cId,size,1,[],[time])]
E.OSM _ _ _ _ _ -> [(cId,size,0,[time],[])]
searchHeadMsg :: E.ChannelID -> [E.OpenHeadMessage] -> ([E.OpenHeadMessage],[E.HeadMessage],Double)
searchHeadMsg cId hml@(h@(idB,s,i,hsm,hrm):hs)
| cId > idB = let (hs',ch',ms') = searchHeadMsg cId hs
in seq hs' (seq ch' (h:hs',ch',ms'))
| cId == idB = let sInt = s + size
sDouble = fromIntegral sInt
in case newMessage of
E.ORM _ _ _ _ _ _ ->
if length hsm == 3
then (hs, (cId,(ts1,tr1,ts2,time),sDouble,(i+1)):closedHeads, sDouble)
else ((idB,sInt,(i+1),hsm,time:hrm):hs,closedHeads,sDouble)
E.OSM _ _ _ _ _ ->
if length hrm == 3
then (hs, (cId,(ts1,tr1,time,tr2),sDouble,i):closedHeads,sDouble)
else ((idB,s,i,time:hsm,hrm):hs,closedHeads,sDouble)
| otherwise = (hml,closedHeads,0)
where ts2 = head hsm
ts1 = last hsm
tr2 = head hrm
tr1 = last hrm
searchHeadMsg cId [] = ([], closedHeads,0)
searchID :: [E.OpenMessage] -> ([E.OpenMessage], [E.Message])
searchID oml@(om@(iB,msgs):oms)
| sp > iB = seq cms' (seq oms' (om:oms',cms')) -- go on
| sp == iB = if null newOms -- OMList found => look for matching message
then (oms,newCms)
else ((iB, newOms):oms,newCms)
| otherwise = ((sp,[newMessage]):oml,closedMessages) -- no OMList for threadId found
where (oms',cms') = searchID oms -- recurse
(newOms,newCms) = insertOrReplace msgs -- try to find matching OpenMessage
insertOrReplace :: [E.OpenMessageEvent] -> ([E.OpenMessageEvent], [E.Message])
insertOrReplace (o:os) = case closeMessage o newMessage of
Nothing -> seq os' (o:os', cls')
Just c -> (os, c:closedMessages)
where (os',cls') = insertOrReplace os
insertOrReplace [] = ([newMessage],closedMessages)
closeMessage :: E.OpenMessageEvent -> E.OpenMessageEvent -> Maybe E.Message
closeMessage (E.OSM t1 p1 o1 i1 r1) (E.ORM t2 p2 o2 i2 r2 s2)
| and [p1==p2, o1==o2, i1==i2, r1==r2] = Just (E.MSG (sp,o1,p1,i1) t1 t2 r1 s2)
| otherwise = Nothing
closeMessage (E.ORM t2 p2 o2 i2 r2 s2) (E.OSM t1 p1 o1 i1 r1)
| and [p1==p2, o1==o2, i1==i2, r1==r2] = Just (E.MSG (sp,o1,p1,i1) t1 t2 r1 s2)
| otherwise = Nothing
closeMessage _ _ = Nothing
searchID [] = ([(sp, [newMessage])], closedMessages)
closeOpenLists :: E.OpenEvents -> E.Events
closeOpenLists (events@(mEvents,pEvents,tEvents),mTimes,(_,closedMessages,(_,_,Node _ pTrees),(openHeadMessages,hSize,headMessages)),(minTime,maxTime,numP,maxLD)) =
seq mEvents (seq minTime (seq allHeadMessages
((mEvents,pEvents,newThreadEvents),mTimes,undefined,(closedMessages,[],allHeadMessages,reversedProcTree, []),
(minTime,maxTime,0,hSize,(fromIntegral maxLD)),(length mEvents,numP,length newThreadEvents))))
where allHeadMessages = handleOpenHeadMsgs openHeadMessages headMessages
newThreadEvents = concat (map (\(_,_,ts) -> ts) tEvents)
reversedProcTree :: E.ProcessTree
reversedProcTree = if null pTrees
then Node (0,0) []
else reverseSubForests (head pTrees)
reverseSubForests :: E.ProcessTree -> E.ProcessTree
reverseSubForests (Node i f) = Node i (map reverseSubForests (reverse f))
handleOpenHeadMsgs :: [E.OpenHeadMessage] -> [E.HeadMessage] -> [E.HeadMessage]
handleOpenHeadMsgs [] hm = hm
handleOpenHeadMsgs ((ch,s,i,sml,rml):os) hm = case zip sml rml of
((lst',lrt'):(fst',frt'):_) -> handleOpenHeadMsgs os ((newHeadMsg fst' frt' lst' lrt'):hm)
_ -> handleOpenHeadMsgs os hm
where newHeadMsg :: E.Seconds -> E.Seconds -> E.Seconds -> E.Seconds -> E.HeadMessage
newHeadMsg tS1 tR1 tS2 tR2 = (ch,(tS1,tR1,tS2,tR2),fromIntegral s,i)
t2pID :: E.ThreadID -> E.ProcessID
t2pID tid = fst tid
instance Eq ThreadStopStatus where
NoStatus == NoStatus = True
NoStatus == _ = False
HeapOverflow == HeapOverflow = True
HeapOverflow == _ = False
StackOverflow == StackOverflow = True
StackOverflow == _ = False
ThreadYielding == ThreadYielding = True
ThreadYielding == _ = False
ThreadBlocked == ThreadBlocked = True
ThreadBlocked == _ = False
ThreadFinished == ThreadFinished = True
ThreadFinished == _ = False
ForeignCall == ForeignCall = True
ForeignCall == _ = False
\end{code}