diff --git a/EdenTvInteract.hs b/EdenTvInteract.hs --- a/EdenTvInteract.hs +++ b/EdenTvInteract.hs @@ -238,7 +238,7 @@ showTraceInfo events filename statusString glade = do --events was: ((ms,ps,ts),mt,mxst,(msgs,_,heads,pt,_),(minT,maxT,_,_,_),_) let (_, _, _, pt,_) = messagelist events - + -- get access to the widgets: infoA <- builderGetObject glade castToLabel "infoA" infoM <- builderGetObject glade castToTreeView "infoM" @@ -261,7 +261,7 @@ treeViewAppendColumn infoM mTime rendererMTime <- cellRendererTextNew cellLayoutPackStart mTime rendererMTime True - + mPrcs <- treeViewColumnNew treeViewColumnSetTitle mPrcs "processes" treeViewAppendColumn infoM mPrcs @@ -339,7 +339,7 @@ cellLayoutPackStart pRcvd rendererPRcvd True dataP <- listStoreNew [] - + inspectProcess (reverse $ processlist events) dataP @@ -405,12 +405,13 @@ numProcesses=(show $ totalProcesses m), numSent=(show $ sentMessagesM m), numRcvd=(show $ receivedMessagesM m)}) - + inspectMachine ms store inspectMachine _ _ = return () + inspectProcess :: [Process] -> ListStore ProcessInfo -> IO () --inspectProcess (((m,i),_,_,stat,evts):ps) store = do - insectProcess (p:ps) store = do + inspectProcess (p:ps) store = do let evts = eventlistP p -- because of the processIDs being reused, there may be more then one -- StartProcess-/KillProcess-Events in evts. One fkt. to find them all: @@ -431,14 +432,14 @@ _ -> filterProcesses es st killTime n l filterProcesses _ _ _ _ _ = inspectProcess ps store inspectProcess _ _ = return () - + inspectThread (((pid,i),evts):ts) store = do - + listStorePrepend store (ThreadInfo{ machIdT=(show $ pId2mId pid), procIdT=if isSystemProcess pid then "System" else (show $ pId pid), thrdId=("Thread " ++ show i), runtimeT=(formatFloat (getEventTime (head evts) - (getEventTime (last evts))))}) - + inspectThread ts store inspectThread _ _ = return () @@ -452,7 +453,7 @@ handleDragnDrop :: MVar ViewerState -> DrawingArea -> Events -> Double -> Double -> IO () handleDragnDrop st pic _ mx my = do state <- readMVar st - + ((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic --widgetQueueDrawArea pic (floor mx - 100) vy 200 vh if mx > ulx && my > uly && mx < lrx && my < lry -- if my > uly && my < lry @@ -472,7 +473,7 @@ moveTo ((fromIntegral vx)+20) (my) lineTo ((fromIntegral vx)+30) (my) stroke - + else return () performDragnDrop v st pic _ mx my = do @@ -514,7 +515,6 @@ ns = selRow state (m,a) = handleMove (floor index) ns arr putMVar st (state {selRow = m, matrixT = a, deleteSel = False}) - 1 -> do let arr = matrixP state ns = selRow state @@ -536,20 +536,20 @@ then do state <- readMVar st let useDiff = locTime state - + globalState <- readMVar edentvState let colorsMap = colors globalState - + -- if the startup-phase is not shown, adapt minT let minT' | hideStartupPhase = maxStartup events --in seconds | otherwise = min_t events - + let time | useDiff = posToTime minT' (max_t events + max_t_diff events) ulx lrx mx | otherwise = posToTime minT' (max_t events) ulx lrx mx text = formatFloat time - + win <- widgetGetDrawWindow pic drawWindowProcessUpdates win False renderWithDrawable win $ do @@ -598,7 +598,7 @@ line = if v /= 3 then fromIntegral (floor (1 + ((my - uly) / ySkip))) else let y = my - uly - in findRow 0 y machineOffsets + in findRow 0 y gpMachineOffsets where findRow i y ((numP,numSkip):xs) | y < (numP*procSkip + numSkip*10) = i | otherwise = findRow (i+1) y xs @@ -608,7 +608,7 @@ numProcs = map (\m -> (getIdM m, totalProcesses m)) m numM = fromIntegral $ length m - procSkip = (lry - uly - ((numM-1)*10) )/ (fromIntegral (length (matrixP oldState))) + procSkip = (lry - uly - ((numM-1)*10) )/ (fromIntegral (length (matrixP oldState))) sortedMachines = [(numM+1) - (posToMachine pos (matrixGP oldState)) | pos <- [1..numM]] where posToMachine :: Double -> [Double] -> Double posToMachine pos sort = posAcc 1 pos sort @@ -617,7 +617,7 @@ | otherwise = posAcc (i+1) pos ss posAcc _ _ [] = 0 - machineOffsets = buildOffsets (0,0) sortedMachines + gpMachineOffsets = buildOffsets (0,0) sortedMachines where buildOffsets :: (Double, Double) -> [Double] -> [(Double,Double)] buildOffsets (numP, numSkip) (mId:mIds) = (numP, numSkip) : (buildOffsets ((fromIntegral curP)+numP, numSkip+1) mIds) where Just curP = lookup (floor mId) numProcs @@ -636,6 +636,13 @@ --putStrLn $ "sortedMachines: " ++ (show sortedMachines) --putStrLn $ "machineOffsets: " ++ (show machineOffsets) --putStrLn $ "line: " ++ (show line) + --putStrLn $ show $ map getIdP $ (filter (\proc -> getMIdFromP proc == getIdM (m!!line')) p) + --putStrLn $ "procSkip = " ++ show procSkip + --putStrLn $ "y = " ++ show (my - uly) + --putStrLn $ "line = " ++ show line + --putStrLn $ "gpMachineOffsets = " ++ show gpMachineOffsets + --putStrLn $ "multiplied gpMachineOffsets: " ++ show ((\(numP, numSkip) -> numP*procSkip + numSkip*10) (gpMachineOffsets !! (floor line - 1))) + --putStrLn $ "index: " ++ show (floor $ ((my - uly) - ((\(numP, numSkip) -> numP*procSkip + numSkip*10) (gpMachineOffsets !! (floor line - 1)))) / procSkip) case eventButton e of LeftButton -> if mx > ulx && my > uly && mx < lrx && my < lry @@ -670,10 +677,17 @@ MiddleButton -> return True RightButton -> if mx > ulx && my > uly && my < lry then do - let tData = (\ (_,evts) -> evts) (t!!line') - pData = eventlistP (p!!line') + let gpProcess = (filter (\proc -> getMIdFromP proc == selMachine) p) + !! + (floor $ ((my - uly) - ((\(numP, numSkip) -> numP*procSkip + numSkip*10) (gpMachineOffsets !! (floor line - 1)))) / procSkip) + + tData = (\ (_,evts) -> evts) (t!!line') + pData = if v /= 3 then eventlistP (p!!line') + else eventlistP gpProcess + mData = eventlistM (m!!line') (selMachine,selName) = case v of + 3 -> (getIdM (m!!line'), 'P': show (getIdP gpProcess)) 2 -> case t!!line' of ((pid,t),_) -> (pId2mId pid,'T': show pid ++ ':': show t) 1 -> let p' = getIdP (p!!line') in (pId2mId p','P': show p') 0 -> let m' = getIdM (m!!line') in (m','M': show m') @@ -685,7 +699,7 @@ selTime = if locTime oldState then (posToTime minT (maxT+maxST) ulx lrx mx) - diffTime else (posToTime minT maxT ulx lrx mx) + minT - labelText = case v of + labelText = case (if v == 3 then 1 else v) of 2 -> case take 1 (dropWhile (\e -> getEventTime e > selTime) tData) of [NewThread s o] -> "New thread " ++ selName ++ "\nTime: " ++ (scaledTime s) ++ @@ -783,26 +797,26 @@ then (len - 1) `mod` len else (len - placesBefore - lenMoved) `mod` len - + filterOther i (x:xs) | i `elem` orderedMoveRows = filterOther (i+1) xs | otherwise = i : (filterOther (i+1) xs) filterOther _ [] = [] - + process :: Int -> [Double] -> [Double] process i (x:xs) | (fromIntegral i) `elem` orderedMoveRows = (fromIntegral movPos ) : (process (i+1) xs) | otherwise = (fromIntegral movPos') : (process (i+1) xs) where movedRowOffset = position i orderedMoveRows movPos = pos (index + movedRowOffset) - + alteredRowOffset = position i orderedOtherRows movPos' = if alteredRowOffset < placesBefore then pos (1+alteredRowOffset) else pos ( index + lenMoved + alteredRowOffset - placesBefore) process _ [] = [] - + pos :: Int -> Int pos x = ((x-1) `mod` len) + 1 diff --git a/EdenTvType.hs b/EdenTvType.hs --- a/EdenTvType.hs +++ b/EdenTvType.hs @@ -25,6 +25,7 @@ import qualified Data.Map as M import qualified Data.Sequence as S --import DeepSeq +import GHC.RTS.Events (ThreadStopStatus(..)) import Graphics.UI.Gtk.Gdk.Pixbuf import Graphics.UI.Gtk.Gdk.GC @@ -280,7 +281,7 @@ | GCThread {-# UNPACK #-} !Seconds {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int | RunThread {-# UNPACK #-} !Seconds -- Event 185 | SuspendThread {-# UNPACK #-} !Seconds -- Event 193 - | BlockThread {-# UNPACK #-} !Seconds {-# UNPACK #-} !InportID !Reason -- Event 201 + | BlockThread {-# UNPACK #-} !Seconds {-# UNPACK #-} !InportID !BlockReason -- Event 201 | DeblockThread {-# UNPACK #-} !Seconds -- Event 209 | DummyThread deriving (Show,Eq) @@ -309,6 +310,34 @@ deepSeq (BlockThread sec inPort tag) y = deepSeq sec $ deepSeq inPort $ deepSeq tag y deepSeq (DeblockThread sec) y = deepSeq sec y -} + +type BlockReason = GHC.RTS.Events.ThreadStopStatus + +instance Eq ThreadStopStatus where + NoStatus == NoStatus = True + HeapOverflow == HeapOverflow = True + StackOverflow == StackOverflow = True + ThreadYielding == ThreadYielding = True + ThreadBlocked == ThreadBlocked = True + ThreadFinished == ThreadFinished = True + ForeignCall == ForeignCall = True + BlockedOnMVar == BlockedOnMVar = True + BlockedOnMVarRead == BlockedOnMVarRead = True + -- since GHC-7.8.2/ghc-events-0.4.3.1 + BlockedOnBlackHole == BlockedOnBlackHole = True + BlockedOnRead == BlockedOnRead = True + BlockedOnWrite == BlockedOnWrite = True + BlockedOnDelay == BlockedOnDelay = True + BlockedOnSTM == BlockedOnSTM = True + BlockedOnDoProc == BlockedOnDoProc = True + BlockedOnCCall == BlockedOnCCall = True + BlockedOnCCall_NoUnblockExc == BlockedOnCCall_NoUnblockExc = True + BlockedOnMsgThrowTo == BlockedOnMsgThrowTo = True + ThreadMigrating == ThreadMigrating = True + BlockedOnMsgGlobalise == BlockedOnMsgGlobalise = True + (BlockedOnBlackHoleOwnedBy _) == (BlockedOnBlackHoleOwnedBy _) = True + _ == _ = False + -- Messages: data ReasonType = diff --git a/EdenTvViewer.hs b/EdenTvViewer.hs --- a/EdenTvViewer.hs +++ b/EdenTvViewer.hs @@ -715,7 +715,6 @@ ySkip = ((lry - uly - ((numM-1)*machGap) ) / numP) xSkip = (lrx - ulx) sort = matrixGP state - names = map (\p' -> let pid = getIdP p' in ('P':(show pid))) processes sortGroup = map (pos 1 sort) [1..numM] where pos :: Double -> [Double] -> Double -> Double pos i (y:ys) x @@ -748,14 +747,14 @@ drawNameLine (fromIntegral vx + ulx - 5) (lry-uly) color stroke - drawPNames [p] (s:ss) skip = do + drawPNames [p] (s:ss) skip colors = do let pid = getIdP p - drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show pid)) - drawNameTick (fromIntegral vx + ulx -5) (lry-uly) ((s*ySkip)+skip+5) - drawPNames (p:ps) (s:ss) skip = do + drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show pid)) colors + drawNameTick (fromIntegral vx + ulx -5) (lry-uly) ((s*ySkip)+skip+5) colors + drawPNames (p:ps) (s:ss) skip colors = do let pid = getIdP p - drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show pid)) - drawPNames ps ss skip + drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show pid)) colors + drawPNames ps ss skip colors target $ do diff --git a/RTSEventsParser.hs b/RTSEventsParser.hs --- a/RTSEventsParser.hs +++ b/RTSEventsParser.hs @@ -774,7 +774,7 @@ thread, status} -> res where res | status == ThreadFinished = (True, newEvents (E.KillThread (convertTimestamp time))) - | status `elem` blockList = (True, newEvents (E.BlockThread (convertTimestamp time) (0) (E.BlockReason))) -- ####hack inport? reason? + | status `elem` blockList = (True, newEvents (E.BlockThread (convertTimestamp time) (0) status)) -- ####hack inport? reason? | otherwise = (True, newEvents (E.SuspendThread (convertTimestamp time))) blockList = [ThreadBlocked,BlockedOnMVar,BlockedOnBlackHole,BlockedOnDelay,BlockedOnSTM, BlockedOnDoProc,BlockedOnMsgThrowTo,ThreadMigrating,BlockedOnMsgGlobalise,BlockedOnBlackHoleOwnedBy 0] @@ -858,15 +858,17 @@ E.eventlistM = newEvts} E.MKillRProcess sec -> let newRunP = E.runningProcesses m - 1 newAllP = E.aliveProcesses m - 1 - newEvts = if newAllP > 0 - then (E.SuspendedMachine sec):evts - else (E.IdleMachine sec):evts + newEvts | newRunP > 0 = evts -- machine keeps on running + | newAllP == 0 = (E.IdleMachine sec):evts + | E.blockedProcesses m == newAllP = (E.BlockedMachine sec):evts + | otherwise = (E.SuspendedMachine sec):evts in m {E.aliveProcesses = newAllP, + E.runningProcesses = newRunP, E.eventlistM = newEvts} E.MKillSProcess sec -> let newAllP = E.aliveProcesses m - 1 - newEvts = if newAllP > 0 - then evts - else (E.IdleMachine sec):evts + newEvts | newAllP == 0 = (E.IdleMachine sec):evts + | newAllP == E.blockedProcesses m = (E.BlockedMachine sec):evts + | otherwise = evts in m {E.aliveProcesses = newAllP, E.eventlistM = newEvts} E.MKillBProcess sec -> let newAllP = E.aliveProcesses m - 1 @@ -1254,46 +1256,3 @@ 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 - BlockedOnMVar == BlockedOnMVar = True - BlockedOnMVar == _ = False - BlockedOnBlackHole == BlockedOnBlackHole = True - BlockedOnBlackHole == _ = False - BlockedOnRead == BlockedOnRead = True - BlockedOnRead == _ = False - BlockedOnWrite == BlockedOnWrite = True - BlockedOnWrite == _ = False - BlockedOnDelay == BlockedOnDelay = True - BlockedOnDelay == _ = False - BlockedOnSTM == BlockedOnSTM = True - BlockedOnSTM == _ = False - BlockedOnDoProc == BlockedOnDoProc = True - BlockedOnDoProc == _ = False - BlockedOnCCall == BlockedOnCCall = True - BlockedOnCCall == _ = False - BlockedOnCCall_NoUnblockExc == BlockedOnCCall_NoUnblockExc = True - BlockedOnCCall_NoUnblockExc == _ = False - BlockedOnMsgThrowTo == BlockedOnMsgThrowTo = True - BlockedOnMsgThrowTo == _ = False - ThreadMigrating == ThreadMigrating = True - ThreadMigrating == _ = False - BlockedOnMsgGlobalise == BlockedOnMsgGlobalise = True - BlockedOnMsgGlobalise == _ = False - (BlockedOnBlackHoleOwnedBy _) == (BlockedOnBlackHoleOwnedBy _) = True - (BlockedOnBlackHoleOwnedBy _) == _ = False diff --git a/edentv.cabal b/edentv.cabal --- a/edentv.cabal +++ b/edentv.cabal @@ -1,5 +1,5 @@ name: edentv -version: 4.4.0 +version: 4.9.1 synopsis: A Tool to Visualize Parallel Functional Program Executions description: The Eden Trace Viewer is a tool designed to help programmers optimize Eden programs by visualising traces @@ -40,7 +40,7 @@ gtk >= 0.12, cairo >= 0.12, array, - ghc-events-parallel >= 0.5 + ghc-events-parallel >= 0.5.0.1 GHC-Options: -rtsopts