edentv 4.4.0 → 4.9.1
raw patch · 5 files changed
+86/−85 lines, 5 filesdep ~ghc-events-parallelnew-uploader
Dependency ranges changed: ghc-events-parallel
Files
- EdenTvInteract.hs +39/−25
- EdenTvType.hs +30/−1
- EdenTvViewer.hs +6/−7
- RTSEventsParser.hs +9/−50
- edentv.cabal +2/−2
EdenTvInteract.hs view
@@ -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
EdenTvType.hs view
@@ -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 =
EdenTvViewer.hs view
@@ -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
RTSEventsParser.hs view
@@ -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
edentv.cabal view
@@ -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