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}