diff --git a/EdenTV.hs b/EdenTV.hs new file mode 100644 --- /dev/null +++ b/EdenTV.hs @@ -0,0 +1,1196 @@ +{- The Eden Trace Viewer (or simply EdenTV) is a tool that can generate diagrams to visualize the behaviour of Eden programs. + Copyright (C) 2005-2010 Phillips Universitaet Marburg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +-} + +module Main (main) where + +import Graphics.UI.Gtk hiding (deleteEvent, destroyEvent, eventButton) +import Graphics.UI.Gtk.Gdk.Events +import Graphics.UI.Gtk.Windows.MessageDialog + +import Graphics.UI.Gtk.Glade +import Graphics.UI.Gtk.General.StockItems + +import Graphics.Rendering.Cairo hiding (version) + +import Control.Concurrent +import Control.Monad.Fix +import Control.Monad + +import EdenTvType +import EdenTvBasic +import EdenTvInteract +import EdenTvViewer +import System.Environment +import System.Exit +import System.Directory +import System.FilePath.Posix +import System.Directory +import System.CPUTime +import System.IO +import Data.List +import RTSEventsParser + +import Debug.Trace + +import Paths_edentv( -- version, + getDataFileName + ) -- this file is generated by cabal +import qualified Paths_edentv +import Data.Version(versionBranch) -- to extract version from there + + +-- unsafe CAF to detect the file name once and return it as a +-- constant immediately for every call later: +-- cafGladeFile = unsafePerformIO $ do +-- let filename = "edentv.glade" -- change only here if desired +-- gladefile <- getDataFileName filename +-- inDataDir <- doesFileExist gladefile +-- if inDataDir +-- then return gladefile +-- else return filename -- default: local + + +-- Datadir, usually "share/edentv-" holds the glade file. +-- Load the glade file from install path or local, specify root and domain +-- (XML is allegedly cached internally, but check is always repeated) +edentvGladeFile :: Maybe String -> Maybe String -> IO (Maybe GladeXML) +edentvGladeFile root domain + = let filename = "edentv.glade" -- change only here if desired + in do gladefile <- getDataFileName filename + inDataDir <- doesFileExist gladefile + inLocalDir <- doesFileExist filename + case (inDataDir, inLocalDir) of + (True, _) -> + xmlNewWithRootAndDomain gladefile root domain + (False, True) -> + xmlNewWithRootAndDomain filename root domain + (False, False) -> + return Nothing + +version,subversion :: String +-- version = "4.0" +version = show (head ( versionBranch Paths_edentv.version )) +subversion = "0" +regpath = "/apps/unimar/edentv/lastPath" + + +-- some general GTK-Events: +deleteEvent :: Event -> IO Bool +deleteEvent _ = do return False +destroyEvent, quitEvent, closeEvent :: IO () +destroyEvent = do mainQuit +quitEvent = do mainQuit +closeEvent = do return () + +data WindowsState = WS { + windowsMenus :: [Menu] + } + +type WidgetCollection = (Menu, MenuItem, MenuItem, MenuItem, MVar WindowsState) +-- Wins, menuOpen, menuOpenWithoutMsgs, menuExit, state +-- openEvent: open a new Tracefile +openEvent :: Window -> WidgetCollection -> MVar EdenTvState -> Bool -> IO () +openEvent parent ws edentvState ignoreMessages = do + --Select Tracefile to load + fileSelect <- fileChooserDialogNew (Just "Select Tracefile") (Just parent) + FileChooserActionOpen [("OK",ResponseOk),("Cancel",ResponseCancel)] + globalState <- readMVar edentvState + let oldPath = lastPath globalState + if null oldPath + then return True + else fileChooserSetCurrentFolder fileSelect oldPath + widgetShow fileSelect + response <- dialogRun fileSelect + case response of -- which Button was pressed? + ResponseOk -> do + Just fileName <- fileChooserGetFilename fileSelect + path <- fileChooserGetCurrentFolder fileSelect + case path of Just filePath -> swapMVar edentvState (globalState { lastPath = filePath }) + Nothing -> return globalState + widgetDestroy fileSelect + -- display dialog with progress indicator + tryToOpen fileName ws ignoreMessages False edentvState + _ -> do + putMVar edentvState (globalState { lastPath = oldPath }) + widgetDestroy fileSelect -- any other response + +tryToOpen :: String -> WidgetCollection -> Bool -> Bool -> MVar EdenTvState -> IO () +tryToOpen filename ws ignoreMessages showMessages edentvState = do + dlg <- dialogNew + windowSetTitle dlg "parsing file..." + button <- dialogAddButton dlg stockCancel ResponseCancel + upper <- dialogGetUpper dlg + pg <- progressBarNew + boxPackStartDefaults upper pg + widgetShowAll dlg + -- animate the progressbar + threadProgress <- forkIO (showProgress pg) + hID <- idleAdd (yield >> return True) priorityDefaultIdle + -- start concurrent process to read tracefile + threadTrace <- forkIO (openTracefile filename ws dlg ignoreMessages showMessages edentvState) + -- Cancel-event! + onClicked button (opCancel threadTrace dlg) + dialogRun dlg -- wating for end of parsing or user interrupt + killThread threadProgress + idleRemove hID + widgetDestroy dlg + where + showProgress :: ProgressBar -> IO () + showProgress pb = do + progressBarPulse pb + threadDelay 200000 + showProgress pb + opCancel :: ThreadId -> Dialog -> IO () + opCancel thread dialog = do + killThread thread + dialogResponse dialog ResponseOk + +hLines :: Show a => Handle -> [a] -> IO () +hLines h (x:xs) = do + hPutStrLn h (show x) + hLines h xs +hLines _ _ = return () + + + + + + +-- open a new Trace-Window and display the Trace +openTracefile :: String -> WidgetCollection -> Dialog -> Bool -> Bool -> MVar EdenTvState -> IO () +openTracefile filename widgets@(winList,mainOpen, mainOpenWithoutMsgs, exitApp, winMenus) + dialog ignoreMessages showMessages edentvState + = do + putStrLn (filename ++ ":") + time <- getCPUTime + traces' <- (traceRTSFile filename ignoreMessages) + case traces' of + Failed msg -> do + dialogResponse dialog ResponseOk + errorMessage ("Tracefile seems not to be valid:\n" ++ msg) + Ok traces -> do + -- build window and render traces: + let ((m,p,t),mt,(maxStartupTimeInSeconds, _), (msgs,amsgs,hmsgs,pTree,rcvtimes),(minT,maxT,maxST,_,maxD),(nm,allP,nt)) = traces + np = length p + strRunT = formatFloat (maxT - minT) + allMsgs = sum (map (\ (_,_,_,d) -> d) hmsgs) + length msgs + time' <- getCPUTime + let timeString = ("\n Traces computed in " ++ + show (fromIntegral (time' - time) / 1000000000000) ++ " seconds.") + putStrLn timeString + + -- load XML-description from gladefile + maybeGladeXML <- edentvGladeFile (Just "EdTVTrace") Nothing + let gladeXML = case maybeGladeXML of + (Just glade) -> glade + Nothing -> error "missing file: \"edentv.glade\"!" + -- get access to the widgets from gladefile + window <- xmlGetWidget gladeXML castToWindow "EdTVTrace" + pic <- xmlGetWidget gladeXML castToDrawingArea "drawingarea" + win <- widgetGetDrawWindow pic + viewport <- xmlGetWidget gladeXML castToViewport "viewport" + scrldWnd <- xmlGetWidget gladeXML castToScrolledWindow "scrolledwindow" + + buttonLocalNull <- xmlGetWidget gladeXML castToToggleToolButton "localNull" + buttonMessages <- xmlGetWidget gladeXML castToToggleToolButton "messages" + buttonInfo <- xmlGetWidget gladeXML castToToolButton "infoButton" + buttonConfMsgs <- xmlGetWidget gladeXML castToToolButton "msgs-relations" + traceZoomInH <- xmlGetWidget gladeXML castToToolButton "zoomInH" + traceZoomInV <- xmlGetWidget gladeXML castToToolButton "zoomInV" + traceZoomIn <- xmlGetWidget gladeXML castToMenuItem "zoom_in" + traceZoomOutH <- xmlGetWidget gladeXML castToToolButton "zoomOutH" + traceZoomOutV <- xmlGetWidget gladeXML castToToolButton "zoomOutV" + traceZoomOut <- xmlGetWidget gladeXML castToMenuItem "zoom_out" + moveUp <- xmlGetWidget gladeXML castToToolButton "go_up" + moveDown <- xmlGetWidget gladeXML castToToolButton "go_down" + viewselect <- xmlGetWidget gladeXML castToComboBox "viewselect" + buttonToPng <- xmlGetWidget gladeXML castToToolButton "saveAsPng" + + winm <- xmlGetWidget gladeXML castToMenu "windows_menu" + menuClose <- xmlGetWidget gladeXML castToMenuItem "close" + menuQuit <- xmlGetWidget gladeXML castToMenuItem "tquit" + menuOpen <- xmlGetWidget gladeXML castToMenuItem "topen" + + menuOpenWithoutMsgs <- xmlGetWidget gladeXML castToMenuItem "topenWithoutMsgs" + menuSave <- xmlGetWidget gladeXML castToMenuItem "save" + menuAllM <- xmlGetWidget gladeXML castToRadioMenuItem "showAllMachines" + menuAllP <- xmlGetWidget gladeXML castToRadioMenuItem "showAllProcesses" + menuAllGP <- xmlGetWidget gladeXML castToRadioMenuItem "showAllGProcesses" + menuAllT <- xmlGetWidget gladeXML castToRadioMenuItem "showAllThreads" + menuSort <- xmlGetWidget gladeXML castToMenuItem "sort" + menuShowRange <- xmlGetWidget gladeXML castToMenuItem "edit_range" + menuEditTicks <- xmlGetWidget gladeXML castToMenuItem "edit_ticks" + menuTotal <- xmlGetWidget gladeXML castToMenuItem "totalView" + menuMarker <- xmlGetWidget gladeXML castToCheckMenuItem "show_marker" + menuStartupMarker <- xmlGetWidget gladeXML castToCheckMenuItem "show_startup" + menuHideStartupPhase <- xmlGetWidget gladeXML castToCheckMenuItem "hide_startup_phase" + menuBlockMsgs <- xmlGetWidget gladeXML castToCheckMenuItem "show_blockmsgs" + menuDataMsgs <- xmlGetWidget gladeXML castToCheckMenuItem "show_data_messages" + menuSystemMsgs <- xmlGetWidget gladeXML castToCheckMenuItem "show_system_messages" + menuRefresh <- xmlGetWidget gladeXML castToMenuItem "refresh" + menuAbout <- xmlGetWidget gladeXML castToMenuItem "tabout" + + -- add labels for tool-items so that a label is displayed in the toolbar overflow menu + addMenuLabelToToolItem gladeXML "toolitemViewSelect" "Select View" + addMenuLabelToToolItem gladeXML "toolitemSort" "Sort" + addMenuLabelToToolItem gladeXML "toolitemZoomH" "Zoom Horizontal" + addMenuLabelToToolItem gladeXML "toolitemZoomV" "Zoom Vertical" + + -- the statusbar: + statusbar <- xmlGetWidget gladeXML castToStatusbar "traceStatusBar" + let statusString = " Runtime: " ++ strRunT ++ "s, " ++ + show nm ++ " Machines, " ++ + show allP ++ " Processes, " ++ + show nt ++ " Threads, " ++ + show (length msgs + (length hmsgs)) ++ " Conversations, " ++ + show allMsgs ++ " Messages" + botID <- statusbarGetContextId statusbar statusString + + statusbarPush statusbar botID statusString + -- initial settings + comboBoxSetActive viewselect 0 -- default to view machines + let listOfMachineIds = map (\(mId,_,_,_,_) -> mId) m + listOfProcessIds = map (\(pId,_,_,_,_) -> pId) p + st <- newMVar (initMatrix nm (length p) nt listOfMachineIds listOfProcessIds filename ignoreMessages) + -- filename in titlebar + let winTitle = "Trace " ++ (takeFileName filename) + windowSetTitle window winTitle + -- create entry for windows-menu in main window (and now all other open windows too) + ws <- takeMVar winMenus + -- update all menus which are found in ws to display new tracefile item + sequence_ $ map (\winList -> do + newListItem <- menuItemNewWithLabel winTitle + submenu <- menuNew + showItem <- menuItemNewWithLabel "Show" + refreshItem <- menuItemNewWithLabel "Refresh" + menuShellAppend winList newListItem + menuShellAppend submenu showItem + menuShellAppend submenu refreshItem + menuItemSetSubmenu newListItem submenu + widgetShow newListItem + onActivateLeaf showItem (windowPresent window) + onActivateLeaf refreshItem (widgetQueueDraw pic) + widgetShowAll newListItem + onDestroy window (widgetDestroy newListItem) + onDestroy window (do + oldWS <- takeMVar winMenus + let oldM = windowsMenus oldWS + --putStrLn "removing old menu from update list" + --putStrLn (show $ length oldM) + let removeSelf (x:xs) + | x == winm = xs + | otherwise = x : (removeSelf xs) + removeSelf [] = [] + newM = removeSelf oldM + --putStrLn (show $ length newM) + putMVar winMenus (oldWS{windowsMenus=newM}) + )) (windowsMenus ws) + -- get list of windows and build a windows menu from ground up + -- for this window + activeWins <- windowListToplevels + sequence_ $ map (\window -> do + title <- (windowGetTitle window) + if isPrefixOf "Trace" title -- only show if window is a tracefile window + then do + newListItem <- menuItemNewWithLabel title + submenu <- menuNew + showItem <- menuItemNewWithLabel "Show" + refreshItem <- menuItemNewWithLabel "Refresh" + menuShellAppend winm newListItem + menuShellAppend submenu showItem + menuShellAppend submenu refreshItem + menuItemSetSubmenu newListItem submenu + widgetShow newListItem + onActivateLeaf showItem (windowPresent window) + onActivateLeaf refreshItem (widgetQueueDraw pic) + widgetShowAll newListItem + onDestroy window (widgetDestroy newListItem) + return () + else return ()) activeWins + -- register this windows menu for future updates + putMVar winMenus (ws{windowsMenus=(winm:(windowsMenus ws))}) + + -- option buttons: + -- zoom in/out, horizontal/vertical + -- when zooming out also refresh the drawing area to get rid of the old drawings + onToolButtonClicked traceZoomInH (zoom pic (*2) (id) viewport) + onToolButtonClicked traceZoomInV (zoom pic (id) (*2) viewport) + onToolButtonClicked traceZoomOutH (do zoom pic (`div` 2) (id) viewport; widgetQueueDraw pic) + onToolButtonClicked traceZoomOutV (do zoom pic (id) (`div` 2) viewport; widgetQueueDraw pic) + onActivateLeaf traceZoomIn (zoom pic (*2) (*2) viewport) + onActivateLeaf traceZoomOut (do zoom pic (`div` 2) (`div` 2) viewport; widgetQueueDraw pic) + + -- mouse zoom event + onScroll pic (\ event -> do + let scrollDirection = eventDirection event + + when (scrollDirection == ScrollUp || scrollDirection == ScrollDown) $ do + -- mouse position on the drawing area + let mousePosX = eventX event + let mousePosY = eventY event + + let zoomFactor + | scrollDirection == ScrollUp = (*2) + | otherwise = (`div` 2) + + zoomAt mousePosX mousePosY pic zoomFactor viewport + widgetQueueDraw pic + + return (True)) + + -- toggle local/global zero => refresh picture + onToolButtonToggled buttonLocalNull (widgetQueueDraw pic) + -- close the "parsing file"-dialog + dialogResponse dialog ResponseOk + + -- events from the menu + -- close window, not program + onActivateLeaf menuClose (widgetDestroy window) + -- close window AND program + onActivateLeaf menuQuit (do + widgetActivate exitApp + return ()) + -- open new tracefile, use controls of main window + onActivateLeaf menuOpen (do + widgetActivate mainOpen + return ()) + -- open new tracefile without msgs, use controls of main window + onActivateLeaf menuOpenWithoutMsgs (do + widgetActivate mainOpenWithoutMsgs + return ()) + + -- redraw + onActivateLeaf menuBlockMsgs (widgetQueueDraw pic) + onActivateLeaf menuDataMsgs (widgetQueueDraw pic) + onActivateLeaf menuSystemMsgs (widgetQueueDraw pic) + onActivateLeaf menuHideStartupPhase (widgetQueueDraw pic) + + -- save image to file (menu entry) + onActivateLeaf menuSave (do + windowPresent window + + v <- comboBoxGetActive viewselect + drawStartupMarker <- checkMenuItemGetActive menuStartupMarker + hideStartupPhase <- checkMenuItemGetActive menuHideStartupPhase + drawBlockMsgs <- checkMenuItemGetActive menuBlockMsgs + drawDataMsgs <- checkMenuItemGetActive menuDataMsgs + drawSystemMsgs <- checkMenuItemGetActive menuSystemMsgs + + saveToFile drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs traces (nt,np,nm) v st edentvState pic) + -- sort current view + onActivateLeaf menuSort ( do + state <- takeMVar st + -- which view has to be sorted? + v <- comboBoxGetActive viewselect + case v of -- set the right list to default: + 3 -> putMVar st (state { matrixGP = [1..(fromIntegral nm)] }) + 2 -> putMVar st (state { matrixT = [1..(fromIntegral nt)] }) + 1 -> putMVar st (state { matrixP = [1..(fromIntegral np)] }) + 0 -> putMVar st (state { matrixM = [1..(fromIntegral nm)] }) + widgetQueueDraw pic) -- refresh picture + onActivateLeaf menuShowRange ( + do -- show specific range + (Just gladeXML) <- edentvGladeFile (Just "range_win") Nothing + rangeDlg <- xmlGetWidget gladeXML castToWindow "range_win" + spinBegin <- xmlGetWidget gladeXML castToSpinButton "range_begin" + spinEnd <- xmlGetWidget gladeXML castToSpinButton "range_end" + buttonShow <- xmlGetWidget gladeXML castToButton "show_intervall" + + viewRange <- viewportGetHAdjustment viewport + + viewLower <- adjustmentGetLower viewRange + viewUpper <- adjustmentGetUpper viewRange + viewInit <- adjustmentGetValue viewRange + viewStep <- adjustmentGetStepIncrement viewRange + + --putStrLn ("posX init: " ++ (show viewInit)) + + state <- readMVar st + let useDiff = locTime state + ((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic + + + hideStartupPhase <- checkMenuItemGetActive menuHideStartupPhase + let minT' + | hideStartupPhase = maxStartupTimeInSeconds + | otherwise = minT + let getTimeFromPosition x + | useDiff = posToTime minT' (maxT+maxST) ulx lrx x + | otherwise = posToTime minT' maxT ulx lrx x + + let timeBeginInit = getTimeFromPosition (viewInit+ulx) + timeBeginLower + | hideStartupPhase = 0 + | otherwise = minT' + timeBeginUpper + | hideStartupPhase = maxT - minT' + | otherwise = maxT + timeEndInit = getTimeFromPosition (viewInit+(fromIntegral vw)) + timeEndLower = timeBeginLower + timeEndUpper = timeBeginUpper + timeStep = getTimeFromPosition viewStep + + beginAdjustment <- adjustmentNew timeBeginInit timeBeginLower timeBeginUpper timeStep 0 0 + endAdjustment <- adjustmentNew timeEndInit timeEndLower timeEndUpper timeStep 0 0 + + spinButtonConfigure spinBegin beginAdjustment timeStep 5 + spinButtonConfigure spinEnd endAdjustment timeStep 5 + + onClicked buttonShow (do + --putStrLn "Ok?" + timeX <- spinButtonGetValue spinBegin + timeX2 <- spinButtonGetValue spinEnd + --let scale_total = (maxT-minT) + let scale = (((fromIntegral vw) - ulx) / (timeX2 - timeX)) * (maxT - minT') + (w,h) <- widgetGetSize pic + widgetSetSizeRequest pic (minimum [round scale, 32000]) (h) + + let newlrx = (realToFrac (round scale)) - 20 + let getPositionFromTime x + | useDiff = timeToPos minT' (maxT+maxST) ulx newlrx x + | otherwise = timeToPos minT' maxT ulx newlrx x + + let posX = (getPositionFromTime timeX) - ulx + -- At the moment the drawing area might no have changed + -- its size yet. So if we try to set the adjustment value now, + -- the adjustment might not be changed because the new value is not + -- between lowerValue and upperValue. + -- So instead we set an event, which is called when the drawing area + -- has changed its size, so that we can safely scroll to the right + -- position. + viewAdj <- viewportGetHAdjustment viewport + mfix $ \ handlerId -> afterAdjChanged viewAdj (do + adjustmentSetValue viewAdj posX + -- remove the event again + signalDisconnect handlerId) + + return () + ) + + windowSetTitle rangeDlg "Show Range" + windowSetTransientFor rangeDlg window + widgetShowAll rangeDlg + + ) + + onActivateLeaf menuEditTicks ( + do -- show ticks setup + (Just gladeXML) <- edentvGladeFile (Just "ticks_win") Nothing + ticksDlg <- xmlGetWidget gladeXML castToWindow "ticks_win" + ticksSkip <- xmlGetWidget gladeXML castToSpinButton "ticks_skip" + ticksMark <- xmlGetWidget gladeXML castToSpinButton "ticks_mark" + buttonSet <- xmlGetWidget gladeXML castToButton "set_ticks" + buttonAuto <- xmlGetWidget gladeXML castToCheckButton "auto_ticks" + + state <- readMVar st + let useDiff = locTime state + auto = autoTicks state + tSkip = tickSkip state + tMark = tickMark state + maxSkip + | useDiff = maxT + maxST + | otherwise = maxT + + skipAdjustment <- adjustmentNew tSkip 0.00001 maxSkip 0.1 0 0 + markAdjustment <- adjustmentNew (fromIntegral tMark) 1 32000 1 0 0 + toggleButtonSetActive buttonAuto auto + + spinButtonConfigure ticksSkip skipAdjustment 0.1 5 + spinButtonConfigure ticksMark markAdjustment 1 0 + + onClicked buttonSet (do + --putStrLn "Ok?" + valSkip <- spinButtonGetValue ticksSkip + valMark <- spinButtonGetValue ticksMark + valAuto <- toggleButtonGetActive buttonAuto + state <- takeMVar st + putMVar st (state { autoTicks=valAuto, tickSkip=valSkip, tickMark=floor valMark }) + widgetQueueDraw pic + ) + + + windowSetTitle ticksDlg "Edit Ticks" + windowSetTransientFor ticksDlg window + widgetShowAll ticksDlg + + ) + onActivateLeaf menuTotal (do -- zoom picture to the size of this window + visibleRegion <- drawableGetVisibleRegion win + Rectangle _ _ w h <- regionGetClipbox visibleRegion -- get dimensions + widgetSetSizeRequest pic (minimum [w, 32000]) (minimum [h, 32000])) + onActivateLeaf menuRefresh (widgetQueueDraw pic) -- refresh picture (remove artefacts) + onActivateLeaf menuAbout showAboutDlg -- show program information + onActivateLeaf menuStartupMarker (widgetQueueDraw pic) + -- Actions/Events from Toolbar + onExpose pic (\_ -> do + v <- comboBoxGetActive viewselect + drawStartupMarker <- checkMenuItemGetActive menuStartupMarker + hideStartupPhase <- checkMenuItemGetActive menuHideStartupPhase + drawBlockMsgs <- checkMenuItemGetActive menuBlockMsgs + drawDataMsgs <- checkMenuItemGetActive menuDataMsgs + drawSystemMsgs <- checkMenuItemGetActive menuSystemMsgs + case v of + 3 -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs 0 0 (renderWithDrawable win) (drawGroupProcesses) pic traces st edentvState nm + 2 -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs 0 0 (renderWithDrawable win) (drawThreads) pic traces st edentvState nt + 1 -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs 0 0 (renderWithDrawable win) (drawProcesses) pic traces st edentvState np + _ -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs 0 0 (renderWithDrawable win) (drawMachines) pic traces st edentvState nm + return False) + -- when the viewport slides over the image, the axes have to be redrawn: + hAdj <- viewportGetHAdjustment viewport + onValueChanged hAdj ( do + ((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic + drawWindowInvalidateRect win + (Rectangle vx vy 100 vh) True) + vAdj <- viewportGetVAdjustment viewport + onValueChanged vAdj ( do + ((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic + let bot = 100 + drawWindowInvalidateRect win + (Rectangle vx (vy+vh-bot) vw bot) True) + onToolButtonClicked buttonToPng (do -- save image to file (toolbutton) + widgetActivate menuSave + return ()) + onActivateLeaf menuAllM ( do -- switch to machine view + v <- comboBoxGetActive viewselect + setTo <- checkMenuItemGetActive menuAllM + if setTo && v /= 0 + then comboBoxSetActive viewselect 0 + else return () + ) + onActivateLeaf menuAllP ( do -- switch to process view + v <- comboBoxGetActive viewselect + setTo <- checkMenuItemGetActive menuAllP + if setTo && v /= 1 + then comboBoxSetActive viewselect 1 + else return () + ) + onActivateLeaf menuAllGP ( do -- switch to process view + v <- comboBoxGetActive viewselect + setTo <- checkMenuItemGetActive menuAllGP + if setTo && v /= 3 + then comboBoxSetActive viewselect 3 + else return () + ) + onActivateLeaf menuAllT ( do -- switch to thread view + v <- comboBoxGetActive viewselect + setTo <- checkMenuItemGetActive menuAllT + if setTo && v /= 2 + then comboBoxSetActive viewselect 2 + else return () + ) + on viewselect changed (do + state <- takeMVar st + v <- comboBoxGetActive viewselect -- get the view to switch to + -- update the menu items: + case v of + 3 -> checkMenuItemSetActive menuAllGP True + 2 -> checkMenuItemSetActive menuAllT True + 1 -> checkMenuItemSetActive menuAllP True + 0 -> checkMenuItemSetActive menuAllM True + -- save the view settings and refresh image: + putMVar st (state { selRow = [], selView = v }) + widgetQueueDraw pic) + onMotionNotify pic False (\e -> do -- the mouse has moved above the image: + active <- checkMenuItemGetActive menuMarker + let mx = eventX e + my = eventY e + if active -- then marker has to be redrawn + then do + hideStartupPhase <- checkMenuItemGetActive menuHideStartupPhase + handleMouseMove st edentvState hideStartupPhase pic traces mx my + else return () + state <- readMVar st + if (clicked state) then handleDragnDrop st pic traces mx my else return () + return False) + onButtonPress pic (\e -> do -- a mousebutton was pressed + state <- takeMVar st + win <- widgetGetDrawWindow pic + ((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic + let mx = eventX e + my = eventY e + activeClick = (mx > ulx && my > uly && mx < lrx && my < lry) + pixbuf <- pixbufGetFromDrawable win (Rectangle 0 0 50 vh) + putMVar st (state { clicked = activeClick, oldView = pixbuf }) + v <- comboBoxGetActive viewselect + handleButtonPress pic v st e traces) + + onButtonRelease pic (\e -> do -- a mousebutton was released + state <- takeMVar st + ((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic + let mx = eventX e + my = eventY e + didClick = clicked state + putMVar st (state { clicked = False }) + v <- comboBoxGetActive viewselect + if (mx > ulx && my > uly && mx < lrx && my < lry) && (didClick) + then performDragnDrop v st pic traces mx my + else return () + widgetQueueDraw pic + return False + ) + onToolButtonClicked buttonInfo ( do -- show traceinformation + (Just gladeXML) <- edentvGladeFile (Just "info_win") Nothing + infoDlg <- xmlGetWidget gladeXML castToWindow "info_win" + windowSetTitle infoDlg ("Info - " ++ filename) + windowSetTransientFor infoDlg window + showTraceInfo traces filename (statusString {- ++ "\n(" + ++ show allMsgs ++ " Messages overall; " + ++ show allP ++ " Processes overall)"-}) gladeXML + widgetShowAll infoDlg) + onToolButtonClicked buttonConfMsgs ( do -- show configure Messages Window + (Just gladeXML) <- edentvGladeFile (Just "confmsgs_win") Nothing + confDlg <- xmlGetWidget gladeXML castToWindow "confmsgs_win" + v <- comboBoxGetActive viewselect + + buildConfMsg st gladeXML pic v + + windowSetTitle confDlg "Configure Messages" + windowSetTransientFor confDlg window + widgetShowAll confDlg + ) + onToolButtonClicked buttonLocalNull (do -- toggle local/global zero + state <- takeMVar st + localNull <- toggleToolButtonGetActive buttonLocalNull + putMVar st (state { selRow = [], locTime = localNull }) + widgetQueueDraw pic) + onToolButtonClicked buttonMessages (do -- show/hide Messages + messagesOn <- toggleToolButtonGetActive buttonMessages + state <- takeMVar st + if (EdenTvType.ignoreMessages state) + then do + -- the trace file was read without parsing messages, + -- so the file has to be read again + putMVar st state + if messagesOn + then do + -- ask the user if the file should be re-parsed + reparseDialog <- messageDialogNew + (Just window) + [DialogModal] + MessageQuestion + ButtonsOkCancel + ("The current trace file has been opened without parsing the messages. " ++ + "Should the file be read again and should the messages be displayed?") + response <- dialogRun reparseDialog + widgetDestroy reparseDialog + case response of + ResponseOk -> + -- load file and also show messages + tryToOpen (EdenTvType.filename state) widgets False True edentvState + _ -> return() + else return () + -- also disable the button again, because no messages are displayed + -- in this window + toggleToolButtonSetActive buttonMessages False + else do + -- messages were parsed while reading the trace file, + -- so just show them + putMVar st (state { selRow = [], showMsg = messagesOn }) + widgetQueueDraw pic) + + -- change theposition of selected line + onToolButtonClicked moveUp ( do + v <- comboBoxGetActive viewselect + handleMoveUp pic v st) + onToolButtonClicked moveDown (do + v <- comboBoxGetActive viewselect + handleMoveDown pic v st) + -- Show Trace-Window + widgetShowAll window + widgetQueueDraw pic + -- traces drawn => all information consumed => file can be closed + --hClose fileHdl + + -- show messages on first display? + if showMessages + then toggleToolButtonSetActive buttonMessages True + else return() + where + -- Zoom in/out horizontally by keeping the current position + -- + zoomAt :: Double -> Double -> DrawingArea -> (Int -> Int) -> Viewport -> IO () + zoomAt mousePosX mousePosYFlipped pic zoomFactor viewport = do + (w,h) <- widgetGetSize pic + adjustmentH <- viewportGetHAdjustment viewport + adjustmentV <- viewportGetVAdjustment viewport + + -- point (0, 0) on the drawing area is in the lower left, but the + -- coordinate system of the mouse position starts in upper left + heightViewPort <- adjustmentGetPageSize adjustmentV + let mousePosY = heightViewPort - mousePosYFlipped + + -- get the current position + (relativePosXViewPort, relativePosXTotal) + <- getRelativePositonAt mousePosX adjustmentH + (relativePosYViewPort, relativePosYTotal) + <- getRelativePositonAt mousePosY adjustmentV + + -- restore the position once the new size is set + restorePosition (setPositionAt adjustmentH relativePosXViewPort relativePosXTotal) + (setPositionAt adjustmentV relativePosYViewPort relativePosYTotal) + adjustmentH + adjustmentV + + widgetSetSizeRequest pic (minimum [zoomFactor w, 32000]) h + + where + -- chart borders in pixels + pageBorderLeft = 55 + pageBorderRight = 20 + pageBorder = pageBorderLeft + pageBorderRight + + -- Returns the relative position of the mouse pointer + -- - relative to the viewable extent + -- - relative to whole size (including the scrollable part) + -- + getRelativePositonAt :: Double -> Adjustment -> IO (Double, Double) + getRelativePositonAt position adj = do + min <- adjustmentGetLower adj + max <- adjustmentGetUpper adj + val <- adjustmentGetValue adj + + viewableSize <- adjustmentGetPageSize adj + let totalSize = max - min + + return ((position - val - pageBorderLeft) / (viewableSize - pageBorder), + (position - min - pageBorderLeft) / (totalSize - pageBorder)) + + setPositionAt :: Adjustment -> Double -> Double -> IO () + setPositionAt adj relativePosViewPort relativePosTotal = do + min <- adjustmentGetLower adj + max <- adjustmentGetUpper adj + + viewableSize <- adjustmentGetPageSize adj + let totalSize = max - min + + let zoomPoint = (totalSize - pageBorder) * relativePosTotal + let position = zoomPoint - ((viewableSize - pageBorder) * relativePosViewPort) + let newValue + | position < min = min + | position + viewableSize > max = max - viewableSize + | otherwise = position + + adjustmentSetValue adj newValue + + + zoom :: DrawingArea -> (Int -> Int) -> (Int -> Int) -> Viewport -> IO () + zoom pic fX fY viewport = do + (w,h) <- widgetGetSize pic + + -- get the current position + adjustmentH <- viewportGetHAdjustment viewport + adjustmentV <- viewportGetVAdjustment viewport + relativePosX <- getRelativePositon adjustmentH + relativePosY <- getRelativePositon adjustmentV + + -- restore the position once the new size is set + restorePosition (setPosition adjustmentH relativePosX) + (setPosition adjustmentV relativePosY) + adjustmentH + adjustmentV + + -- the resolution is restricted to 32K*32K, + -- this is because DrawingArea immediately would allocate a backing store + -- of 32k * 32k * (3 Bytes/pixel) memory and because x values are + -- limited to short integer (-32768/+32767) + widgetSetSizeRequest pic (minimum [fX w, 32000]) (minimum [fY h, 32000]) + + where + -- Returns the relative position of the center point. + -- + getRelativePositon :: Adjustment -> IO (Double) + getRelativePositon adj = do + min <- adjustmentGetLower adj + max <- adjustmentGetUpper adj + val <- adjustmentGetValue adj + pageSize <- adjustmentGetPageSize adj + let center = val + (pageSize / 2) + + return ((center - min) / (max - min)) + + setPosition :: Adjustment -> Double -> IO () + setPosition adj relativePos = do + min <- adjustmentGetLower adj + max <- adjustmentGetUpper adj + pageSize <- adjustmentGetPageSize adj + + let center = min + (max - min) * relativePos + let newValue + | (center + (pageSize / 2)) >= max = max - pageSize + | otherwise = (center - (pageSize / 2)) + + adjustmentSetValue adj newValue + + restorePosition :: (IO ()) -> (IO ()) -> Adjustment -> Adjustment -> IO () + restorePosition setPositionH setPositionV adjustmentH adjustmentV = do + mfix $ \ handlerId -> afterAdjChanged adjustmentH (do + setPositionH + signalDisconnect handlerId) + mfix $ \ handlerId -> afterAdjChanged adjustmentV (do + setPositionV + signalDisconnect handlerId) + return () + + +-- export to Picture: +-- Attention: parts of the window, that are off-screen, are not being exported! +--saveToFile :: DrawColor -> Events -> (Int,Int,Int) -> Int -> ViewerState -> DrawingArea -> IO () +saveToFile drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs traces (nt,np,nm) v st edentvState pic = do + -- redraw window (refresh the image) + widgetQueueDraw pic + -- extract Image from Window: + win <- widgetGetDrawWindow pic + visibleRegion <- drawableGetVisibleRegion win + visible <- regionGetClipbox visibleRegion + let Rectangle visX visY visW visH = visible + mPixbuf <- pixbufGetFromDrawable win visible + -- ask for filename: + selectFilename <- fileChooserDialogNew (Just "Save Picture") Nothing + FileChooserActionSave [("_Save",ResponseOk),("Cancel",ResponseCancel)] + dialogSetDefaultResponse selectFilename ResponseOk + -- add filters for special filetypes: + filterAll <- fileFilterNew + filterAll `fileFilterAddPattern` "*.*" + filterAll `fileFilterSetName` "all Files" + filterImg <- fileFilterNew -- to select the filetype + fileFilterAddPixbufFormats filterImg -- add imagetypes + filterImg `fileFilterAddPattern` "*.pdf" + filterImg `fileFilterSetName` "all known images" + selectFilename `fileChooserAddFilter` filterAll -- add filters to dialog + selectFilename `fileChooserAddFilter` filterImg + filterPDF <- fileFilterNew + filterPDF `fileFilterAddPattern` ("*.pdf") + filterPDF `fileFilterSetName` "Portable Document Format (*.pdf)" + selectFilename `fileChooserAddFilter` filterPDF + addSpecialFilters selectFilename pixbufGetFormats + -- show and run the dialog: + widgetShow selectFilename + response <- dialogRun selectFilename + case response of + ResponseCancel -> widgetDestroy selectFilename -- don't save the image + ResponseOk -> do + Just filename <- fileChooserGetFilename selectFilename + let filetype = reverse (takeWhile (/= '.') (reverse filename)) -- extract the choosen filetype + if (elem filetype ["bmp","jpg","jpeg","png", "pdf"]) -- filetype recognized? + then do + widgetDestroy selectFilename + pathExists <- doesDirectoryExist filename + fileExists <- doesFileExist filename + doWrite <- if pathExists + then do errorMessage (filename ++ " is a Directory.") + return False + else if fileExists + then yesNoMessage (filename ++ " exists, overwrite?") + else return True + if doWrite + then case mPixbuf of + Nothing -> error "saveToFile: Window not visible" + Just p -> do + if (elem filetype ["bmp","jpg","jpeg","png"]) + then pixbufSave p filename (if filetype == "jpg" then "jpeg" else filetype) [] + else do + + case v of + 3 -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawGroupProcesses) pic traces st edentvState nt ) + 2 -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawThreads) pic traces st edentvState nt ) + 1 -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawProcesses) pic traces st edentvState nt ) + _ -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawMachines) pic traces st edentvState nt ) + else return () + else do -- unknown filetype + widgetDestroy selectFilename + maybeGladeXML <- edentvGladeFile (Just "dlg_err_save_filetype") Nothing + let gladeXML = case maybeGladeXML of + (Just glade) -> glade + Nothing -> error "missing file: \"edentv.glade\"!" + dlg <- xmlGetWidget gladeXML castToDialog "dlg_err_save_filetype" + dlg `afterResponse` (\_ -> widgetDestroy dlg) + widgetShowAll dlg + -- allowed filetypes: png bmp wbmp gif ico ani jpeg pnm ras tiff xpm xbm tga + -- supported: png, bmp, jpeg + _ -> widgetDestroy selectFilename + return () + where addSpecialFilters _ [] = return () + addSpecialFilters dlg (f:fs) = do + filter <- fileFilterNew + filter `fileFilterAddPattern` ("*." ++ f) + case f of + "pdf" -> do + filter `fileFilterSetName` "Portable Document Format(*.pdf)" + dlg `fileChooserAddFilter` filter + "png" -> do + filter `fileFilterSetName` "Portable Networks Graphics (*.png)" + dlg `fileChooserAddFilter` filter + "bmp" -> do + filter `fileFilterSetName` "Windows Bitmap (*.bmp)" + dlg `fileChooserAddFilter` filter + "jpeg" -> do + filter `fileFilterAddPattern` ("*.jpg") + filter `fileFilterSetName` "Joint Photographic Experts Group (*.jpeg)" + dlg `fileChooserAddFilter` filter + _ -> return () + addSpecialFilters dlg fs + +-- start GUI +main :: IO () +main = do + putStrLn ("This is EdenTV v" ++ version ++ ". Happy tracing!") + initGUI -- for GTK+ + -- load Glade-description + maybeGladeXML <- edentvGladeFile (Just "EdTVMain") Nothing + -- TODO: Search in current directory and in directory of EdenTV-executable + let gladeXML = case maybeGladeXML of + (Just glade) -> glade + Nothing -> error "missing file: \"edentv.glade\"!" + -- load Widgets from Glade-description + -- main window + windowMain <- xmlGetWidget gladeXML castToWindow "EdTVMain" + + -- colorbuttons + iCB <- xmlGetWidget gladeXML castToColorButton "idle_colorbutton" + rCB <- xmlGetWidget gladeXML castToColorButton "running_colorbutton" + sCB <- xmlGetWidget gladeXML castToColorButton "suspended_colorbutton" + bCB <- xmlGetWidget gladeXML castToColorButton "blocked_colorbutton" + -- other toolbar entries + toolbarOpen <- xmlGetWidget gladeXML castToToolButton "toolbar_Open" + -- menu entries + menuFileOpen <- xmlGetWidget gladeXML castToMenuItem "menuFile_Open" + menuFileOpenWithoutMsgs <- xmlGetWidget gladeXML castToMenuItem "menuFile_OpenWithoutMsgs" + menuFileExit <- xmlGetWidget gladeXML castToMenuItem "menuFile_Quit" + + cCol <- xmlGetWidget gladeXML castToRadioMenuItem "default_colors" + cBW <- xmlGetWidget gladeXML castToRadioMenuItem "default_colBW" + menuOptsSetColors <- xmlGetWidget gladeXML castToMenuItem "menuOptions_SetColors" + + menuWindows <- xmlGetWidget gladeXML castToMenu "windows_menu" + refreshWins <- xmlGetWidget gladeXML castToMenuItem "refresh_all" + menuHelpAbout <- xmlGetWidget gladeXML castToMenuItem "menuHelp_About" + -- menuSetTitle menuWindows "active Documents" + + -- initial state with default colors + edentvState <- newMVar (ES { lastPath = "", colors = getDefaultColors }) + + -- Eventhandling: + onDelete windowMain deleteEvent + onDestroy windowMain destroyEvent + onActivateLeaf menuFileExit quitEvent + onToolButtonClicked toolbarOpen (do {widgetActivate menuFileOpen; return ()}) -- open tracefile + winMenus <- newMVar WS {windowsMenus=[menuWindows]} + + -- open tracefile + onActivateLeaf menuFileOpen + (openEvent windowMain (menuWindows,menuFileOpen,menuFileOpenWithoutMsgs,menuFileExit, winMenus) edentvState False) + -- open tracefile without parsing messages + onActivateLeaf menuFileOpenWithoutMsgs + (openEvent windowMain (menuWindows,menuFileOpen,menuFileOpenWithoutMsgs,menuFileExit, winMenus) edentvState True) + + -- handling colors + let updateMainColorButtons colorMap = do + updateColorButton iCB (statusIdle colorMap) + updateColorButton rCB (statusRunning colorMap) + updateColorButton sCB (statusSuspended colorMap) + updateColorButton bCB (statusBlocked colorMap) + let setTemplateMenuInconsistent = do + checkMenuItemSetInconsistent cCol True + checkMenuItemSetInconsistent cBW True + onActivateLeaf menuOptsSetColors (showSetColorDialog edentvState menuWindows updateMainColorButtons + setTemplateMenuInconsistent) + + onActivateLeaf cCol ( do + setDefaultColors cCol edentvState menuWindows updateMainColorButtons + checkMenuItemSetInconsistent cBW False) + onActivateLeaf cBW ( do + setDefaultBW cBW edentvState menuWindows updateMainColorButtons + checkMenuItemSetInconsistent cCol False) + + onColorSet iCB (colorChanged iCB edentvState + (\ color colors -> colors {statusIdle = color}) menuWindows setTemplateMenuInconsistent) + onColorSet rCB (colorChanged rCB edentvState + (\ color colors -> colors {statusRunning = color}) menuWindows setTemplateMenuInconsistent) + onColorSet sCB (colorChanged sCB edentvState + (\ color colors -> colors {statusSuspended = color}) menuWindows setTemplateMenuInconsistent) + onColorSet bCB (colorChanged bCB edentvState + (\ color colors -> colors {statusBlocked = color}) menuWindows setTemplateMenuInconsistent) + + -- a list of all opened windows + onActivateLeaf refreshWins (refreshAll menuWindows) + onActivateLeaf menuHelpAbout showAboutDlg -- not supported on CentOS!!! + + -- set default colors on start-up + setDefaultColors cCol edentvState menuWindows updateMainColorButtons + checkMenuItemSetActive cCol True + + -- load tracefile if filename is in commandline + args <- getArgs + if (null args) + then return () + else case (head args) of + "--version" -> exitWith ExitSuccess + "--help" -> do + putStrLn " EdenTV just open main dialog of EdenTV" + putStrLn " EdenTV run EdenTV and open " + putStrLn " EdenTV --version print version and exit" + putStrLn " EdenTV --help print this help and exit" + exitWith ExitSuccess + hArgs -> do + cPath <- canonicalizePath hArgs + let path = (reverse (tail (dropWhile (\c -> notElem c ['\\','/']) (reverse cPath)))) + swapMVar edentvState (ES { lastPath = path, colors = getDefaultColors }) + tryToOpen hArgs (menuWindows, menuFileOpen, menuFileOpenWithoutMsgs, menuFileExit, winMenus) False False edentvState + -- for GTK+ + widgetShowAll windowMain + mainGUI + where + -- Called when one of the 4 colors in the main windows was changed + -- + colorChanged colorButton edentvState setter openTraceWindows setTemplateMenuInconsistent = do + globalState <- readMVar edentvState + let colorMap = colors globalState + newColor <- getColorFromColorButton colorButton + + -- store new color in the state + let colorMap' = setter newColor colorMap + swapMVar edentvState (globalState {colors = colorMap' }) + + setTemplateMenuInconsistent + refreshAll openTraceWindows + +setDefaultColors, setDefaultBW :: RadioMenuItem -> MVar EdenTvState -> Menu -> (Colors -> IO ()) -> IO () +setDefaultColors cCol edentvState openTraceWindows updateMainColorButtons = do + isActive <- get cCol checkMenuItemActive + when isActive $ do + setNewColors edentvState (getDefaultColors) openTraceWindows updateMainColorButtons + checkMenuItemSetInconsistent cCol False +setDefaultBW cBW edentvState openTraceWindows updateMainColorButtons = do + isActive <- get cBW checkMenuItemActive + when isActive $ do + setNewColors edentvState (getDefaultColorsBW) openTraceWindows updateMainColorButtons + checkMenuItemSetInconsistent cBW False + +-- This function takes care of displaying the dialog to customize all +-- colors (not just the four shown in the main window). If the dialog is +-- closed with `Ok`, the new colors are stored in the state and all open +-- trace windows are refreshed. +-- +showSetColorDialog :: MVar EdenTvState -> Menu -> (Colors -> IO ()) -> (IO ()) -> IO () +showSetColorDialog edentvState openTraceWindows updateMainColorButtons setTemplateMenuInconsistent = do + (Just gladeXML) <- edentvGladeFile (Just "dialogColors") Nothing + colorsDialog <- xmlGetWidget gladeXML castToDialog "dialogColors" + + globalState <- readMVar edentvState + updateDialogFromState gladeXML (colors globalState) + + dialogResponse <- dialogRun colorsDialog + + case dialogResponse of + ResponseAccept -> do + colors' <- updateStateFromDialog gladeXML (colors globalState) + setNewColors edentvState colors' openTraceWindows updateMainColorButtons + setTemplateMenuInconsistent + + _ -> return () + + widgetDestroy colorsDialog + return () + + where + updateDialogFromState :: GladeXML -> Colors -> IO () + updateDialogFromState gladeXML colors = do + mapM_ (updateColorButtonById gladeXML colors) colorMapping + + -- Sets the color of a color button using the current value in + -- the state. + -- + updateColorButtonById :: GladeXML -> Colors -> ColorMapping -> IO () + updateColorButtonById gladeXML colors (id, getter, _) = do + let color = getter colors + colorButton <- xmlGetWidget gladeXML castToColorButton id + updateColorButton colorButton color + + -- Retrieves the changed colors from the dialog and stores them in + -- the state. + -- + updateStateFromDialog :: GladeXML -> Colors -> IO (Colors) + updateStateFromDialog gladeXML colors = do + newColors <- mapM getColor colorMapping + let colors' = foldr applyColor colors $ zip colorMapping newColors + return (colors') + + where + applyColor :: (ColorMapping, ColorRGBA) -> Colors -> Colors + applyColor ((_, _, setter), newColor) colors = setter newColor colors + + getColor :: ColorMapping -> IO (ColorRGBA) + getColor (id, _, _) = getColorFromColorButtonById gladeXML id + + getColorFromColorButtonById :: GladeXML -> String -> IO (ColorRGBA) + getColorFromColorButtonById gladeXML id = do + colorButton <- xmlGetWidget gladeXML castToColorButton id + getColorFromColorButton colorButton + +-- Stores new colors in the state, updates the main windows color buttons and +-- refreshes all open trace windows. +-- +setNewColors :: MVar EdenTvState -> Colors -> Menu -> (Colors -> IO ()) -> IO () +setNewColors edentvState newColors openTraceWindows updateMainColorButtons = do + globalState <- takeMVar edentvState + putMVar edentvState (globalState {colors = newColors}) + updateMainColorButtons newColors + refreshAll openTraceWindows + +updateColorButton :: ColorButton -> ColorRGBA -> IO () +updateColorButton colorButton color = do + colorButtonSetColor colorButton (rgbColor color) + colorButtonSetAlpha colorButton (alpha color) + +getColorFromColorButton :: ColorButton -> IO (ColorRGBA) +getColorFromColorButton colorButton = do + rgbColor <- colorButtonGetColor colorButton + alpha <- colorButtonGetAlpha colorButton + + return (RGBA {rgbColor = rgbColor, alpha = alpha}) + + +addMenuLabelToToolItem :: GladeXML -> String -> String -> IO () +addMenuLabelToToolItem gladeXML toolItemId labelCaption + = do toolItem <- xmlGetWidget gladeXML castToToolItem toolItemId + label <- imageMenuItemNewWithLabel labelCaption + let labelId = toolItemId ++ "Label" + toolItemSetProxyMenuItem toolItem labelId label + +refreshAll :: Menu -> IO () +refreshAll menu = do + (_:winList) <- containerGetChildren menu + refresh winList + where refresh [] = return () + refresh (l:ls) = do + Just submenu <- menuItemGetSubmenu (castToMenuItem l) + (_:r:_) <- containerGetChildren (castToMenu submenu) + widgetActivate r + refresh ls + +showAboutDlg = do + dlg <- aboutDialogNew + dlg `aboutDialogSetName` "EdenTV" + dlg `aboutDialogSetVersion` version + dlg `aboutDialogSetComments` "Trace Viewer for Eden Trace Files" + dlg `aboutDialogSetLicense` Nothing + dlg `aboutDialogSetWebsite` "http://www.mathematik.uni-marburg.de/~eden" + dlg `aboutDialogSetWebsiteLabel` "Take me to Eden" + dlg `aboutDialogSetAuthors` ["Bjoern Struckmeier","Bernhard Pickenbrock","","Betreuung:","Prof. Dr. Rita Loogen"] + dlg `afterResponse` (\_ -> widgetDestroy dlg) + widgetShowAll dlg + diff --git a/EdenTvBasic.hs b/EdenTvBasic.hs new file mode 100644 --- /dev/null +++ b/EdenTvBasic.hs @@ -0,0 +1,183 @@ +{- The Eden Trace Viewer (or simply EdenTV) is a tool that can generate diagrams to visualize the behaviour of Eden programs. + Copyright (C) 2005-2010 Phillips Universitaet Marburg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +-} + + + +module EdenTvBasic where + +import EdenTvType +import Graphics.Rendering.Cairo +import Graphics.UI.Gtk.Gdk.GC +import Numeric +import Data.Tree hiding (drawTree) +import Data.Word + +-- adaption of Data.Tree.drawTree for (Tree a) +-- | Neat 2-dimensional drawing of a tree. +drawTree :: Show a => Tree a -> String +drawTree = unlines . drawTree_ + +drawTree_ :: Show a => Tree a -> [String] +drawTree_ (Node p pts) = show p : drawSubTrees pts + where drawSubTrees [] = [] + drawSubTrees [t] = + "|" : shift "`-- " " " (drawTree_ t) + drawSubTrees (t:ts) = + "|" : shift "+-- " "| " (drawTree_ t) ++ drawSubTrees ts + shift first other = zipWith (++) (first : repeat other) + +-- some standard colors +-- color___ :: Render () +colorRedA = setSourceRGBA 0.8 0.0 0.0 0.7 +colorGray = setSourceRGB 0.5 0.5 0.5 +colorBlack = setSourceRGB 0.0 0.0 0.0 + +getDefaultColors :: Colors +getDefaultColors = Colors + { statusRunning = rgb 0 65535 0 + , statusSuspended = rgb 65535 65535 0 + , statusBlocked = rgb 65535 0 0 + , statusIdle = rgb 0 0 65535 + + , messagesSystem = rgb 41120 0 0 + , messagesHead = rgb 6553 6553 6553 + , messagesData = rgb 6553 6553 6553 + , messagesHeadLocal = rgb 3328 0 47616 + , messagesDataLocal = rgb 3328 0 47616 + , messagesBlock = rgb 19660 19660 19660 + , messagesReceive = rgb 6553 6553 6553 + + , markerLine = rgba 52428 0 0 45874 + , markerLabel = rgba 52428 0 0 45874 + , markerStartup = rgba 52428 0 0 45874 + + , chartBackground = rgb 65535 65535 65535 + , chartAxes = rgba 0 0 0 45874 + , chartAxesLabel = rgba 0 0 0 45874 + } + +getDefaultColorsBW :: Colors +getDefaultColorsBW = Colors + { statusRunning = rgb 39500 39500 39500 + , statusSuspended = rgb 59000 59000 59000 + , statusBlocked = rgb 19500 19500 19500 + , statusIdle = rgb 0 0 0 + + , messagesSystem = rgb 32767 32767 32767 + , messagesHead = rgb 6553 6553 6553 + , messagesData = rgb 6553 6553 6553 + , messagesHeadLocal = rgb 6553 6553 6553 + , messagesDataLocal = rgb 6553 6553 6553 + , messagesBlock = rgb 19660 19660 19660 + , messagesReceive = rgb 6553 6553 6553 + + , markerLine = rgba 52428 0 0 45874 + , markerLabel = rgba 52428 0 0 45874 + , markerStartup = rgba 52428 0 0 45874 + + , chartBackground = rgb 65535 65535 65535 + , chartAxes = rgba 0 0 0 45874 + , chartAxesLabel = rgba 0 0 0 45874 + } + +getColor :: (Colors -> ColorRGBA) -> Colors -> Render () +getColor getter colors = setSourceRGBA r g b a + where + (r, g, b, a) = getCairoColor $ getter colors + +getColorAlpha :: (Colors -> ColorRGBA) -> Colors -> Double -> Render () +getColorAlpha getter colors alpha = setSourceRGBA r g b alpha + where + (r, g, b, _) = getCairoColor $ getter colors + +getCairoColor :: ColorRGBA -> (Double, Double, Double, Double) +getCairoColor (RGBA (Color r g b) a) = (toCairo r, toCairo g, toCairo b, toCairo a) + where + -- Converts a GTK color value (0 - 65535) to a Cairo + -- color value (0 - 1). + toCairo :: Word16 -> Double + toCairo val = (fromIntegral val) / 65535 + +type ColorGetter = Colors -> ColorRGBA +type ColorSetter = ColorRGBA -> Colors -> Colors +type ColorMapping = (String, ColorGetter, ColorSetter) + +-- Maps the color buttons in the "Set Color" - dialog to the color values +-- in the state (`EdenTvState`). +colorMapping :: [ColorMapping] +colorMapping = + [ ("btnStatusRunning", statusRunning, \ color colors -> colors {statusRunning = color}) + , ("btnStatusSuspended", statusSuspended, \ color colors -> colors {statusSuspended = color}) + , ("btnStatusBlocked", statusBlocked, \ color colors -> colors {statusBlocked = color}) + , ("btnStatusIdle", statusIdle, \ color colors -> colors {statusIdle = color}) + + , ("btnMessagesSystem", messagesSystem, \ color colors -> colors {messagesSystem = color}) + , ("btnMessagesHead", messagesHead, \ color colors -> colors {messagesHead = color}) + , ("btnMessagesData", messagesData, \ color colors -> colors {messagesData = color}) + , ("btnMessagesBlock", messagesBlock, \ color colors -> colors {messagesBlock = color}) + , ("btnMessagesReceive", messagesReceive, \ color colors -> colors {messagesReceive = color}) + + , ("btnMarkerLine", markerLine, \ color colors -> colors {markerLine = color}) + , ("btnMarkerLabel", markerLabel, \ color colors -> colors {markerLabel = color}) + , ("btnMarkerStartup", markerStartup, \ color colors -> colors {markerStartup = color}) + + , ("btnChartBackground", chartBackground, \ color colors -> colors {chartBackground = color}) + , ("btnChartAxes", chartAxes, \ color colors -> colors {chartAxes = color}) + , ("btnAxesLabel", chartAxesLabel, \ color colors -> colors {chartAxesLabel = color}) + ] + +-- ScreenSetup: +border, shadow :: Double +border = 5 +shadow = 3 + +-- getStartTime : gap between local and global starttime of machine i +-- perhaps: use assoziative array / hashtable +getStartTime :: MachineID -> [(MachineID,Double)] -> Double +getStartTime _ [] = 0.0 -- machine not found? +getStartTime i ((m,t):ts) + | m == i = t + | otherwise = getStartTime i ts + +posToTime :: Seconds -> Seconds -> Double -> Double -> Double -> Seconds +posToTime minT maxT ulx lrx x = ((x - ulx) * (maxT - minT) / (lrx - ulx)) + +timeToPos :: Seconds -> Seconds -> Double -> Double -> Seconds -> Double +timeToPos minT maxT ulx lrx y = ((y * (lrx - ulx)) / (maxT-minT) + ulx) + +formatFloat :: RealFloat a => a -> String +formatFloat d = showFFloat (Just 6) d "" + +switch :: Eq a => a -> a -> [a] -> [a] +{-switch m n matrix = switch' matrix + where + switch' (d:ds) + | d == m = n : switch' ds + | d == n = m : switch' ds + | otherwise = d : switch' ds + switch' _ = [] +-} + +-- faster switch (old one in O(2n), this one in O(n)): +switch m n (d:ds) + | d == m = n : switch' n m ds + | d == n = m : switch' m n ds + | otherwise = d : switch m n ds + where switch' o p (e:es) + | e == o = p : es + | otherwise = e : switch' o p es + -- switch' _ _ [] = [] diff --git a/EdenTvInteract.hs b/EdenTvInteract.hs new file mode 100644 --- /dev/null +++ b/EdenTvInteract.hs @@ -0,0 +1,892 @@ +{- The Eden Trace Viewer (or simply EdenTV) is a tool that can generate diagrams to visualize the behaviour of Eden programs. + Copyright (C) 2005-2010 Phillips Universitaet Marburg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +-} + +{-# OPTIONS_GHC -cpp #-} +-- JB first draft: commented out features missing in Gtk2hs-0.9.11 +module EdenTvInteract where + +import EdenTvType +import EdenTvBasic +import Graphics.UI.Gtk hiding (get, eventButton) +import Graphics.UI.Gtk.Gdk.Events +import qualified Graphics.UI.Gtk.Gdk.GC as G +import Graphics.UI.Gtk.Glade +-- JB: not in Gtk2hs-0.9.11 any more: +-- import Graphics.UI.Gtk.Mogul +import Graphics.UI.Gtk.ModelView.TreeView +import Graphics.UI.Gtk.ModelView.ListStore +import Graphics.Rendering.Cairo +import Data.Tree hiding (drawTree) +import Data.Char +import Control.Concurrent.MVar + +import Data.List + +import Debug.Trace + +-- get dimensions of drawinarea: +-- visible Rect and the upper left and lower right corners to draw in +type Dim = (Double,Double,Double,Double) +type DimV = (Int,Int,Int,Int) +getCorners :: DrawingArea -> IO (DimV,Dim) +getCorners pic = do + win <- widgetGetDrawWindow pic + (w,h) <- widgetGetSize pic + vR <- drawableGetVisibleRegion win + Rectangle vx vy vw vh <- regionGetClipbox vR + return ((vx, vy, vw, vh), (border + 50, border + 20, + (realToFrac w) - 20, (realToFrac h) - 20)) + + + +buildConfMsg :: MVar ViewerState -> GladeXML -> DrawingArea -> Int -> IO () +buildConfMsg st glade pic v = do + -- get access to the widgets: + confM <- xmlGetWidget glade castToTreeView "confM" + confP <- xmlGetWidget glade castToTreeView "confP" + noteb <- xmlGetWidget glade castToNotebook "notebook1" + + -- Machine checkBoxes + mId <- treeViewColumnNew + treeViewColumnSetTitle mId "machine id" + treeViewAppendColumn confM mId + rendererMId <- cellRendererTextNew + cellLayoutPackStart mId rendererMId True + + mSnt <- treeViewColumnNew + treeViewColumnSetTitle mSnt "show outgoing" + treeViewAppendColumn confM mSnt + rendererMSnt <- cellRendererToggleNew + cellLayoutPackStart mSnt rendererMSnt True + + mRcv <- treeViewColumnNew + treeViewColumnSetTitle mRcv "show incoming" + treeViewAppendColumn confM mRcv + rendererMRcv <- cellRendererToggleNew + cellLayoutPackStart mRcv rendererMRcv True + + + + state <- readMVar st + dataM <- listStoreNew (confMachines state) + + -- activate right tab view + case v of + 1 -> notebookSetCurrentPage noteb 1 + 3 -> notebookSetCurrentPage noteb 1 + 0 -> notebookSetCurrentPage noteb 0 + _ -> notebookSetCurrentPage noteb 0 + + + -- update the model when the toggle buttons are activated + on rendererMRcv cellToggled $ \pathStr -> do + let (i:_) = stringToTreePath pathStr + (mid,(inb,outb)) <- listStoreGetValue dataM i + listStoreSetValue dataM i (mid,(not inb,outb)) + on rendererMSnt cellToggled $ \pathStr -> do + let (i:_) = stringToTreePath pathStr + (mid,(inb,outb)) <- listStoreGetValue dataM i + listStoreSetValue dataM i (mid,(inb,not outb)) + + cellLayoutSetAttributes mId rendererMId dataM $ \(id,_) -> [ cellText := (show id) ] + cellLayoutSetAttributes mRcv rendererMRcv dataM $ \(_,(inb,_)) -> [ cellToggleActive := inb ] + cellLayoutSetAttributes mSnt rendererMSnt dataM $ \(_,(_,outb)) -> [ cellToggleActive := outb ] + + treeViewSetModel confM dataM + treeViewColumnsAutosize confM + + buttonStoreM <- xmlGetWidget glade castToButton "store_m" + buttonAllInM <- xmlGetWidget glade castToButton "all_in_m" + buttonAllOutM <- xmlGetWidget glade castToButton "all_out_m" + buttonNoneInM <- xmlGetWidget glade castToButton "none_in_m" + buttonNoneOutM <- xmlGetWidget glade castToButton "none_out_m" + + onClicked buttonStoreM (do oldState <- takeMVar st + val <- listStoreToList dataM + --putStrLn ("saving: " ++ (show val)) + putMVar st (oldState {confMachines = val}) + widgetQueueDraw pic) + + onClicked buttonAllInM (do vals <- listStoreToList dataM + let newVals = setAllIn True vals + listStoreClear dataM + sequence_ $ map (\x -> listStoreAppend dataM x) newVals) + + onClicked buttonAllOutM (do vals <- listStoreToList dataM + let newVals = setAllOut True vals + listStoreClear dataM + sequence_ $ map (\x -> listStoreAppend dataM x) newVals) + + onClicked buttonNoneInM (do vals <- listStoreToList dataM + let newVals = setAllIn False vals + listStoreClear dataM + sequence_ $ map (\x -> listStoreAppend dataM x) newVals) + + onClicked buttonNoneOutM (do vals <- listStoreToList dataM + let newVals = setAllOut False vals + listStoreClear dataM + sequence_ $ map (\x -> listStoreAppend dataM x) newVals) + + + + -- Process checkBoxes + pId <- treeViewColumnNew + treeViewColumnSetTitle pId "process id" + treeViewAppendColumn confP pId + rendererPId <- cellRendererTextNew + cellLayoutPackStart pId rendererPId True + + pSnt <- treeViewColumnNew + treeViewColumnSetTitle pSnt "show outgoing" + treeViewAppendColumn confP pSnt + rendererPSnt <- cellRendererToggleNew + cellLayoutPackStart pSnt rendererPSnt True + + pRcv <- treeViewColumnNew + treeViewColumnSetTitle pRcv "show incoming" + treeViewAppendColumn confP pRcv + rendererPRcv <- cellRendererToggleNew + cellLayoutPackStart pRcv rendererPRcv True + + + state <- readMVar st + dataP <- listStoreNew (confProcesses state) + + -- update the model when the toggle buttons are activated + on rendererPRcv cellToggled $ \pathStr -> do + let (i:_) = stringToTreePath pathStr + (mid,(inb,outb)) <- listStoreGetValue dataP i + listStoreSetValue dataP i (mid,(not inb,outb)) + on rendererPSnt cellToggled $ \pathStr -> do + let (i:_) = stringToTreePath pathStr + (mid,(inb,outb)) <- listStoreGetValue dataP i + listStoreSetValue dataP i (mid,(inb,not outb)) + + cellLayoutSetAttributes pId rendererPId dataP $ \(id,_) -> [ cellText := (show id) ] + cellLayoutSetAttributes pRcv rendererPRcv dataP $ \(_,(inb,_)) -> [ cellToggleActive := inb ] + cellLayoutSetAttributes pSnt rendererPSnt dataP $ \(_,(_,outb)) -> [ cellToggleActive := outb ] + + treeViewSetModel confP dataP + treeViewColumnsAutosize confP + + buttonStoreP <- xmlGetWidget glade castToButton "store_p" + buttonAllInP <- xmlGetWidget glade castToButton "all_in_p" + buttonAllOutP <- xmlGetWidget glade castToButton "all_out_p" + buttonNoneInP <- xmlGetWidget glade castToButton "none_in_p" + buttonNoneOutP <- xmlGetWidget glade castToButton "none_out_p" + + onClicked buttonStoreP (do oldState <- takeMVar st + val <- listStoreToList dataP + --putStrLn ("saving: " ++ (show val)) + putMVar st (oldState {confProcesses = val}) + widgetQueueDraw pic) + + onClicked buttonAllInP (do vals <- listStoreToList dataP + let newVals = setAllIn True vals + listStoreClear dataP + sequence_ $ map (\x -> listStoreAppend dataP x) newVals) + + onClicked buttonAllOutP (do vals <- listStoreToList dataP + let newVals = setAllOut True vals + listStoreClear dataP + sequence_ $ map (\x -> listStoreAppend dataP x) newVals) + + onClicked buttonNoneInP (do vals <- listStoreToList dataP + let newVals = setAllIn False vals + listStoreClear dataP + sequence_ $ map (\x -> listStoreAppend dataP x) newVals) + + onClicked buttonNoneOutP (do vals <- listStoreToList dataP + let newVals = setAllOut False vals + listStoreClear dataP + sequence_ $ map (\x -> listStoreAppend dataP x) newVals) + + return () + + + where setAll :: (Bool, Bool) -> [(a,(Bool,Bool))] -> [(a,(Bool,Bool))] + setAll to ((x,_):xs) = (x,to) : (setAll to xs) + setAll _ [] = [] + setAllIn :: Bool -> [(a,(Bool,Bool))] -> [(a,(Bool,Bool))] + setAllIn to ((x,(_,out)):xs) = (x,(to,out)) : (setAllIn to xs) + setAllIn _ [] = [] + setAllOut :: Bool -> [(a,(Bool,Bool))] -> [(a,(Bool,Bool))] + setAllOut to ((x,(i,_)):xs) = (x,(i,to)) : (setAllOut to xs) + setAllOut _ [] = [] + + + + +data MachineInfo = MachineInfo { machId :: String, runtime :: String, numProcesses :: String, numSent :: String, numRcvd :: String} +data ProcessInfo = ProcessInfo { machIdP :: String, procId :: String, runtimeP :: String, numThreads :: String, numSentP :: String, numRcvdP :: String} +data ThreadInfo = ThreadInfo { machIdT :: String, procIdT :: String, thrdId :: String, runtimeT :: String} + +showTraceInfo :: Events -> String -> String -> GladeXML -> IO () +showTraceInfo ((ms,ps,ts),mt,mxst,(msgs,_,heads,pt,_),(minT,maxT,_,_,_),_) filename statusString glade = do + -- get access to the widgets: + infoA <- xmlGetWidget glade castToLabel "infoA" + infoM <- xmlGetWidget glade castToTreeView "infoM" + infoP <- xmlGetWidget glade castToTreeView "infoP" + infoT <- xmlGetWidget glade castToTreeView "infoT" + -- Global information: + labelSetText infoA ("Tracefile: " ++ filename ++ "\n" ++ + map (commaToNewline) statusString ++ "\n\nProcesstree:\n" ++ drawTree pt) + -- Machine information: +-- #if __GLASGOW_HASKELL__ < 606 + --skelM <- emptyListSkel + mId <- treeViewColumnNew + treeViewColumnSetTitle mId "machine id" + treeViewAppendColumn infoM mId + rendererMId <- cellRendererTextNew + cellLayoutPackStart mId rendererMId True + + mTime <- treeViewColumnNew + treeViewColumnSetTitle mTime "runtime (s)" + treeViewAppendColumn infoM mTime + rendererMTime <- cellRendererTextNew + cellLayoutPackStart mTime rendererMTime True + + mPrcs <- treeViewColumnNew + treeViewColumnSetTitle mPrcs "processes" + treeViewAppendColumn infoM mPrcs + rendererMPrcs <- cellRendererTextNew + cellLayoutPackStart mPrcs rendererMPrcs True + + --mTrds <- treeViewColumnNew + --treeViewColumnSetTitle mTrds "threads" + --treeViewAppendColumn infoM mTrds + + mSent <- treeViewColumnNew + treeViewColumnSetTitle mSent "sent messages" + treeViewAppendColumn infoM mSent + rendererMSent <- cellRendererTextNew + cellLayoutPackStart mSent rendererMSent True + + mRcvd <- treeViewColumnNew + treeViewColumnSetTitle mRcvd "received messages" + treeViewAppendColumn infoM mRcvd + rendererMRcvd <- cellRendererTextNew + cellLayoutPackStart mRcvd rendererMRcvd True + + dataM <- listStoreNew [] + -- newListStore skelM + + -- insert machine data + inspectMachine ms dataM + + cellLayoutSetAttributes mId rendererMId dataM $ \row -> [ cellText := machId row ] + cellLayoutSetAttributes mTime rendererMTime dataM $ \row -> [ cellText := runtime row ] + cellLayoutSetAttributes mPrcs rendererMPrcs dataM $ \row -> [ cellText := numProcesses row ] + cellLayoutSetAttributes mSent rendererMSent dataM $ \row -> [ cellText := numSent row ] + cellLayoutSetAttributes mRcvd rendererMRcvd dataM $ \row -> [ cellText := numRcvd row ] + + treeViewSetModel infoM dataM + treeViewColumnsAutosize infoM + + + -- Process information: + --skelP <- emptyListSkel + pMid <- treeViewColumnNew + treeViewColumnSetTitle pMid "on machine" + treeViewAppendColumn infoP pMid + rendererPMid <- cellRendererTextNew + cellLayoutPackStart pMid rendererPMid True + + pId <- treeViewColumnNew + treeViewColumnSetTitle pId "process id" + treeViewAppendColumn infoP pId + rendererPId <- cellRendererTextNew + cellLayoutPackStart pId rendererPId True + + pTime <- treeViewColumnNew + treeViewColumnSetTitle pTime "runtime (s)" + treeViewAppendColumn infoP pTime + rendererPTime <- cellRendererTextNew + cellLayoutPackStart pTime rendererPTime True + + pTrds <- treeViewColumnNew + treeViewColumnSetTitle pTrds "threads" + treeViewAppendColumn infoP pTrds + rendererPTrds <- cellRendererTextNew + cellLayoutPackStart pTrds rendererPTrds True + + pSent <- treeViewColumnNew + treeViewColumnSetTitle pSent "sent messages" + treeViewAppendColumn infoP pSent + rendererPSent <- cellRendererTextNew + cellLayoutPackStart pSent rendererPSent True + + pRcvd <- treeViewColumnNew + treeViewColumnSetTitle pRcvd "received messages" + treeViewAppendColumn infoP pRcvd + rendererPRcvd <- cellRendererTextNew + cellLayoutPackStart pRcvd rendererPRcvd True + + dataP <- listStoreNew [] + + inspectProcess (reverse ps) dataP + + + + + cellLayoutSetAttributes pMid rendererPMid dataP $ \row -> [ cellText := machIdP row ] + cellLayoutSetAttributes pId rendererPId dataP $ \row -> [ cellText := procId row ] + cellLayoutSetAttributes pTime rendererPTime dataP $ \row -> [ cellText := runtimeP row ] + cellLayoutSetAttributes pTrds rendererPTrds dataP $ \row -> [ cellText := numThreads row ] + cellLayoutSetAttributes pSent rendererPSent dataP $ \row -> [ cellText := numSentP row ] + cellLayoutSetAttributes pRcvd rendererPRcvd dataP $ \row -> [ cellText := numRcvdP row ] + + treeViewSetModel infoP dataP + treeViewColumnsAutosize infoP + + + + -- Thread information: + --skelT <- emptyListSkel + tMid <- treeViewColumnNew + treeViewColumnSetTitle tMid "on machine" + treeViewAppendColumn infoT tMid + rendererTMid <- cellRendererTextNew + cellLayoutPackStart tMid rendererTMid True + + tPid <- treeViewColumnNew + treeViewColumnSetTitle tPid "in process" + treeViewAppendColumn infoT tPid + rendererTPid <- cellRendererTextNew + cellLayoutPackStart tPid rendererTPid True + + tId <- treeViewColumnNew + treeViewColumnSetTitle tId "thread id" + treeViewAppendColumn infoT tId + rendererTId <- cellRendererTextNew + cellLayoutPackStart tId rendererTId True + + tTime <- treeViewColumnNew + treeViewColumnSetTitle tTime "runtime (s)" + treeViewAppendColumn infoT tTime + rendererTTime <- cellRendererTextNew + cellLayoutPackStart tTime rendererTTime True + + dataT <- listStoreNew [] + + cellLayoutSetAttributes tMid rendererTMid dataT $ \row -> [ cellText := machIdT row ] + cellLayoutSetAttributes tPid rendererTPid dataT $ \row -> [ cellText := procIdT row ] + cellLayoutSetAttributes tId rendererTId dataT $ \row -> [ cellText := thrdId row ] + cellLayoutSetAttributes tTime rendererTTime dataT $ \row -> [ cellText := runtimeT row ] + + inspectThread ts dataT + + + treeViewSetModel infoT dataT + treeViewColumnsAutosize infoT + + where inspectMachine ((i,_,_,(p,s,r),evts):ms) store = do + listStorePrepend store (MachineInfo {machId=("Machine " ++ show i), + runtime=(formatFloat (getEventTime (head evts) - (getStartTime i mt))), + numProcesses=(show p), + numSent=(show s), + numRcvd=(show r)}) + + inspectMachine ms store + inspectMachine _ _ = return () + inspectProcess (((m,i),_,_,stat,evts):ps) store = do + -- because of the processIDs being reused, there may be more then one + -- StartProcess-/KillProcess-Events in evts. One fkt. to find them all: + filterProcesses evts stat (getEventTime (head evts)) 0 "" + where filterProcesses :: [ProcessEvent] -> (Int,Int,Int) -> Seconds -> Int -> String -> IO () + filterProcesses (e:es) st@(t,s,r) killTime n l = case e of + KillProcess time (t',s',r') -> filterProcesses es (t',s',r') time (n+1) l + LabelProcess _ label -> filterProcesses es st killTime n label + NewProcess time -> do + + listStoreAppend store (ProcessInfo {machIdP=(show m), + procId=("Process " ++ show i ++ "/" ++ show n), + runtimeP=(formatFloat (killTime - time)), + numThreads= (show t), + numSentP= (show s), + numRcvdP= (show r)}) + filterProcesses es st killTime n l + _ -> filterProcesses es st killTime n l + filterProcesses _ _ _ _ _ = inspectProcess ps store + inspectProcess _ _ = return () + + inspectThread ((((m,p),i),evts):ts) store = do + + listStorePrepend store (ThreadInfo{ machIdT=(show m), + procIdT=(show p), + thrdId=("Thread " ++ show i), + runtimeT=(formatFloat (getEventTime (head evts) - (getEventTime (last evts))))}) + + inspectThread ts store + inspectThread _ _ = return () + + commaToNewline c + | c == ',' = '\n' + | otherwise = c + + + + +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 + then do win <- widgetGetDrawWindow pic + let oldpixbuf = oldView state :: Maybe Pixbuf + gc <- G.gcNew win + --redraw old portion of screen + case oldpixbuf of + Just pb -> drawPixbuf win gc pb 0 0 0 0 (-1) (-1) RgbDitherNormal 0 0 + Nothing -> return () + --drawWindowProcessUpdates win False + renderWithDrawable win $ do + --colorWhite + --rectangle (fromIntegral vx) lry (50) (uly-lry) + --fill + colorRedA + moveTo ((fromIntegral vx)+20) (my) + lineTo ((fromIntegral vx)+30) (my) + stroke + + else return () + +performDragnDrop v st pic _ mx my = do + state <- takeMVar st + ((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic + let matrix = case v of + 2 -> matrixT state + 1 -> matrixP state + _ -> matrixM state + ySkip = (lry - uly) / (fromIntegral (length matrix)) + index = fromIntegral (floor (1 + ((my - uly) / ySkip))) + oldIndex = head $ sort $ selRow state + if null (selRow state) + then putMVar st state + else do + if index == oldIndex + then do + if deleteSel state + then do + (w,h) <- widgetGetSize pic + win <- widgetGetDrawWindow pic + let pLines = selRow state + skip' = round ySkip + putMVar st (state { selRow = [], deleteSel = False, noDND = False }) + let pRects = map (\pLine -> Rectangle 0 (floor ((pLine-1)*ySkip + uly)-1) w (skip'+2)) pLines + sequence_ (map (\r -> drawWindowInvalidateRect win r False) pRects) + else putMVar st (state { deleteSel = False, noDND = False }) + else if noDND state + then putMVar st (state { deleteSel = False, noDND = False }) + else do + case v of + 3 -> do + let arr = matrixGP state + ns = selRow state + (m,a) = handleMove (floor index) ns arr + putMVar st (state {selRow = m, matrixGP = a, deleteSel = False}) + 2 -> do + let arr = matrixT state + 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 + (m,a) = handleMove (floor index) ns arr + putMVar st (state {selRow = m, matrixP = a, deleteSel = False}) + _ -> do + let arr = matrixM state + ns = selRow state + (m,a) = handleMove (floor index) ns arr + putMVar st (state {selRow = m, matrixM = a, deleteSel = False}) + return () + +handleMouseMove :: MVar ViewerState -> MVar EdenTvState -> Bool -> DrawingArea -> Events -> Double -> Double -> IO () +handleMouseMove st edentvState hideStartupPhase pic (_,_,(maxStartupTimeInSeconds, _),_,(minT,maxT,maxST,_,_),_) mx my = do + ((vx,vy,vw,vh),(ulx,uly,lrx,lry)) <- getCorners pic + widgetQueueDrawArea pic (floor mx - 100) vy 200 vh + if mx > (fromIntegral vx + ulx) && my > uly && my < lry + 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 = maxStartupTimeInSeconds + | otherwise = minT + + let time + | useDiff = posToTime minT' (maxT+maxST) ulx lrx mx + | otherwise = posToTime minT' maxT ulx lrx mx + text = formatFloat time + + win <- widgetGetDrawWindow pic + drawWindowProcessUpdates win False + renderWithDrawable win $ do + ext <- textExtents text + let dx = (\ (TextExtents _ _ w _ _ _) -> w) ext + lb = fromIntegral vx + ulx + 5 + rb = fromIntegral (vx + vw) - (border + 2) - dx + x0 = mx - (dx/2) -- centered at mouse position + x1 = max x0 lb -- not over left border + xm = min x1 rb -- not over right border + getColor markerLine colorsMap + moveTo mx (fromIntegral vy + uly) + lineTo mx (fromIntegral (vy + vh - 5)) + stroke + moveTo xm (fromIntegral vy + 15) + getColor markerLabel colorsMap + showText text + else return () + +removeElem :: (Eq a) => a -> [a] -> [a] +removeElem o (x:xs) + | o == x = xs + | otherwise = x : removeElem o xs +removeElem _ [] = [] + +handleButtonPress :: DrawingArea -> Int -> MVar ViewerState -> Event -> Events -> IO Bool +handleButtonPress pic v st e ((m,p,t),mt,(mxs,mxst),_,(minT,maxT,maxST,_,maxD),_) = do + (_,(ulx,uly,lrx,lry)) <- getCorners pic + oldState <- readMVar st + + let matrix = case v of + 3 -> matrixGP oldState + 2 -> matrixT oldState + 1 -> matrixP oldState + _ -> matrixM oldState + ySkip = (lry - uly) / (fromIntegral (length matrix)) + (mx,my) = (eventX e, eventY e) + line = if v /= 3 + then fromIntegral (floor (1 + ((my - uly) / ySkip))) + else let y = my - uly + in findRow 0 y machineOffsets + where findRow i y ((numP,numSkip):xs) + | y < (numP*procSkip + numSkip*10) = i + | otherwise = findRow (i+1) y xs + findRow i _ [] = i + + numProcs :: [(MachineID, Int)] + numProcs = map (\(mId,_,_,(numP,_,_),_) -> (mId, numP)) m + + numM = fromIntegral $ length m + 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 + where posAcc i pos (s:ss) + | pos == s = i + | otherwise = posAcc (i+1) pos ss + posAcc _ _ [] = 0 + + machineOffsets = 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 + buildOffsets _ [] = [] + + line' = elemIndex line matrix -- get position of selLine in matrix + elemIndex :: Eq a => a -> [a] -> Int + elemIndex = ei 0 -- start search at index 0 + where ei :: Eq a => Int -> a -> [a] -> Int + ei i e (c:cs) + | e == c = i -- elem found at index i + | otherwise = ei (i+1) e cs -- not found yet + ei _ _ [] = -1 -- elem not found + + --putStrLn $ "sort: " ++ (show (matrixGP oldState)) + --putStrLn $ "sortedMachines: " ++ (show sortedMachines) + --putStrLn $ "machineOffsets: " ++ (show machineOffsets) + --putStrLn $ "line: " ++ (show line) + + case eventButton e of + LeftButton -> if mx > ulx && my > uly && mx < lrx && my < lry + then do + state <- takeMVar st + (w,h) <- widgetGetSize pic + win <- widgetGetDrawWindow pic + let pLines = selRow oldState + skip' = round ySkip + --pRects = map (\pLine -> (pLine, Rectangle 0 (floor ((pLine-1)*ySkip + uly)-1) w (skip'+2))) pLines + --rect0 = Rectangle 0 (floor ((pLine-1)*ySkip + uly)-1) w (skip'+2) + rect1 = Rectangle 0 (floor ((line-1)*ySkip + uly)-1) w (skip'+2) + if line `elem` pLines + then do if Shift `elem` (Graphics.UI.Gtk.Gdk.Events.eventModifier e) + then putMVar st (state { selRow = removeElem line pLines, noDND = True }) + else do + putMVar st (state { deleteSel = True }) + --putMVar st (state { selRow = [] }) + --let pRects = map (\pLine -> Rectangle 0 (floor ((pLine-1)*ySkip + uly)-1) w (skip'+2)) pLines + --sequence_ (map (\r -> drawWindowInvalidateRect win r False) pRects) + drawWindowInvalidateRect win rect1 False + else do if Shift `elem` (Graphics.UI.Gtk.Gdk.Events.eventModifier e) + then putMVar st (state { selRow = (line:pLines), noDND = True }) + else do + putMVar st (state { selRow = [line] }) + let pRects = map (\pLine -> Rectangle 0 (floor ((pLine-1)*ySkip + uly)-1) w (skip'+2)) pLines + sequence_ (map (\r -> drawWindowInvalidateRect win r False) pRects) + --drawWindowInvalidateRect win rect0 False + drawWindowInvalidateRect win rect1 False + return True + else return True + MiddleButton -> return True + RightButton -> if mx > ulx && my > uly && my < lry + then do + let tData = (\ (_,evts) -> evts) (t!!line') + pData = (\ (_,_,_,_,evts) -> evts) (p!!line') + mData = (\ (_,_,_,_,evts) -> evts) (m!!line') + (selMachine,selName) = case v of + 2 -> case t!!line' of (((m,p),t),_) -> (m,'T': show m ++ ':': show p ++ ':': show t) + 1 -> case p!!line' of ((m,p),_,_,_,_) -> (m,'P': show m ++ ':': show p) + 0 -> case m!!line' of (m,_,_,_,_) -> (m,'M': show m) + diffTime = (getStartTime selMachine mxst) + scaledTime :: Double -> String + scaledTime t = if locTime oldState + then formatFloat (t + diffTime) + else formatFloat (t - minT) + 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 + 2 -> case take 1 (dropWhile (\e -> getEventTime e > selTime) tData) of + [NewThread s o] -> "New thread " ++ selName ++ + "\nTime: " ++ (scaledTime s) ++ + "\noutport: " ++ show o + [KillThread s] -> "Kill thread " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [RunThread s] -> "Run thread " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [SuspendThread s] -> "Suspend thread " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [BlockThread s i r] -> "Block thread " ++ selName ++ + "\nTime: " ++ (scaledTime s) ++ + "\nInport: " ++ show i ++ + "\nReason: " ++ show r + [GCThread s g a c l]-> "Garbage collection " ++ selName ++ + "\nTime: " ++ (scaledTime s) ++ + "\nGeneration: " ++ show g ++ + "\nAllocated: " ++ show a ++ + "\nCollected: " ++ show c ++ + "\nLive data: " ++ show l + _ -> "No event to show" + 1 -> case take 1 (dropWhile (\e -> getEventTime e > selTime) pData) of + [NewProcess s] -> "New process " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [KillProcess s _] -> "Kill process " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [IdleProcess s] -> "Idle process " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [RunningProcess s] -> "Running process " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [SuspendedProcess s] -> "Suspended process " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [BlockedProcess s] -> "Blocked process " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [GCProcess s g a c l]-> "Garbage collection " ++ selName ++ + "\nTime: " ++ (scaledTime s) ++ + "\nGeneration: " ++ show g ++ + "\nAllocated: " ++ show a ++ + "\nCollected: " ++ show c ++ + "\nLive data: " ++ show l + _ -> "No event to show" + 0 -> case take 1 (dropWhile (\e -> getEventTime e > selTime) mData) of + [StartMachine s] -> "Start machine " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [EndMachine s] -> "End machine " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [GCMachine s g a c l]-> "Garbage collection " ++ selName ++ + "\nTime: " ++ (scaledTime s) ++ + "\nGeneration: " ++ show g ++ + "\nAllocated: " ++ show a ++ + "\nCollected: " ++ show c ++ + "\nLive data: " ++ show l + [IdleMachine s] -> "Idle machine " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [RunningMachine s] -> "Running machine " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [SuspendedMachine s] -> "Suspended machine " ++ selName ++ + "\nTime: " ++ (scaledTime s) + [BlockedMachine s] -> "Blocked machine " ++ selName ++ + "\nTime: " ++ (scaledTime s) + _ -> "No event to show" + infoDlg <- dialogNew + windowSetTitle infoDlg "Event-info" + windowSetPosition infoDlg WinPosCenterOnParent + dialogAddButton infoDlg stockOk ResponseOk + upper <- dialogGetUpper infoDlg + infoText <- labelNew (Just labelText) + boxPackStartDefaults upper infoText + widgetShowAll infoDlg + dialogRun infoDlg + widgetDestroy infoDlg + return True + else return True + + +handleMove :: Int -> [Double] -> [Double] -> ([Double],[Double]) +handleMove index moveRows allRows = result + where orderedMoveRows = map (\row -> 1 + (position (floor row) allRows) ) $ sort moveRows + len = length allRows + lenMoved = length moveRows + lenOther = length orderedOtherRows + orderedOtherRows = sortBy sortOther $ filterOther 1 allRows + + sortOther :: Double -> Double -> Ordering + sortOther a b + | (allRows!!((floor a)-1)) < (allRows!!((floor b)-1)) = LT + | otherwise = GT + + moveUp = head moveRows > (fromIntegral index) + + placesBefore = if (index `mod` len) == 0 + then 0 + else (index - 1) `mod` len + placesAfter = if (index `mod` len) == 0 + 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 + + position i (x:xs) + | (fromIntegral i) == x = 0 + | otherwise = 1 + (position i xs) + position _ [] = 0 + + selection = map (fromIntegral . pos) [index..(index+lenMoved-1)] + + result = (selection, process 1 allRows) + +handleMoveUp :: DrawingArea -> Int -> MVar ViewerState -> IO () +handleMoveUp pic i st = do + state <- takeMVar st + ((x,_,w,_),(ulx,uly,lrx,lry)) <- getCorners pic + let ns = selRow state + if not $ null ns + then let n = head ns in case i of + 3 -> do let arr = matrixGP state + rows = fromIntegral (length (arr)) + ySkip = (lry - uly) / rows + sortedRows = sort ns + ind = (floor (head sortedRows))-1 + (m,a) = handleMove ind ns arr + putMVar st (state {selRow = m, matrixGP = a}) + widgetQueueDraw pic + 2 -> do let arr = matrixT state + rows = fromIntegral (length (arr)) + ySkip = (lry - uly) / rows + sortedRows = sort ns + ind = (floor (head sortedRows))-1 + (m,a) = handleMove ind ns arr + putMVar st (state {selRow = m, matrixT = a}) + widgetQueueDraw pic + 1 -> do let arr = matrixP state + rows = fromIntegral (length (arr)) + ySkip = (lry - uly) / rows + sortedRows = sort ns + ind = (floor (head sortedRows))-1 + (m,a) = handleMove ind ns arr + putMVar st (state {selRow = m, matrixP = a}) + widgetQueueDraw pic + _ -> do let arr = matrixM state + rows = fromIntegral (length (arr)) + ySkip = (lry - uly) / rows + sortedRows = sort ns + ind = (floor (head sortedRows))-1 + (m,a) = handleMove ind ns arr + putMVar st (state {selRow = m, matrixM = a}) + widgetQueueDraw pic + else putMVar st state + +shiftDown,shiftUp :: (Eq a, Num a) => a -> [a] -> [a] +shiftDown max (x:xs) + | x == max = 1 : shiftDown max xs + | otherwise = x + 1 : shiftDown max xs +shiftDown _ _ = [] +shiftUp max (x:xs) + | x == 1 = max : shiftUp max xs + | otherwise = x - 1 : shiftUp max xs +shiftUp _ _ = [] + +handleMoveDown :: DrawingArea -> Int -> MVar ViewerState -> IO () +handleMoveDown pic i st = do + state <- takeMVar st + (w,h) <- widgetGetSize pic + ((x,_,w,_),(ulx,uly,lrx,lry)) <- getCorners pic + let ns = selRow state -- TODO hack + if not $ null ns + then case i of + 3 -> do let arr = (matrixGP state) + rows = fromIntegral (length arr) + ySkip = (lry - uly) / rows + sortedRows = sort ns + ind = (floor (head sortedRows))+1 + (m,a) = handleMove ind ns arr + putMVar st (state {selRow = m, matrixGP = a}) + widgetQueueDraw pic + 2 -> do let arr = (matrixT state) + rows = fromIntegral (length arr) + ySkip = (lry - uly) / rows + sortedRows = sort ns + ind = (floor (head sortedRows))+1 + (m,a) = handleMove ind ns arr + putMVar st (state {selRow = m, matrixT = a}) + widgetQueueDraw pic + 1 -> do let arr = (matrixP state) + rows = fromIntegral (length arr) + ySkip = (lry - uly) / rows + sortedRows = sort ns + ind = (floor (head sortedRows))+1 + (m,a) = handleMove ind ns arr + putMVar st (state {selRow = m, matrixP = a}) + widgetQueueDraw pic + _ -> do let arr = (matrixM state) + rows = fromIntegral (length arr) + ySkip = (lry - uly) / rows + sortedRows = sort ns + ind = (floor (head sortedRows))+1 + (m,a) = handleMove ind ns arr + putMVar st (state {selRow = m, matrixM = a}) + widgetQueueDraw pic + else putMVar st state diff --git a/EdenTvType.hs b/EdenTvType.hs new file mode 100644 --- /dev/null +++ b/EdenTvType.hs @@ -0,0 +1,388 @@ +{- The Eden Trace Viewer (or simply EdenTV) is a tool that can generate diagrams to visualize the behaviour of Eden programs. + Copyright (C) 2005-2012 Phillips Universitaet Marburg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +-} + +{-# LANGUAGE CPP #-} +-- JB: adapted instances (see end of file) +module EdenTvType where + +import Data.Tree +import Data.Word +import qualified Data.Map as M +import qualified Data.Sequence as S +--import DeepSeq +import Graphics.UI.Gtk.Gdk.Pixbuf +import Graphics.UI.Gtk.Gdk.GC + + + +-- A State to carry around: +-- What has to be drawn and how? +data ViewerState = VS + { selRow :: [Double] -- currently selected row, [] if none + , selView :: Int -- machine- (0), process- (1) or threadView (2) + , locTime :: Bool -- all machines starting simultaneously + , showMsg :: Bool -- draw messages? + , matrixM :: [Double] -- \ :-) + , matrixP :: [Double] -- these lists control sorting in diffrent views + , matrixT :: [Double] -- / + , matrixGP :: [Double] + , ommitRedraw :: Bool + + , clicked :: Bool + , deleteSel :: Bool + , noDND :: Bool + , oldView :: Maybe Pixbuf + + , confMachines :: [(MachineID, (Bool,Bool))] -- show in/out Messages Machines + , confProcesses :: [(ProcessID, (Bool,Bool))] -- show in/out Messages Procs + + , autoTicks :: Bool + , tickSkip :: Seconds + , tickMark :: Int + + , filename :: String -- the trace file the data was read from + , ignoreMessages :: Bool -- indicates if the trace file was parsed without messages + } deriving Show + +instance Show Pixbuf where + show x = "pixbuf" + +data EdenTvState = ES + { lastPath :: String + , colors :: Colors + } deriving Show + +data ColorRGBA = RGBA + { rgbColor :: Color + , alpha :: Word16 + } deriving Show + +data Colors = Colors + { statusRunning :: ColorRGBA + , statusSuspended :: ColorRGBA + , statusBlocked :: ColorRGBA + , statusIdle :: ColorRGBA + + , messagesSystem :: ColorRGBA + , messagesHead :: ColorRGBA + , messagesData :: ColorRGBA + , messagesHeadLocal :: ColorRGBA + , messagesDataLocal :: ColorRGBA + , messagesBlock :: ColorRGBA + , messagesReceive :: ColorRGBA + + , markerLine :: ColorRGBA + , markerLabel :: ColorRGBA + , markerStartup :: ColorRGBA + + , chartBackground :: ColorRGBA + , chartAxes :: ColorRGBA + , chartAxesLabel :: ColorRGBA + } deriving Show + +rgba :: Word16 -> Word16 -> Word16 -> Word16 -> ColorRGBA +rgba r g b a = RGBA {rgbColor = (Color r g b), alpha = a} + +rgb :: Word16 -> Word16 -> Word16 -> ColorRGBA +rgb r g b = rgba r g b 65535 + +type Seconds = Double +type InportID = Int +type OutportID = Int +class EdenEvent e where + getEventTime :: e -> Seconds + setEventTime :: e -> Seconds -> e + +-- A machine consists of an id and a list of related events +type MachineID = Int +type Machine = (MachineID,Int,Int,(Int,Int,Int),[MachineEvent]) +-- (mID, allP,blkP,(#Proc,#sent,#rcv),events) +data MachineEvent + = StartMachine !Seconds -- Event 137 + | EndMachine !Seconds -- Event 145 + | GCMachine !Seconds !Int !Int !Int !Int -- Event 849 (Garbage Collection) + | IdleMachine !Seconds -- virtual event (no processes available) + | RunningMachine !Seconds -- virtual event (process running) + | SuspendedMachine !Seconds -- virtual event (no process running but runnable waiting) + | BlockedMachine !Seconds -- virtual event (all processes blocked) + | MNewProcess !Seconds -- other virtual events triggert by ProcessEvents + | MKillRProcess !Seconds + | MKillSProcess !Seconds + | MKillBProcess !Seconds + | MRunProcess !Seconds + | MSuspendProcess !Seconds + | MBlockProcess !Seconds + | MIdleProcess !Seconds + deriving (Show,Eq) +instance EdenEvent MachineEvent where + getEventTime (StartMachine s) = s + getEventTime (EndMachine s) = s + getEventTime (GCMachine s _ _ _ _) = s + getEventTime (IdleMachine s) = s + getEventTime (RunningMachine s) = s + getEventTime (SuspendedMachine s) = s + getEventTime (BlockedMachine s) = s + getEventTime (MNewProcess s) = s + getEventTime (MKillBProcess s) = s + getEventTime (MRunProcess s) = s + getEventTime (MSuspendProcess s) = s + getEventTime (MBlockProcess s) = s + getEventTime (MIdleProcess s) = s + getEventTime (MKillSProcess s) = s + getEventTime (MKillRProcess s) = s + --getEventTime e = error (show e) + + setEventTime (StartMachine _) s = StartMachine s + setEventTime (EndMachine _) s = EndMachine s + setEventTime (GCMachine _ g a c l) s = GCMachine s g a c l + setEventTime (IdleMachine _) s = IdleMachine s + setEventTime (RunningMachine _) s = RunningMachine s + setEventTime (SuspendedMachine _) s = SuspendedMachine s + setEventTime (BlockedMachine _) s = BlockedMachine s + setEventTime (MNewProcess _) s = MNewProcess s + setEventTime (MKillBProcess _) s = MKillBProcess s + setEventTime (MRunProcess _) s = MRunProcess s + setEventTime (MSuspendProcess _) s = MSuspendProcess s + setEventTime (MBlockProcess _) s = MBlockProcess s + setEventTime (MIdleProcess _) s = MIdleProcess s +{-instance DeepSeq MachineEvent where + deepSeq (StartMachine sec) y = deepSeq sec y + deepSeq (EndMachine sec) y = deepSeq sec y +-} + +-- A process is identified by its own id and the machine's id +-- it is running on, completed with it's events +type ProcessID = (MachineID,Int) -- (MachineID,ProcessID) +type Process = (ProcessID,Int,Int,(Int,Int,Int),[ProcessEvent]) +-- (pID,allT,blockedT,(#Threads,#sent,#rec),events) +data ProcessEvent + = NewProcess !Seconds -- Event 153 + | LabelProcess !Seconds String + | KillProcess !Seconds (Int,Int,Int) -- Event 161 + | GCProcess !Seconds !Int !Int !Int !Int + | IdleProcess !Seconds -- virtual event (no threads available) + | RunningProcess !Seconds -- virtual event (thread running) + | SuspendedProcess !Seconds -- virtual event (no thread running but runnable waiting) + | BlockedProcess !Seconds -- virtual event (all threads blocked) + | PNewThread !Seconds + | PKillRThread !Seconds + | PKillSThread !Seconds + | PKillBThread !Seconds + | PRunThread !Seconds + | PSuspendThread !Seconds + | PBlockThread !Seconds + | PDeblockThread !Seconds + deriving (Show,Eq) +instance EdenEvent ProcessEvent where + getEventTime (NewProcess s) = s + getEventTime (LabelProcess s _) = s + getEventTime (KillProcess s _) = s + getEventTime (GCProcess s _ _ _ _) = s + getEventTime (IdleProcess s) = s + getEventTime (RunningProcess s) = s + getEventTime (SuspendedProcess s) = s + getEventTime (BlockedProcess s) = s + getEventTime (PNewThread s) = s + getEventTime (PKillRThread s) = s + getEventTime (PKillSThread s) = s + getEventTime (PKillBThread s) = s + getEventTime (PRunThread s) = s + getEventTime (PSuspendThread s) = s + getEventTime (PBlockThread s) = s + getEventTime (PDeblockThread s) = s + + setEventTime (NewProcess _) s = NewProcess s + setEventTime (LabelProcess _ l) s = LabelProcess s l + setEventTime (KillProcess _ i) s = KillProcess s i + setEventTime (GCProcess _ g a c l) s = GCProcess s g a c l + setEventTime (IdleProcess _) s = IdleProcess s + setEventTime (RunningProcess _) s = RunningProcess s + setEventTime (SuspendedProcess _) s = SuspendedProcess s + setEventTime (BlockedProcess _) s = BlockedProcess s + setEventTime (PNewThread _) s = PNewThread s + setEventTime (PKillRThread _) s = PKillRThread s + setEventTime (PKillSThread _) s = PKillSThread s + setEventTime (PKillBThread _) s = PKillBThread s + setEventTime (PRunThread _) s = PRunThread s + setEventTime (PSuspendThread _) s = PSuspendThread s + setEventTime (PBlockThread _) s = PBlockThread s + setEventTime (PDeblockThread _) s = PDeblockThread s + +-- Threads also have events and an identifier. +type ThreadID = (ProcessID,Int) -- (MachineID,ProcessID,ThreadID) +type Thread = (ThreadID,[ThreadEvent]) +type OpenThread = (MachineID,(ThreadID,ThreadEvent),[Thread]) +data ThreadEvent + = NewThread !Seconds !OutportID -- Event 169 + | KillThread !Seconds -- Event 177 + | GCThread !Seconds !Int !Int !Int !Int + | RunThread !Seconds -- Event 185 + | SuspendThread !Seconds -- Event 193 + | BlockThread !Seconds !InportID !Reason -- Event 201 + | DeblockThread !Seconds -- Event 209 + | DummyThread + deriving (Show,Eq) +instance EdenEvent ThreadEvent where + getEventTime (NewThread s _) = s + getEventTime (KillThread s) = s + getEventTime (GCThread s _ _ _ _) = s + getEventTime (RunThread s) = s + getEventTime (SuspendThread s) = s + getEventTime (BlockThread s _ _) = s + getEventTime (DeblockThread s) = s + + setEventTime (NewThread _ o) s = NewThread s o + setEventTime (KillThread _) s = KillThread s + setEventTime (GCThread _ g a c l) s = GCThread s g a c l + setEventTime (RunThread _) s = RunThread s + setEventTime (SuspendThread _) s = SuspendThread s + setEventTime (BlockThread _ i r) s = BlockThread s i r + setEventTime (DeblockThread _) s = DeblockThread s + +{-instance DeepSeq ThreadEvent where + deepSeq (NewThread sec outPort) y = deepSeq sec $ deepSeq outPort y + deepSeq (KillThread sec) y = deepSeq sec y + deepSeq (RunThread sec) y = deepSeq sec y + deepSeq (SuspendThread sec) y = deepSeq sec y + deepSeq (BlockThread sec inPort tag) y = deepSeq sec $ deepSeq inPort $ deepSeq tag y + deepSeq (DeblockThread sec) y = deepSeq sec y +-} + +-- Messages: +data ReasonType = + RFork | -- legacy code: 85 + Connect | -- legacy code: 86 + DataMes | -- legacy code: 87 + Head | -- legacy code: 88 + Constr | -- legacy code: 89 + Part | -- legacy code: 90 + Terminate | -- legacy code: 91 + Default | -- legacy code: -1 + BlockReason | -- legacy code: 1 + LocalHead | -- new: optimized message on local machine + LocalDataMes -- new: optimized message on local machine + deriving (Show, Eq, Ord) + +type Reason = ReasonType +type Size = Int + +-- Map of open messages per process. +-- +-- Key: sender process id +-- Value: all message events (send and receive) that were +-- triggered for messages sent by this process +-- +type OpenMessagesPerProcess = M.Map ProcessID OpenMessages + +-- Map of open messages for a process. The key used in this map (`OpenMessageKey`) +-- is not unique for a message event. It groups messages sent to the same process +-- through the same channel (inport/outport) and with the same type and reason. +-- These messages with the same key are organized in a sequence/queue, so that +-- the message events can be matched in the right order. +-- +type OpenMessages = M.Map OpenMessageKey (S.Seq SmallOpenMessageEvent) + +type OpenMessageKey = (OpenMessageType, ProcessID, OutportID, InportID, Reason) +data OpenMessageType = TORM | TOSM deriving (Show, Eq, Ord) + +-- This type is used to store an open message as value in `OpenMessages`. +-- All other information of the message is already contained in the map key. +-- +data SmallOpenMessageEvent + = SmallORM !Seconds !Size + | SmallOSM !Seconds + deriving (Show,Eq) + +-- Data type for open message events for messages sent from a process. +-- The process id for both ORM and OSM is always the the receiver process id. +data OpenMessageEvent + = ORM !Seconds !ProcessID !OutportID !InportID !Reason !Size + | OSM !Seconds !ProcessID !OutportID !InportID !Reason + deriving (Show,Eq) + + +{-instance DeepSeq OpenMessageEvent where + deepSeq (ORM sec proc ports info) y = deepSeq sec $ deepSeq proc $ deepSeq ports $ deepSeq info y + deepSeq (OSM sec proc ports info) y = deepSeq sec $ deepSeq proc $ deepSeq ports $ deepSeq info y +-} + +-- Message: Complete message with send- and receive information +type ChannelID = (ProcessID,OutportID,ProcessID,InportID) +data Message = MSG !ChannelID !Seconds !Seconds !Reason !Size +-- channel stime rtime tag size + deriving (Show,Eq) +{-instance DeepSeq Message where + deepSeq (MSG times procs ports info) y = deepSeq times $ deepSeq procs $ deepSeq ports $ deepSeq info y +-} + +-- the time it took to receive a message +type ReceiveLength = ((MachineID, [(Int,Seconds)]), Seconds, Seconds) + +-- HeadMessage: Messages of type 100 +type Count = Int +type DSize = Double +type OpenHeadMessage = (ChannelID,Size,Count,[Seconds],[Seconds]) +-- channel, sum of sizes, quantity, sending/receiving times +type HeadMessage = (ChannelID,(Seconds,Seconds,Seconds,Seconds),DSize,Count) +-- channel stimeA,rtimeA stimeO,rtimeO size num +type OpenProcMessage = (MachineID,[(ProcessID,OpenMessageEvent)],[(ProcessID,OpenMessageEvent)],[ProcessID]) +-- rcvMach sent Messages rcvd Messages NewProcess +type OpenMessageList = (OpenMessagesPerProcess,[Message],([OpenProcMessage],ProcessList,ProcessTree),([OpenHeadMessage],Double,[HeadMessage])) + +type MessageList = ( + [Message], -- + [Message], -- additional messages: messages sent in a stream (bulk messages) + [HeadMessage], -- msgs from + ProcessTree, + [ReceiveLength] -- time to receive the messages + ) + +type ProcessList = [(ProcessID,[ProcessID])] +type ProcessTree = (Tree ProcessID) -- Node ProcessID [ProcessTree]) + +-- (Trace-)Events: +type EventID = Int +type NewEvent = ((EventID,Seconds,[Int]),Maybe String) +-- datatype used within the calculation +type OpenEvents = ( + ([Machine], [Process], [OpenThread]), -- list of machines/processes/threads + [(MachineID,Double)], -- machine starttimes + OpenMessageList, -- o/c Msgs + (Seconds,Seconds,Int,Int)) -- min_t max_t #P maxLD + +-- The main datatype for the generated list of information +type Events = ( + ([Machine], [Process], [Thread]), -- list of machines/processes/threads + [(MachineID, Double)], -- start-times per machine + (Seconds, [(MachineID, Seconds)]), -- maxStartup msgs/heads + MessageList, + ( Seconds, -- min_t + Seconds, -- max_t + Seconds, -- max_t_diff + Double, -- maxMsgSize + Double), -- MaxLD + (Int, Int, Int) -- number of machines/processes/threads + ) + +#if __GLASGOW_HASKELL__ < 606 +#warning __GLASGOW_HASKELL__ +instance (Show a,Show b,Show c,Show d,Show e,Show f) => Show (a,b,c,d,e,f) +instance (Show a,Show b,Show c,Show d,Show e,Show f,Show g) => Show (a,b,c,d,e,f,g) +instance (Show a,Show b,Show c,Show d,Show e,Show f,Show g,Show h) => Show (a,b,c,d,e,f,g,h) +instance (Show a,Show b,Show c,Show d,Show e,Show f,Show g,Show h,Show i) => Show (a,b,c,d,e,f,g,h,i) +instance (Show a,Show b,Show c,Show d,Show e,Show f,Show g,Show h,Show i,Show j) => Show (a,b,c,d,e,f,g,h,i,j) +#endif diff --git a/EdenTvViewer.hs b/EdenTvViewer.hs new file mode 100644 --- /dev/null +++ b/EdenTvViewer.hs @@ -0,0 +1,974 @@ +{- The Eden Trace Viewer (or simply EdenTV) is a tool that can generate diagrams to visualize the behaviour of Eden programs. + Copyright (C) 2005-2010 Phillips Universitaet Marburg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +-} + +module EdenTvViewer where + +import EdenTvType +import EdenTvBasic +import EdenTvInteract +import Graphics.UI.Gtk hiding (get) +import Graphics.UI.Gtk.Gdk.Pixbuf +import Graphics.UI.Gtk.Glade +import Graphics.Rendering.Cairo +import Control.Monad.State +import Control.Concurrent.MVar +import Numeric +--import DeepSeq + +import Debug.Trace + +-- short terms: +type DrawColor = (Render (), Render (), Render (), Render ()) + -- idle running suspended blocked +type ColorButtons = (ColorButton,ColorButton,ColorButton,ColorButton) + +-- at first the matrices are sorted and nothing is selected +initMatrix :: Int -> Int -> Int -> [MachineID] -> [ProcessID] -> String -> Bool -> ViewerState +initMatrix m p t lm lp filename ignoreMessages = VS { + selRow = [], + selView = 0, -- machines are the default view + locTime = False, -- local Time off + showMsg = False, -- messages off + matrixM = [1..(fromIntegral m)], + matrixP = [1..(fromIntegral p)], + matrixT = [1..(fromIntegral t)], + matrixGP = [1..(fromIntegral m)], + + ommitRedraw = False, + clicked = False, + deleteSel = False, + noDND = False, + oldView = Nothing, + + confMachines = [ (mId, (True,True)) | mId <- reverse lm], + confProcesses = [ (pId, (True,True)) | pId <- reverse lp], + autoTicks = True, + tickSkip = 0, + tickMark = 1, + + filename = filename, + ignoreMessages = ignoreMessages} + +-- draw a piece of text right-justified +showTextR :: String -> Render () +showTextR str = do + info <- textExtents str + let width = (\ (TextExtents _ _ w _ _ _) -> w) info + relMoveTo (-width) 0 + showText str + +drawAnyPic :: Bool -> Bool -> Bool -> Bool -> Bool -> Double -> Double -> (Render () -> IO ()) -> (Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ())) -> DrawingArea -> + Events -> MVar ViewerState -> MVar EdenTvState -> Int -> IO () +drawAnyPic drawBlkMsg drawStartup hideStartupPhase drawDataMsgs drawSystemMsgs transX transY target drawfunc pic traces st edentvState rows = do + target $ do translate transX transY; save + + state <- readMVar st + globalState <- readMVar edentvState + let colorsMap = colors globalState + + -- if the startup-phase should not be displayed, the mininum startup + -- time is used as minTime + let traces'@(_, _, _, _, (minTime, maxTime, maxSTime, _, _), _) + = if hideStartupPhase + then setMinTimeToStartUpTime traces + else traces + + let ommit = ommitRedraw state + when (not ommit) $ do + prepareBackground transX transY target pic colorsMap + + -- Returns the time difference for a machine in relation to the + -- local startup time. Only used if startup synchronisation is + -- enabled + -- + let getDiffTime :: Int -> [(MachineID, Double)] -> Double -> Double + getDiffTime machineId startTimes minTime + | hideStartupPhase = -((getStartTime machineId startTimes)) + | otherwise = -((getStartTime machineId startTimes) + minTime) + + -- Returns the relative position in percent for a given point of time + -- in relation to the total duration. The value is used to calculate the + -- absolute position in pixels (which is done automatically by the drawing + -- area). + -- + let scaledTime :: Double -> Double + scaledTime time + | not $ locTime state = (time - minTime) / (maxTime - minTime) + | otherwise = (time - minTime) / ((maxTime+maxSTime) - minTime) + + -- draw machines/processes/threads + drawAxes <- drawfunc hideStartupPhase transX transY target traces' colorsMap pic state getDiffTime scaledTime + pixelsPerSecond <- getPixelsPerSecond pic state minTime maxTime maxSTime + + if selView state < 3 + then addSelection transX transY target (fromIntegral rows) pic state + else addSelectionGroupedProcesses transX transY target (fromIntegral rows) pic state [] traces' + + drawMessages drawBlkMsg drawDataMsgs drawSystemMsgs hideStartupPhase pixelsPerSecond transX transY target traces' pic state colorsMap + when (drawStartup && (not hideStartupPhase)) $ drawStartupMarker pixelsPerSecond transX transY target traces' pic state colorsMap + target showPage -- only for pdf export -- ortherwise useless + + -- finally draw axes on top of everything + target drawAxes + + +setMinTimeToStartUpTime :: Events -> Events +setMinTimeToStartUpTime (lists, mTimes, maxStartups@(maxStartupTimeInSeconds, _), msgs, (_,maxTime,maxSTime,maxSize,maxLD), counts) + = (lists, mTimes, maxStartups, msgs, (maxStartupTimeInSeconds,maxTime,maxSTime,maxSize,maxLD), counts) + +getPixelsPerSecond :: DrawingArea -> ViewerState -> Double -> Double -> Double -> IO Double +getPixelsPerSecond pic state minTime maxTime maxSTime = do + (_,(ulx,uly,lrx,lry)) <- getCorners pic + + let pixelsPerSecond + | locTime state = (lrx - ulx) / ((maxTime+maxSTime) - minTime) + | otherwise = (lrx - ulx) / (maxTime - minTime) + + return pixelsPerSecond + +drawMessages :: Bool -> Bool -> Bool -> Bool -> Double -> Double -> Double -> (Render () -> IO ()) -> Events -> DrawingArea -> ViewerState -> Colors -> IO () +drawMessages drawBlkMsg drawDataMsgs drawSystemMsgs hideStartupPhase pixelsPerSecond visX visY target ((ms,ps,_),mTimes,(mxs,mxst),(msgs,amsgs,hmsgs,_,rcvtimes),(minTime,maxTime,maxSTime,maxSize,maxLD),_) pic state colorsMap = do + if ((v < 2) || (v == 3)) && showMsg state + then do + win <- widgetGetDrawWindow pic + (_,(ulx,uly,lrx,lry)) <- getCorners pic + let ySkip :: Double + ySkip = case v of + 1 -> (lry - uly) / (fromIntegral (length (matrixP state))) + 0 -> (lry - uly) / (fromIntegral (length (matrixM state))) + 3 -> (lry - uly - ((numM-1)*10) )/ (fromIntegral (length (matrixP state))) + + -- do not draw trapezoid if each message of a message bulk is + -- drawn individually + when (drawDataMsgs && (not drawBlkMsg)) $ drawHeads win pixelsPerSecond ySkip ulx uly + + drawRcvLengths win pixelsPerSecond ySkip ulx uly + drawMsgs win pixelsPerSecond ySkip ulx uly + else return () + where v = selView state + useDiff = locTime state + sort = case v of + 1 -> 0:(reverse (matrixP state)) + 0 -> reverse (matrixM state) + 3 -> reverse (matrixGP state) + iv = 0 + + -- Returns the pixel position on the drawing area for a given + -- point of time. + -- + getPositionInPx :: Int -> Double -> [(MachineID, Double)] -> Double -> Double + getPositionInPx machineId time startTimes xScale + | useDiff && hideStartupPhase = (time + (getStartTime machineId startTimes) - minTime) * xScale + | useDiff = (time + (getStartTime machineId startTimes)) * xScale + | otherwise = (time - minTime) * xScale + + (rowPos,rowOff) = case v of + 1 -> ((iv:(rowPosP 0 iv (reverse ps))), [iv..]) + 0 -> ((iv:(rowPosM iv (reverse ms))), (repeat iv)) + where rowPosP :: Num a => MachineID -> a -> [Process] -> [a] + rowPosP _ _ [] = [] + rowPosP m' i (((m,p),_,_,_,_):pss) + | m == m' = rowPosP m (i+1) pss + | otherwise = i:(rowPosP m (i+1) pss) + rowPosM :: Num a => a -> [Machine] -> [a] + rowPosM _ [] = [] + rowPosM i (_:mss) = i:(rowPosM (i+1) mss) + + numProcs :: [(MachineID, Int)] + numProcs = map (\(mId,_,_,(numP,_,_),_) -> (mId, numP)) ms + + numM = fromIntegral $ length ms + + sortedMachines = [(numM+1) - (posToMachine pos (matrixGP state)) | pos <- [1..numM]] + + posToMachine :: Double -> [Double] -> Double + posToMachine pos sort = posAcc 1 pos sort + where posAcc i pos (s:ss) + | pos == s = i + | otherwise = posAcc (i+1) pos ss + posAcc _ _ [] = 0 + + machineOffsets = 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 + buildOffsets _ [] = [] + + + messageActive :: ProcessID -> ProcessID -> Bool + messageActive sender receiver = case v of + 3 -> let activeProcs = confProcesses state + Just (_,sout) = lookup sender activeProcs + Just (rin,_) = lookup receiver activeProcs + in sout && rin + 1 -> let activeProcs = confProcesses state + Just (_,sout) = lookup sender activeProcs + Just (rin,_) = lookup receiver activeProcs + in sout && rin + 0 -> let activeMachs = confMachines state + Just (_,sout) = lookup (fst sender) activeMachs + Just (rin,_) = lookup (fst receiver) activeMachs + in sout && rin + _ -> True + drawRcvLengths :: DrawWindow -> Double -> Double -> Double -> Double -> IO () + drawRcvLengths win xScale yScale ulx uly = + target $ do + translate visX visY + translate ulx (uly- 0.2*yScale) + getColor messagesReceive colorsMap + drawRcvLength rcvtimes + where + pidsOnMachine :: MachineID -> [Int] + pidsOnMachine mId = map (\((_,pid),_,_,_,_) -> pid) $ filter (\((pmid,pid),_,_,_,_) -> pmid == mId) ps + row :: Int -> Int -> Double + row m p + | v /= 3 = (((sort)!!(rowPos!!m + rowOff!!p)) * yScale) + | otherwise = ( (numP + ((fromIntegral curP) +1- (fromIntegral p))) * yScale) + (numSkip*10) + where machine = floor $ sort!!(m-1) + (numP,numSkip) = machineOffsets!!(machine-1) + Just curP = lookup m numProcs + drawRcvLength [] = return () + drawRcvLength (((mID,ptimes),st,et):ts) = + if and (map (0<=) [mID]) + then do + drawRcvLength' mID ptimes st + drawRcvLength ts + else drawRcvLength ts + drawRcvLength' mID ((pID,ptime):ptimes) oldSec = do + rectangleLimited hideStartupPhase (getPositionInPx mID oldSec mxst xScale) (row mID pID) ((getPositionInPx mID ptime mxst xScale)-(getPositionInPx mID oldSec mxst xScale)) (yScale/10) + drawRcvLength' mID ptimes ptime + drawRcvLength' _ [] _ = fill + arrow :: Double -> Double -> Double -> Double -> Render () + arrow fromX fromY toX toY = do + moveTo fromX fromY + lineTo toX toY + arc toX toY 1.5 0 (2 * pi) + stroke + drawMsgs :: DrawWindow -> Double -> Double -> Double -> Double -> IO () + drawMsgs win xScale yScale ulx uly = + target $ do + translate visX visY + thickness <- getLineWidth + translate ulx (uly - 0.3*yScale) + drawMsg msgs thickness + + -- if requested, draw additional messages + if drawBlkMsg then drawMsg amsgs (thickness/2) else return () + where + row :: Int -> Int -> Double + row m p + | v /= 3 = (((sort)!!(rowPos!!m + rowOff!!p)) * yScale) + | otherwise = ( (numP + ((fromIntegral curP) +1- (fromIntegral p))) * yScale) + (numSkip*10) + where machine = floor $ sort!!(m-1) + (numP,numSkip) = machineOffsets!!(machine-1) + Just curP = lookup m numProcs + drawMsg [] l = setLineWidth l + drawMsg (m@(MSG ((sm,sp),o,(rm,rp),i) st rt t s):ms) thickness = do + when ((and (map (0<=) [sm,sp,rm,rp])) && (messageActive (sm,sp) (rm,rp))) + (do + if t == DataMes || t == Head || t == LocalDataMes || t == LocalHead-- not a system message (`DataMes` or `Head`) + then + when drawDataMsgs $ do + let colorType = case t of + DataMes -> messagesData + Head -> messagesHead + LocalDataMes -> messagesDataLocal + LocalHead -> messagesHeadLocal + getColor colorType colorsMap + drawMsgArrow thickness sm sp rm rp st rt + +-- if t == DataMes +-- then do +-- -- draw data messages with half thickness +-- getColor messagesData colorsMap +-- drawMsgArrow (thickness / 2) sm sp rm rp st rt +-- else do +-- getColor messagesHead colorsMap +-- drawMsgArrow thickness sm sp rm rp st rt + else + -- if requested, draw system msgs with a gray color + -- otherwise skip the system msgs + when drawSystemMsgs $ do + getColor messagesSystem colorsMap + drawMsgArrow thickness sm sp rm rp st rt + ) + drawMsg ms thickness + + drawMsgArrow width sm sp rm rp st rt + = do + setLineWidth width + arrow (getPositionInPx sm st mxst xScale) ((row sm sp)-0.3*yScale) (getPositionInPx rm rt mxst xScale) (row rm rp) + + arrow :: Double -> Double -> Double -> Double -> Render () + arrow fromX fromY toX toY = do + moveTo fromX fromY + lineTo toX toY + arc toX toY 1.5 0 (2 * pi) + stroke + + -- draws a transparent, grey trapezoid for bulk messages + drawHeads :: DrawWindow -> Double -> Double -> Double -> Double -> IO () + drawHeads win xScale yScale ulx uly = + target $ do + translate visX visY + lWidth <- getLineWidth + setLineWidth (lWidth / 2) + translate ulx (uly - 0.3*yScale) + drawHead hmsgs + setLineWidth lWidth + where + row :: Int -> Int -> Double + row m p + | v /= 3 = (((sort)!!(rowPos!!m + rowOff!!p)) * yScale) + | otherwise = ( (numP + ((fromIntegral curP) +1- (fromIntegral p))) * yScale) + (numSkip*10) + where machine = floor $ sort!!(m-1) + (numP,numSkip) = machineOffsets!!(machine-1) + Just curP = lookup m numProcs + compSize = 2 * maxSize + relSize s = 0.15 + (s / compSize) + drawHead ((((sm,sp),_,(rm,rp),_),(ts1,tr1,ts2,tr2),size,_):hs) = + if ((min sp rp) < 0) || (not (messageActive (sm,sp) (rm,rp))) + then drawHead hs -- can't draw this! + else do getColorAlpha messagesBlock colorsMap (relSize size) + trapezoid (getPositionInPx sm ts1 mxst xScale) (getPositionInPx sm ts2 mxst xScale) ((row sm sp)-0.3*yScale) + (getPositionInPx rm tr1 mxst xScale) (getPositionInPx rm tr2 mxst xScale) (row rm rp) + drawHead hs + drawHead [] = return () + trapezoid :: Double -> Double -> Double -> Double -> Double -> Double -> Render () + trapezoid x11 x12 y1 x21 x22 y2 = do + moveTo x11 y1 + lineTo x12 y1 + lineTo x22 y2 + lineTo x21 y2 + fill + + + + + +-- Draws a transparent blue box on top of a selected row +-- +addSelection ::Double -> Double -> (Render () -> IO ()) -> Double -> DrawingArea -> ViewerState -> IO () +addSelection visX visY target nRows pic state = do + win <- widgetGetDrawWindow pic + (_,(ulx,uly,lrx,lry)) <- getCorners pic + let xSkip = (lrx - ulx) + ySkip = (lry - uly) / nRows + rows = selRow state + if (not $ null rows) + then sequence_ $ map (\row -> target $ do + translate visX visY + translate ulx uly + --scale xSkip ySkip + translate 0 (ySkip * (row - 1)) + setSourceRGBA 0.0 0.0 1.0 0.3 + rectangle 0.0 0.0 xSkip ySkip + fill) rows + else return () + return () + +addSelectionGroupedProcesses :: Double -> Double -> (Render () -> IO ()) -> Double -> DrawingArea -> ViewerState -> [Double] -> Events -> IO () +addSelectionGroupedProcesses visX visY target nRows pic state lineHeights ((ms,ps,_),mTimes,(mxs,mxst),(msgs,amsgs,hmsgs,_,rcvtimes),(minTime,maxTime,maxSTime,maxSize,maxLD),_)= do + win <- widgetGetDrawWindow pic + (_,(ulx,uly,lrx,lry)) <- getCorners pic + let xSkip = (lrx - ulx) + ySkip = (lry - uly) / nRows + rows = selRow state + numProcs :: [(MachineID, Int)] + numProcs = map (\(mId,_,_,(numP,_,_),_) -> (mId, numP)) ms + + numM = fromIntegral $ length ms + procSkip = (lry - uly - ((numM-1)*10) )/ (fromIntegral (length (matrixP state))) + sortedMachines = [(numM+1) - (posToMachine pos (matrixGP state)) | pos <- [1..numM]] + + posToMachine :: Double -> [Double] -> Double + posToMachine pos sort = posAcc 1 pos sort + where posAcc i pos (s:ss) + | pos == s = i + | otherwise = posAcc (i+1) pos ss + posAcc _ _ [] = 0 + + machineOffsets = 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 + buildOffsets _ [] = [] + if (not $ null rows) + then sequence_ $ map (\row -> target $ do + translate visX visY + translate ulx uly + --scale xSkip ySkip + let mach = (floor numM + 1) - (floor (posToMachine row (matrixGP state))) + (numP,numGap) = (machineOffsets!!((floor row) - 1)) + Just lenP = lookup mach numProcs + translate 0 (numP*procSkip+numGap*10 - 5) + setSourceRGBA 0.0 0.0 1.0 0.3 + rectangle 0.0 0.0 xSkip ((fromIntegral lenP)*procSkip + 5) + fill) rows + else return () + return () + +-- draws y-axis +-- +drawNames :: Double -> Double -> [Double] -> [String] -> Colors -> Render () +-- x-Offset lry y-Offsets names +drawNames x lry (s:ss) (n:ns) colorsMap = do + moveTo x (s-3) + getColor chartAxesLabel colorsMap + showTextR (n) + moveTo (x+2) s + getColor chartAxes colorsMap + lineTo (x+5) s + drawNames x lry ss ns colorsMap +drawNames x lry _ _ colorsMap = do + moveTo (x+5) (- 5) + getColor chartAxes colorsMap + lineTo (x+5) (lry + 5) + +drawName x lry y name colorsMap = do + moveTo x (y-3) + getColor chartAxesLabel colorsMap + showTextR name + +drawNameTick x lry y colorsMap = do + moveTo (x+2) y + getColor chartAxes colorsMap + lineTo (x+5) y + +drawNameLine x lry colorsMap = do + moveTo (x+5) (- 5) + getColor chartAxes colorsMap + lineTo (x+5) (lry + 5) + +drawTimes :: Bool -- True, if ticks/labels should be placed automatically + -> Seconds -- draw tick every `manualSkip` seconds + -> Int -- draw time every `manualMarks` ticks + -> (Seconds, Seconds, Seconds) + -> Bool -- startup sync. enabled + -> DimV -- visible area + -> Dim -- area to draw in + -> Colors + -> Render () +drawTimes useAuto manualSkip manualMarks (minT,maxT,maxST) useDiff (vx,vy,vw,vh) (ulx,uly,lrx,lry) colors = do + let y = fromIntegral (vy + vh - 20) + xDelta = fromIntegral vw / 15 + tDelta + | useDiff = xDelta * ((maxT+maxST) - minT) / (lrx - ulx) + | otherwise = xDelta * (maxT - minT) / (lrx - ulx) + tSkip = if not useAuto then manualSkip else smoothSkip tDelta + xSkip + | useDiff = tSkip * (lrx - ulx) / ((maxT+maxST) - minT) + | otherwise = tSkip * (lrx - ulx) / (maxT - minT) + + -- draw the x-axis + moveTo (ulx-5) y + getColor chartAxes colors + lineTo lrx y + stroke + + -- draw axis labels and ticks + drawTime 0 xSkip y + + where + drawTime :: Double -> Double -> Double -> Render () + drawTime i x y = if mx < lrx + then do + -- draw tick + moveTo mx y + getColor chartAxes colors + lineTo mx my + stroke + + -- draw label + moveTo mx (y + 12) + getColor chartAxesLabel colors + if useAuto + then showText timeString + else if (floor i) `mod` manualMarks == 0 + then showText timeString + else return () + drawTime (i+1) x y + + else stroke + where mx = ulx + (i * x) + my = if useAuto + then y + 5 + else if ((floor i) `mod` manualMarks == 0) && manualMarks > 1 + then y + 6 + else y + 5 + + fullTime + | useDiff = (showFFloat (Just 6) (posToTime minT (maxT+maxST) ulx lrx mx) "") + | otherwise = (showFFloat (Just 6) (posToTime minT maxT ulx lrx mx) "") + -- drop trailing zeros (1.600000 -> 1.6) + (sndStr,fstStr) = splitAt 5 (reverse fullTime) + timeString = (reverse fstStr) ++ (reverse (dropWhile (== '0') sndStr)) + + smoothSkip :: Seconds -> Double + smoothSkip s + | cmp > 7 = 10^^(exponent+1) + | cmp > 5 = 7.5 * 10^^exponent + | cmp > 2 = 5 * 10^^exponent + | cmp > 1 = 2 * 10^^exponent + | otherwise = 10^^exponent + where exponent = floor (logBase 10 s) + cmp = s * 10^^(-exponent) + +drawThreads :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ()) +drawThreads hideStartupPhase visX visY target ((_,_,threads),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) color pic state getDiffTime scaledTime = do + win <- widgetGetDrawWindow pic + (cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic + let numT = (fromIntegral (length threads))::Double + ySkip = (lry - uly) / numT + xSkip = (lrx - ulx) + sort = matrixT state + names = map (\(((m,p),t),_) -> ('T':(show m) ++ ':':(show p) ++ ':': (show t))) threads + target $ do + translate visX visY + save + translate ulx uly + scale xSkip ySkip + if locTime state + then drawLocalThreads threads sort + else drawGlobalThreads threads sort + restore + + let drawAxes = do + drawTimes (autoTicks state) (tickSkip state) (tickMark state) (minTime,maxTime,maxSTime) (locTime state) cv cr color + translate 0 (uly) + drawNames (fromIntegral vx + ulx - 5) (lry-uly) (map (ySkip *) sort) names color + stroke + + return drawAxes + where + drawLocalThreads, drawGlobalThreads :: [Thread] -> [Double] -> Render () + drawLocalThreads ((((m,_),_),evts):ts) (s:ss) = do + let diff = getDiffTime m mxst minTime + drawEvents evts 1 s diff + drawLocalThreads ts ss + drawLocalThreads _ _ = return () + drawGlobalThreads ((_,evts):ts) (s:ss) = do + drawEvents evts 1 s 0.0 + drawGlobalThreads ts ss + drawGlobalThreads _ _ = return () + drawEvents :: [ThreadEvent] -> Double -> Double -> Double -> Render () + drawEvents (e:es) oldSec line diff = case e of + (KillThread sec) -> drawEvents es (scaledTime (sec - diff)) line diff + (GCThread sec _ _ _ l) -> do + let (newSec,evtColor) = getTimeAndColor + evtColor + rectangleLimited hideStartupPhase newSec barG (oldSec - newSec) (fromIntegral l * ldScale) + fill + drawEvents es newSec line diff + evt -> do + let (newSec,evtColor) = getTimeAndColor + evtColor -- set the right color + rectangleLimited hideStartupPhase newSec barO (oldSec - newSec) barH + fill + drawEvents es newSec line diff + where getTimeAndColor = case e of + RunThread sec -> (scaledTime (sec - diff), getColor statusRunning color) + SuspendThread sec -> (scaledTime (sec - diff), getColor statusSuspended color) + BlockThread sec _ _ -> (scaledTime (sec - diff), getColor statusBlocked color) + DeblockThread sec -> (scaledTime (sec - diff), getColor statusSuspended color) + GCThread sec _ _ _ _-> (scaledTime (sec - diff), getColor statusIdle color) + NewThread sec _ -> (scaledTime (sec - diff), getColor statusSuspended color) + barO = line - 0.8 + barG = line - 0.1 + drawEvents _ _ _ _ = return () + barH = 0.7 + ldScale = (-barH) / maxLD + +drawProcesses :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ()) +drawProcesses hideStartupPhase visX visY target ((_,processes,_),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) color pic state getDiffTime scaledTime = do + win <- widgetGetDrawWindow pic + (cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic + let numP = (fromIntegral (length processes))::Double + ySkip = (lry - uly) / numP + xSkip = (lrx - ulx) + sort = matrixP state + names = map (\((m,p),_,_,_,_) -> ('P':(show m) ++ ':':(show p))) processes + target $ do + translate visX visY + save + translate ulx uly + scale xSkip ySkip + if locTime state + then drawLocalProcesses processes sort + else drawGlobalProcesses processes sort + restore + + let drawAxes = do + drawTimes (autoTicks state) (tickSkip state) (tickMark state) (minTime,maxTime,maxSTime) (locTime state) cv cr color + translate 0 (uly) + drawNames (fromIntegral vx + ulx - 5) (lry-uly) (map (ySkip *) sort) names color + stroke + + return drawAxes + where + drawLocalProcesses, drawGlobalProcesses :: [Process] -> [Double] -> Render () + drawLocalProcesses (((m,_),_,_,_,evts):ps) (s:ss) = do + let diff = getDiffTime m mxst minTime + + drawEvents evts 1 s diff + drawLocalProcesses ps ss + drawLocalProcesses _ _ = return () + drawGlobalProcesses ((_,_,_,_,evts):ps) (s:ss) = do + drawEvents evts 1 s 0.0 + drawGlobalProcesses ps ss + drawGlobalProcesses _ _ = return () + drawEvents :: [ProcessEvent] -> Double -> Double -> Double -> Render () + drawEvents [] _ _ _ = return () + drawEvents (e:es) oldSec line diff = case e of + KillProcess sec _ -> drawEvents es (scaledTime (sec - diff)) line diff + LabelProcess _ _ -> drawEvents es oldSec line diff -- don't care + GCProcess sec _ _ _ l -> do + let (newSec,evtColor,_,_) = getTimeAndColor + evtColor + rectangleLimited hideStartupPhase newSec barG (oldSec - newSec) (fromIntegral l * ldScale) + fill + drawEvents es newSec line diff + _ -> do + let (newSec,evtColor,u,d) = getTimeAndColor + evtColor -- set the right color + rectangleLimited hideStartupPhase newSec u (oldSec - newSec) d + fill + drawEvents es newSec line diff + where getTimeAndColor = case e of + RunningProcess sec -> (scaledTime (sec - diff), getColor statusRunning color,barO,barH) + SuspendedProcess sec -> (scaledTime (sec - diff), getColor statusSuspended color,barO,barH) + BlockedProcess sec -> (scaledTime (sec - diff), getColor statusBlocked color,barO,barH) + GCProcess sec _ _ _ _-> (scaledTime (sec - diff), getColor statusIdle color,barO,barH) + NewProcess sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI) + IdleProcess sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI) + barO = line - 0.8 + barG = line - 0.1 + barP = line - 0.5 + barH = 0.7 + barI = 0.4 + ldScale = (-barH) / maxLD + + +drawGroupProcesses :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ()) +drawGroupProcesses hideStartupPhase visX visY target ((machines,processes,_),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) color pic state getDiffTime scaledTime = do + win <- widgetGetDrawWindow pic + let groupedProcesses = map (\(mid,_,_,_,_) -> filter (\((pmid,pid),_,_,_,_) -> pmid == mid) processes) machines + --let sortOrder :: [(Double, + (cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic + let numP = (fromIntegral (length processes))::Double + numM = (fromIntegral (length machines))::Double + machGap = 10 + ySkip = ((lry - uly - ((numM-1)*machGap) ) / numP) + xSkip = (lrx - ulx) + sort = matrixGP state + names = map (\((m,p),_,_,_,_) -> ('P':(show m) ++ ':':(show p))) processes + sortGroup = map (pos 1 sort) [1..numM] + where pos :: Double -> [Double] -> Double -> Double + pos i (y:ys) x + | x == y = i + | otherwise = pos (i+1) ys x + pos _ [] _ = undefined + + + sortedGroupedProcess = map (\i -> groupedProcesses !! ((floor i)-1)) sortGroup + drawLocalGroupedProcesses :: [[Process]] -> Double -> Render () + drawLocalGroupedProcesses (p:ps) i = do + let skip = (machGap / ySkip) + drawLocalProcesses p [1..] i + drawLocalGroupedProcesses ps (i + (fromIntegral $ length p) + skip) + drawLocalGroupedProcesses [] _ = return () + drawGlobalGroupedProcesses :: [[Process]] -> Double -> Render () + drawGlobalGroupedProcesses (p:ps) i = do + let skip = (machGap / ySkip) + drawGlobalProcesses p [1..] i + drawGlobalGroupedProcesses ps (i + (fromIntegral $ length p) + skip) + drawGlobalGroupedProcesses [] _ = return () + + drawGroupNames :: [[Process]] -> Double -> Render () + drawGroupNames (p:ps) i = do + let skip = (machGap) + drawPNames p [1..] i color + stroke + drawGroupNames ps (i+ (((fromIntegral $ length p))*ySkip) + skip) + drawGroupNames [] _ = do + drawNameLine (fromIntegral vx + ulx - 5) (lry-uly) color + stroke + + drawPNames [((m,pid),_,_,_,evts)] (s:ss) skip = do + drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show m) ++ ":" ++ (show pid)) + drawNameTick (fromIntegral vx + ulx -5) (lry-uly) ((s*ySkip)+skip+5) + drawPNames (((m,pid),_,_,_,evts):ps) (s:ss) skip = do + drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show m) ++ ":" ++ (show pid)) + drawPNames ps ss skip + + + target $ do + translate visX visY + save + translate ulx uly + scale xSkip ySkip + --liftIO $ putStrLn $ "sort" ++ (show sort) + --liftIO $ putStrLn $ "sortGroup" ++ (show sort) + if locTime state + then drawLocalGroupedProcesses sortedGroupedProcess 0 + else drawGlobalGroupedProcesses sortedGroupedProcess 0 + restore + + let drawAxes = do + drawTimes (autoTicks state) (tickSkip state) (tickMark state) (minTime,maxTime,maxSTime) (locTime state) cv cr color + translate 0 (uly) + drawGroupNames sortedGroupedProcess 0 + stroke + + return drawAxes + where + drawLocalProcesses :: [Process] -> [Double] -> Double -> Render () + drawLocalProcesses (((m,_),_,_,_,evts):ps) (s:ss) skip = do + let diff = getDiffTime m mxst minTime + + drawEvents evts 1 s diff skip + drawLocalProcesses ps ss skip + drawLocalProcesses _ _ _ = return () + drawGlobalProcesses ((_,_,_,_,evts):ps) (s:ss) skip = do + drawEvents evts 1 s 0.0 skip + drawGlobalProcesses ps ss skip + drawGlobalProcesses _ _ _ = return () + drawEvents :: [ProcessEvent] -> Double -> Double -> Double -> Double -> Render () + drawEvents [] _ _ _ _ = return () + drawEvents (e:es) oldSec line diff skip = case e of + KillProcess sec _ -> drawEvents es (scaledTime (sec - diff)) line diff skip + LabelProcess _ _ -> drawEvents es oldSec line diff skip -- don't care + GCProcess sec _ _ _ l -> do + let (newSec,evtColor,_,_) = getTimeAndColor + evtColor + rectangleLimited hideStartupPhase newSec barG (oldSec - newSec) (fromIntegral l * ldScale) + fill + drawEvents es newSec line diff skip + _ -> do + let (newSec,evtColor,u,d) = getTimeAndColor + evtColor -- set the right color + rectangleLimited hideStartupPhase newSec (skip+u) (oldSec - newSec) d + fill + drawEvents es newSec line diff skip + where getTimeAndColor = case e of + RunningProcess sec -> (scaledTime (sec - diff), getColor statusRunning color,barO,barH) + SuspendedProcess sec -> (scaledTime (sec - diff), getColor statusSuspended color,barO,barH) + BlockedProcess sec -> (scaledTime (sec - diff), getColor statusBlocked color,barO,barH) + GCProcess sec _ _ _ _-> (scaledTime (sec - diff), getColor statusIdle color,barO,barH) + NewProcess sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI) + IdleProcess sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI) + barO = line - 1 -- - 0.7 + barG = line - 0.1 + barP = line - 0.5 + barH = 1 + barI = 0.4 + ldScale = (-barH) / maxLD + + + +drawMachines :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ()) +drawMachines hideStartupPhase visX visY target ((machines,_,_),mTimes,(mxs,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) color pic state getDiffTime scaledTime = do + win <- widgetGetDrawWindow pic + (cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic + let numM = (fromIntegral (length machines))::Double + ySkip = (lry - uly) / numM + xSkip = (lrx - ulx) + sort = matrixM state + names = map (\(m,_,_,_,_) -> ('M':(show m))) machines + + target $ do + translate visX visY + translate ulx (uly - ySkip) + scale xSkip ySkip + if locTime state + then drawLocalMachines machines sort + else drawGlobalMachines machines sort + + let drawAxes = do + translate visX visY + drawTimes (autoTicks state) (tickSkip state) (tickMark state) (minTime,maxTime,maxSTime) (locTime state) cv cr color + translate 0 (uly) + drawNames (fromIntegral vx + ulx - 5) (lry-uly) (map (ySkip *) sort) names color + stroke + + return drawAxes + where + -- startup sync activated + drawLocalMachines, drawGlobalMachines :: [Machine] -> [Double] -> Render () + drawLocalMachines ((i,_,_,_,evts):ms) (s:ss) = do + let diffTime = getDiffTime i mxst minTime + + drawEvents evts 1 s diffTime + drawLocalMachines ms ss + drawLocalMachines _ _ = return () + + -- startup sync deactivated + drawGlobalMachines ((i,_,_,_,evts):ms) (s:ss) = do + drawEvents evts 1 s 0.0 + drawGlobalMachines ms ss + drawGlobalMachines _ _ = return () + + drawEvents :: [MachineEvent] -> Double -> Double -> Double -> Render () + drawEvents (e:es) oldSec line diff = case e of + (EndMachine sec) -> + drawEvents es (scaledTime (sec - diff)) line diff + (GCMachine sec _ _ _ l) -> do + let (newSec,evtColor,_,_) = getTimeAndColor + evtColor + rectangleLimited hideStartupPhase newSec barG (oldSec - newSec) (fromIntegral l * ldScale) + fill + drawEvents es newSec line diff + _ -> do + let (newSec,evtColor,u,d) = getTimeAndColor + evtColor -- set the right color + rectangleLimited hideStartupPhase newSec u (oldSec - newSec) d + fill + drawEvents es newSec line diff + where getTimeAndColor = case e of + RunningMachine sec -> (scaledTime (sec - diff), getColor statusRunning color,barO,barH) + SuspendedMachine sec -> (scaledTime (sec - diff), getColor statusSuspended color,barO,barH) + BlockedMachine sec -> (scaledTime (sec - diff), getColor statusBlocked color,barO,barH) + GCMachine sec _ _ _ _-> (scaledTime (sec - diff), getColor statusIdle color,barO,barH) + StartMachine sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI) + IdleMachine sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI) + barO = line + 0.2 + barG = line + 0.9 + barP = line + 0.5 + drawEvents _ _ _ _ = return () + barH = 0.7 + barI = 0.4 + ldScale = (-barH) / maxLD + +prepareBackground :: Double -> Double -> (Render () -> IO ()) -> DrawingArea -> Colors -> IO () +prepareBackground visX visY target area colors = do + win <- widgetGetDrawWindow area + (w,h) <- widgetGetSize area + (_,(ulx,uly,lrx,lry)) <- getCorners area + let width = realToFrac w + height = realToFrac h + width' = width - 2 * border + height' = height - 2 * border + target $ do + translate visX visY + -- setLineWidth 1 + -- Background + colorGray + rectangle 0 0 width height + fill + colorBlack + + -- Shadow of paper + save + translate shadow shadow + rectangle border border width' height' + fill + restore + + -- Paper + rectangle border border width' height' + stroke + getColor chartBackground colors + rectangle border border width' height' + fill + + {-- Axis + colorBlack + moveTo (ulx - 10) lry + lineTo (lrx + 5) lry + stroke-} + return () + where + +-- create a dialog with a message (for errors and questions) +genericDialog :: String -> Bool -> IO Dialog +genericDialog msg err = do + dlg <- dialogNew + dialogSetHasSeparator dlg False + windowSetIconName dlg $ if err + then "gtk-dialog-error" + else "gtk-dialog-question" + upper <- dialogGetUpper dlg + label <- labelNew (Just msg) + labelSetJustify label JustifyCenter + miscSetPadding label 20 20 + containerAdd upper label + return dlg + +-- errorMessage: +-- opens a window and displays the given string as errormessage +errorMessage :: String -> IO () +errorMessage e = do + dlg <- genericDialog e True + dialogAddButton dlg stockOk ResponseOk + afterResponse dlg (\_ -> widgetDestroy dlg) + widgetShowAll dlg + +yesNoMessage :: String -> IO Bool +yesNoMessage e = do + dlg <- genericDialog e False + dialogAddButton dlg stockYes ResponseYes + dialogAddButton dlg stockNo ResponseNo + afterResponse dlg (\_ -> widgetDestroy dlg) + widgetShowAll dlg + response <- dialogRun dlg + case response of + ResponseYes -> return True + _ -> return False + + +drawStartupMarker :: Double -> Double -> Double -> (Render () -> IO ()) -> Events -> DrawingArea -> ViewerState -> Colors -> IO () +drawStartupMarker pixelsPerSecond visX visY target (_, _, (maxStartupTimeInSeconds,_),_ , (minTime, maxTime, maxSTime,_ ,_ ), _) pic state colorsMap + = do + win <- widgetGetDrawWindow pic + (_,(ulx,uly,lrx,lry)) <- getCorners pic + + drawMarker win pixelsPerSecond ulx uly (lry - uly) + where + drawMarker :: DrawWindow -> Double -> Double -> Double -> Double -> IO () + drawMarker win pixelsPerSecond ulx uly height = target $ do + translate visX visY + thickness <- getLineWidth + setLineWidth (thickness / 2) + translate ulx uly + getColor markerStartup colorsMap + + let startupPositionInPx = getPosition maxStartupTimeInSeconds + + arrow startupPositionInPx (0) startupPositionInPx (height) + setLineWidth thickness + + where + getPosition :: Double -> Double + getPosition seconds = seconds * pixelsPerSecond + + arrow :: Double -> Double -> Double -> Double -> Render () + arrow fromX fromY toX toY = do + moveTo fromX fromY + lineTo toX toY + arc toX toY 1.5 0 (2 * pi) + stroke + +-- When hiding the startup-phase, the blue box of a machine might start before +-- the y-axis. This function makes sure that only the part right of the +-- y-axis is drawn. +rectangleLimited :: Bool -> Double -> Double -> Double -> Double -> Render() +rectangleLimited checkOverflow x y width height + | checkOverflow && (x < 0) = do + let newWidth = width + x + when (newWidth > 0) $ rectangle 0 y newWidth height + | otherwise = rectangle x y width height + diff --git a/RTSEventsParser.hs b/RTSEventsParser.hs new file mode 100644 --- /dev/null +++ b/RTSEventsParser.hs @@ -0,0 +1,1177 @@ +{- The Eden Trace Viewer (or simply EdenTV) is a tool that can generate diagrams + to visualize the behaviour of Eden programs. + Copyright (C) 2005-2010 Phillips Universitaet Marburg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +-} +{-# OPTIONS -XNamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} +module RTSEventsParser ( + traceRTSFile, + Err(..) +) where + +import TinyZipper +import qualified EdenTvType as E +import GHC.RTS.Events + +import qualified Control.Exception as C +import Control.Monad.Error +import Data.Binary.Get +import Data.ByteString.Lazy (ByteString) +import Data.Either +import Data.Maybe +import Data.Tree +import qualified Data.Map as M +import qualified Data.Sequence as S + +import Debug.Trace + +type RTSEvents = (E.MachineID, [Event]) +data Err a = Ok !a | Failed String +type Lookuptable = [(E.MachineID, [(Int, Int)])] + +---------------------------------- +-- +-- Reader function: parseRawFile +-- Reads a zip File containing binary eventlog files +-- to a List of RTSEvents +-- +---------------------------------- + +-- 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 ("ParseRawFile: Bad File (due to: "++(show e)++")")) + + +-- similar to readEventLogFromFile, but uses a ByteString +-- parses a binary *.eventlog file +readGhcEventsSingle :: ByteString -> IO (Either String EventLog) +readGhcEventsSingle s = return $ runGet (do v <- runErrorT $ getEventLog + m <- isEmpty + m `seq` return v) $ s + +-- convert an EventLog to a List of its Events, paired with +-- the machine number +eventLogToEvents :: EventLog -> Either String RTSEvents +eventLogToEvents 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 "eventLogToEvents: No CreateMachine Event!" + +-- now we can read all files contained in a zip archive +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 eventLogToEvents logs + case null errevts of + False -> return $ Left ("readAll: Events error "++(show errevts)) + True -> return $ Right events + False -> return $ Left "readAll: Parse error") + files' + + + +--------------------------------------------------------------- +-- parseAdditional +-- parses Additional information (needed for, or not covered by +-- the old legacy parser) from RTSEvents +--------------------------------------------------------------- + +data AddInfo = AddInfo { + ai_threadTable :: !ThreadTable, -- get Proc# from Thread# + ai_mainTime :: !E.Seconds, -- realtime of 1st machine + ai_syncTable :: ![(E.MachineID, E.Seconds)], -- offsets to mainTime + ai_startupDiff :: !(E.Seconds, [(E.MachineID, E.Seconds)]), -- offsets to Startup + ai_endTable :: ![(E.MachineID, E.Seconds)], -- end Times of Machines + ai_maxEndTime :: !E.Seconds, -- max End Time + ai_minCMTime :: !E.Seconds, -- earliest CreateMachine Time + ai_maxSUDiff :: !E.Seconds, -- max startup offset + ai_rcvLengths :: ![((E.MachineID,[(Int,E.Seconds)]), E.Seconds, E.Seconds)], -- used for rect Blocks in Grouped Messages + ai_leftMsgs :: ![E.Message] -- Messages which are left out by old ETV +} +type ThreadTable = [(E.MachineID, [(Int, Int)])] + +parseAdditional :: Bool -> [RTSEvents] -> AddInfo +parseAdditional ignoreMessages = mergeInfo . + map (\(mID, evts) -> (parseAdditionalSingle evts (emptyInfo mID)) ignoreMessages) + + +mergeInfo :: [AddInfoSingle] -> AddInfo +mergeInfo aiss = + let threadTable = map (\ais -> let mID = ais_machineID ais + tTable = ais_threadTable ais + in mID `seq` (length tTable) `seq` (mID, tTable)) aiss + + mainTime = ais_realtime $ head $ filter (\ais -> ais_machineID ais == 1) aiss + syncTable = map (\ais -> let mID = ais_machineID ais + realT = ais_realtime ais + in mID `seq` realT `seq` (mID, realT - mainTime)) aiss + + + cmTimes = map (\ais -> let mID = ais_machineID ais + cmT = convertTimestampWithTable syncTable mID (ais_CMTimestamp ais) + in mID `seq` cmT `seq` (mID, cmT) + ) aiss + minCMTime = minimum $ map snd cmTimes + + startupTimes = map (\ais -> let mID = ais_machineID ais + suT = convertTimestampWithTable syncTable mID (ais_SUTimestamp ais) + in mID `seq` suT `seq` (mID, suT) + ) aiss + maxStartupTime = maximum $ map snd startupTimes + + startupDiff = (maxStartupTime, map (\(mID, s) -> (mID, maxStartupTime - s)) startupTimes) + maxStartupDiff = maximum $ zipWith (\(_, diffs) (_,end) -> if diffs + end > maxEndTime then (diffs+end)-maxEndTime else 0) (snd startupDiff) endTimes + + endTimes = map (\ais -> let mID = ais_machineID ais + leT = convertTimestampWithTable syncTable mID (ais_LETimestamp ais) + in mID `seq` leT `seq` (mID, leT) + ) aiss + maxEndTime = maximum $ map snd endTimes + + rcvLengths = concatMap (\ais -> let mID = ais_machineID ais + convert = convertTimestampWithTable syncTable mID + in map (\(pids, ts, te) -> let pidM = reverse $ map (\(pid, t) -> (pid, convert t)) pids + cts = convert ts + cte = convert te + in mID `seq` (length pidM) `seq` cts `seq` cte `seq` ((mID, pidM), cts, cte) + ) (ais_receiveLengths ais)) aiss + + leftMsgEvents :: [(E.MachineID, Event)] + leftMsgEvents = concatMap (\ais -> map (\e -> (ais_machineID ais, e)) (ais_leftMessages ais)) aiss + + leftMsgs :: (E.OpenMessagesPerProcess, [E.Message]) + leftMsgs = foldr processLeftMsgs (M.empty, []) leftMsgEvents + + left :: [E.Message] + left = snd leftMsgs + + processLeftMsgs :: (E.MachineID, Event) -> (E.OpenMessagesPerProcess, [E.Message]) + -> (E.OpenMessagesPerProcess, [E.Message]) + processLeftMsgs (mID, Event{time, spec}) oe + = let convertTimestamp = convertTimestampWithSync (toSyncTime syncTable mID) + in case spec of + SendMessage{ + mesTag, + senderProcess, + senderThread, + receiverMachine, + receiverProcess, + receiverInport} + -> insertLeftOutMessages (mID, (fromIntegral senderProcess)) + (E.OSM (convertTimestamp time) + (fromIntegral receiverMachine, fromIntegral receiverProcess) + (fromIntegral senderThread) + (fromIntegral receiverInport) + (readTag mesTag)) oe + ReceiveMessage{ + mesTag, + receiverProcess, + receiverInport, + senderMachine, + senderProcess, + senderThread, + messageSize} + -> insertLeftOutMessages ((fromIntegral senderMachine), (fromIntegral senderProcess)) + (E.ORM (convertTimestamp time) + (mID, fromIntegral receiverProcess) + (fromIntegral senderThread) + (fromIntegral receiverInport) + (readTag mesTag) + (fromIntegral messageSize)) oe + SendReceiveLocalMessage{ + mesTag, + senderProcess, + senderThread, + receiverProcess, + receiverInport} + -> insertLeftOutLocalMessage (E.MSG ((mID, fromIntegral senderProcess), + fromIntegral senderThread, + (mID, fromIntegral receiverProcess), + fromIntegral receiverInport) + (convertTimestamp time) + (convertTimestamp time) + (readLocalTag mesTag) + 0 + ) oe + _ -> oe + + + evaluateMessages [] = [] + evaluateMessages ((E.MSG _ _ _ _ _):msgs) = evaluateMessages msgs + + in (length threadTable) `seq` + (length rcvLengths) `seq` + (evaluateMessages left) `seq` + AddInfo { ai_threadTable = threadTable, + ai_mainTime = mainTime, + ai_syncTable = syncTable, + ai_startupDiff = startupDiff, + ai_endTable = endTimes, + ai_maxEndTime = maxEndTime, + ai_rcvLengths = rcvLengths, + ai_minCMTime = minCMTime, + ai_maxSUDiff = maxStartupDiff, + ai_leftMsgs = left + } + +emptyInfo :: E.MachineID -> AddInfoSingle +emptyInfo mID = AddInfoSingle { ais_machineID = mID, + ais_threadTable = [], + ais_CMTimestamp = 0, + ais_SUTimestamp = 0, + ais_LETimestamp = 0, + ais_realtime = 0, + ais_receiveLengths = [], + ais_leftMessages = [], + + ais_tCollect = False, + ais_tStart = 0, + ais_tPIDS = [] + } + +data AddInfoSingle = AddInfoSingle { + ais_machineID :: !E.MachineID, + ais_threadTable :: ![(Int,Int)], -- (Thread#, Proc#) + ais_CMTimestamp :: !Timestamp, -- Timestamp of CreateMachine + ais_SUTimestamp :: !Timestamp, -- Timestamp of Startup + ais_LETimestamp :: !Timestamp, --- Timestamp of last Event + ais_realtime :: !E.Seconds, + ais_receiveLengths :: ![([(Int, Timestamp)], Timestamp, Timestamp)], + ais_leftMessages :: ![Event], + + ais_tCollect :: !Bool, + ais_tStart :: !Timestamp, + ais_tPIDS :: ![(Int,Timestamp)] +} +parseAdditionalSingle :: [Event] -> AddInfoSingle -> Bool -> AddInfoSingle +parseAdditionalSingle [] aux _ = aux +parseAdditionalSingle ((Event{time, + spec=AssignThreadToProcess{thread,process}}):evts) aux ignoreMessages = + let oldTT = ais_threadTable aux + newTT@((!t, !p): (!oldTT')) = (fromIntegral thread, fromIntegral process):oldTT + in parseAdditionalSingle evts (aux{ais_threadTable = newTT,ais_LETimestamp= time}) ignoreMessages + +parseAdditionalSingle ((Event{time, + spec=CreateMachine{realtime}}):evts) aux ignoreMessages = + let newRealtime = ((fromIntegral realtime)/10e7)-((fromIntegral time) / 10e8) + in parseAdditionalSingle evts (aux{ais_CMTimestamp = time, ais_realtime = newRealtime,ais_LETimestamp= time}) ignoreMessages + +parseAdditionalSingle ((Event{time, + spec=Startup{}}):evts) aux ignoreMessages = parseAdditionalSingle evts (aux{ais_SUTimestamp = time, ais_LETimestamp= time}) ignoreMessages + +parseAdditionalSingle (e@(Event{time, spec=SendMessage{}}):evts) aux@(AddInfoSingle{ais_leftMessages=oldMsg}) ignoreMessages + | ignoreMessages = parseAdditionalSingle evts aux ignoreMessages + | otherwise = parseAdditionalSingle evts (aux{ais_leftMessages = (e:oldMsg), ais_LETimestamp= time}) ignoreMessages + +parseAdditionalSingle ((Event{time, + spec=EdenStartReceive}):evts) aux ignoreMessages = + parseAdditionalSingle evts (aux{ais_tCollect = True,ais_tStart=time,ais_LETimestamp= time }) ignoreMessages + +parseAdditionalSingle ((Event{time, + spec=EdenEndReceive}):evts) aux@(AddInfoSingle{ais_receiveLengths=oldRL, ais_tStart, ais_tPIDS}) ignoreMessages = + ais_tStart `seq` ais_tPIDS `seq` oldRL `seq` parseAdditionalSingle evts (aux{ais_tCollect = False,ais_receiveLengths=((ais_tPIDS, ais_tStart, time):oldRL), ais_tPIDS=[], ais_LETimestamp= time}) ignoreMessages + +parseAdditionalSingle ((Event{time, + spec=CreateProcess{process}}):evts) aux@(AddInfoSingle{ais_tCollect=True, ais_tPIDS=oldPIDs}) ignoreMessages = + let p = fromIntegral process + in p `seq` oldPIDs `seq` parseAdditionalSingle evts (aux{ais_tPIDS=((p,time):oldPIDs),ais_LETimestamp= time}) ignoreMessages + +parseAdditionalSingle (e@(Event{time, spec=ReceiveMessage{receiverProcess,mesTag}}):evts) aux@(AddInfoSingle{ais_tCollect=b, ais_tPIDS=oldPIDs,ais_leftMessages=oldMsg}) ignoreMessages + | ignoreMessages = parseAdditionalSingle evts aux ignoreMessages + | b = case mesTag of RFork -> parseAdditionalSingle evts (aux{ais_leftMessages = (e:oldMsg),ais_LETimestamp=time}) ignoreMessages + _ -> let rp = fromIntegral receiverProcess + in rp ` seq` parseAdditionalSingle evts (aux{ais_leftMessages = (e:oldMsg),ais_tPIDS=((fromIntegral receiverProcess,time):oldPIDs),ais_LETimestamp=time}) ignoreMessages + | otherwise = parseAdditionalSingle evts (aux{ais_leftMessages = (e:oldMsg),ais_LETimestamp=time}) ignoreMessages + +parseAdditionalSingle (e@(Event{time, spec=SendReceiveLocalMessage{}}):evts) aux@(AddInfoSingle{ais_leftMessages=oldMsg}) ignoreMessages + | ignoreMessages = parseAdditionalSingle evts aux ignoreMessages + | otherwise = parseAdditionalSingle evts (aux{ais_leftMessages = (e:oldMsg), ais_LETimestamp= time}) ignoreMessages + +parseAdditionalSingle (e:evts) aux ignoreMessages = parseAdditionalSingle evts (aux{ais_LETimestamp= time e}) ignoreMessages + + +-- This function is called for every SendMessage or ReceiveMessage that +-- was found in the additional events. It takes care of grouping corresponding +-- send and receive message events into a single message. +-- +-- copy of legacy Code, used to just extract Head Messages +insertLeftOutMessages :: E.ProcessID -- sender process id + -> E.OpenMessageEvent -- the message event to process + -> (E.OpenMessagesPerProcess, -- messages that could not yet be matched with their + -- corresponding close/open message grouped per process + [E.Message]) -- complete messages for which the send and + -- and receive event could be matched + -> (E.OpenMessagesPerProcess, [E.Message]) +insertLeftOutMessages senderProcessId newMessage ocMsgs@(openMessages, closedMessages) + | or [(tag == E.Head), (tag == E.DataMes)] + = let ((_, senderProcess'), (_, receiveProcess')) = (senderProcessId, receiveProcessId) + in if (min senderProcess' receiveProcess') >= 0 + then openMessages' `seq` closedMessages' `seq` (openMessages', closedMessages') + else ocMsgs + | otherwise = ocMsgs + where (receiveProcessId, tag) = case newMessage of + E.ORM _ p _ _ r _ -> (p, r) + E.OSM _ p _ _ r -> (p, r) + + (openMessages', closedMessages') = searchID senderProcessId newMessage openMessages closedMessages + + +insertLeftOutLocalMessage :: E.Message -> (E.OpenMessagesPerProcess, [E.Message]) -> (E.OpenMessagesPerProcess, [E.Message]) +insertLeftOutLocalMessage m (oms, msgs) = let msgs' = m : msgs + in msgs' ` seq` (oms, msgs') + + +-- This function receives a process id, a message event (send or receive) for a message +-- that was sent from this process, a map of open messages for all processes +-- and a list of closed messages. +-- +-- If there already are message events for the given process, the corresponding +-- send/receive message is searched in the open messages of the process. +-- If a message can be 'closed' (a SendMessage can be found for a ReceiveMessage, +-- or a ReceiveMessage can be found for a SendMessage), the merged message is +-- added to the list of closed messages. +-- +searchID :: E.ProcessID -> E.OpenMessageEvent -> E.OpenMessagesPerProcess -> [E.Message] + -> (E.OpenMessagesPerProcess, [E.Message]) +searchID senderProcess newOpenMessage openMessagesPerProcess closedMessages + = trySearchProcess (M.lookup senderProcess openMessagesPerProcess) + where + -- the key to store the message event in a map + messageKey = getKeyForOpenMessage newOpenMessage + -- the key a corresponding 'closing' message event would have + closingMessageKey = getClosingMessageKey newOpenMessage + + -- a compressed representation of the message which is used as + -- value to store the message in a map (all other information + -- about the message is already contained in the key) + smallNewOpenMessage = getSmallOpenMessage newOpenMessage + + + trySearchProcess :: Maybe E.OpenMessages -> (E.OpenMessagesPerProcess, [E.Message]) + -- this is the first message of the process, create a new entry in the map + trySearchProcess (Nothing) = (openMessagesPerProcess', closedMessages) + where + openMessagesPerProcess' = M.insert senderProcess processEntry openMessagesPerProcess + processEntry = M.singleton messageKey (S.singleton smallNewOpenMessage) + -- there is already an entry for the process, look for an closing message event + trySearchProcess (Just openMessages) + = trySearchClosingMessage (M.lookup closingMessageKey openMessages) openMessages + + + trySearchClosingMessage :: Maybe (S.Seq E.SmallOpenMessageEvent) -> E.OpenMessages + -> (E.OpenMessagesPerProcess, [E.Message]) + -- there is no matching closing message event yet, so store the event + trySearchClosingMessage (Nothing) openMessages + = (openMessagesPerProcess', closedMessages) + where + -- update the process entry in the map + openMessagesPerProcess' :: E.OpenMessagesPerProcess + openMessagesPerProcess' = M.insert senderProcess openMessages' openMessagesPerProcess + + -- add the event to the map of open events for this process: + -- if there already are open events for this process that use the same + -- channel (same type/rcvProcess/inport/outport/type), thus use the same + -- map key, then enqueue the new message to the sequence of these messages. + openMessages' :: E.OpenMessages + openMessages' = M.insertWith enqueueEvent messageKey (S.singleton smallNewOpenMessage) openMessages + + -- this functions takes care of appending the new event to the sequence + -- of already existing events with the same map key + enqueueEvent :: S.Seq E.SmallOpenMessageEvent -- sequence which contains only the new event + -> S.Seq E.SmallOpenMessageEvent -- old events with the same key + -> S.Seq E.SmallOpenMessageEvent + enqueueEvent newOpenMessageSeq oldOpenMessages = enqueue oldOpenMessages newOpenMessage + where + newOpenMessage = S.index newOpenMessageSeq 0 + enqueue = (S.|>) + -- if there is a corresponding event, 'close' the message + trySearchClosingMessage (Just oldMessages) openMessages + = (openMessagesPerProcess', closedMessages') + where + openMessagesPerProcess' :: E.OpenMessagesPerProcess + openMessagesPerProcess' = + -- if this was the last message event of the process, + -- remove the process' map entry + if (M.null openMessages') + then M.delete senderProcess openMessagesPerProcess + else M.insert senderProcess openMessages' openMessagesPerProcess + + openMessages' :: E.OpenMessages + openMessages' = + -- if there are no more events with the same key as the + -- closing event, remove the key from the map + if ((S.length oldMessages) == 1) + then M.delete closingMessageKey openMessages + else M.insert closingMessageKey (S.drop 1 oldMessages) openMessages + + closedMessages' :: [E.Message] + closedMessages' = closedMessage : closedMessages + closedMessage :: E.Message + closedMessage = closeMessage newOpenMessage oldMessage + + oldMessage :: E.SmallOpenMessageEvent + oldMessage = S.index oldMessages 0 + + -- Merges matching send- and receive-message events into a single message + closeMessage :: E.OpenMessageEvent -> E.SmallOpenMessageEvent -> E.Message + closeMessage (E.OSM sendTime rcvProcess outport inport reason) (E.SmallORM rcvTime size) + = E.MSG (senderProcess, outport, rcvProcess, inport) sendTime rcvTime reason size + closeMessage (E.ORM rcvTime rcvProcess outport inport reason size) (E.SmallOSM sendTime) + = E.MSG (senderProcess, outport, rcvProcess, inport) sendTime rcvTime reason size + + -- Creates a 'small' representation of a message event, which is + -- used to store the message in a map. + getSmallOpenMessage :: E.OpenMessageEvent -> E.SmallOpenMessageEvent + getSmallOpenMessage (E.OSM sendTime rcvProcess outport inport reason) + = E.SmallOSM sendTime + getSmallOpenMessage (E.ORM sendTime rcvProcess outport inport reason size) + = E.SmallORM sendTime size + + -- Returns a map key to retrieve a message event which would close + -- the given message event. + getClosingMessageKey :: E.OpenMessageEvent -> E.OpenMessageKey + getClosingMessageKey (E.ORM _ rcvProcess outport inport reason _) + = getKeyForOpenMessage (E.OSM __ rcvProcess outport inport reason) + getClosingMessageKey (E.OSM _ rcvProcess outport inport reason) + = getKeyForOpenMessage (E.ORM __ rcvProcess outport inport reason ___) + __ = 0 / 0 + ___ = 0 + + -- Returns a key which is used store a message event in a map. + getKeyForOpenMessage :: E.OpenMessageEvent -> E.OpenMessageKey + getKeyForOpenMessage (E.ORM _ rcvProcess outport inport reason _) + = (E.TORM, rcvProcess, outport, inport, reason) + getKeyForOpenMessage (E.OSM _ rcvProcess outport inport reason) + = (E.TOSM, rcvProcess, outport, inport, reason) + +-------------------------------------------------------------------------------- +-- Main Function +-------------------------------------------------------------------------------- +traceRTSFile :: FilePath -> Bool -> IO (Err E.Events) +traceRTSFile file ignoreMessages = + do ghcevents' <- parseRawFile file + case ghcevents' of + Left err -> return (Failed err) + Right ghcevents -> + do return (Ok finishedEvents) + where processedEvents = closeOpenLists $ process ghcevents emptyoe + additionalInfo = parseAdditional ignoreMessages ghcevents + finishedEvents = if ignoreMessages + then finish processedEvents + else injectProcMessages $ finish processedEvents + + finish ((lom,lop,lot),mst, sudiff, (ml,aml,hml,pt, rcvl ), (min_t, m_t,msudiff,mmsg,mld),nums) = + ((lom,lop,lot),mst, ai_startupDiff additionalInfo, (ml,ai_leftMsgs additionalInfo,hml,pt, ai_rcvLengths additionalInfo), (min_t, m_t,ai_maxSUDiff additionalInfo,mmsg,mld),nums) + + + {- + -- START HACK + -- TODO needs rewrite + -} + -- 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 (ai_syncTable additionalInfo) 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 (ai_syncTable additionalInfo) receiverMach) (time e) + child = E.MSG channelID sTime rTime E.RFork (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) + + {- + -- END HACK + -} + + -- from old haskell EdenTV + -- initial events structure + emptyoe = (([],[],[]),[(0,firstTime)], fml firstTime, (firstTime, firstTime, 0, -1)) + where firstTime = ai_minCMTime additionalInfo + + + -- from old haskell EdenTV + -- creates initial MessageList + fml :: E.Seconds -> E.OpenMessageList + fml t = (M.empty,[],([(1,[((1,1),E.OSM t (0,0) (-1) (-1) E.RFork)],[((0,0),E.ORM t (1,1) (-1) (-1) E.RFork 4)],[])],[((0,0),[])],Node (0,0) []),([],0,[])) + + -- 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 (ai_syncTable additionalInfo) mID) + newOE = insertEvent convertTimestamp (ai_threadTable additionalInfo) (mID,evt) oe ignoreMessages + in seq newOE $ process ((mID,evts):machines) newOE + process ((_,[]):machines) oe = process machines oe + process [] oe = oe + + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +-- 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) + +convertTimestampWithTable :: [(E.MachineID, Double)] -> E.MachineID -> Timestamp -> E.Seconds +convertTimestampWithTable syncTable mID timestamp = + let offset = toSyncTime syncTable mID + in convertTimestampWithSync offset timestamp + +toSyncTime :: [(E.MachineID, Double)] -> E.MachineID -> E.Seconds +toSyncTime ((mId, t):machines) i + | mId == i = t + | otherwise = toSyncTime machines i +toSyncTime [] _ = 0 + +-- converts a MessageTag to the ReasonType specified in old legacy format +readTag :: MessageTag -> E.ReasonType +readTag tag = case tag of + RFork -> E.RFork + Connect -> E.Connect + DataMes -> E.DataMes + Head -> E.Head + Constr -> E.Constr + Part -> E.Part + Terminate -> E.Terminate + _ -> E.Default + +readLocalTag :: MessageTag -> E.ReasonType +readLocalTag tag = case tag of + Head -> E.LocalHead + DataMes -> E.LocalDataMes + _ -> error "readLocalTag was given a non-local tag" + +-- finds the matching Process# to a given MachineId and Thread# +-- inside the ThreadTable +lookupProcess :: ThreadTable -> 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@((tnum,pnum):xs) stnum = if tnum == stnum + then pnum + else lookupProcess' xs stnum + lookupProcess' [] stnum = Debug.Trace.trace ("Warning Thread #" ++ (show stnum) ++ + " on Machine #" ++ (show sMachine) ++ "is not assigned to a Process: Defaulting to 1") 1 +lookupProcess [] sMachine sThread = Debug.Trace.trace ("Warning Thread #" ++ (show sThread) ++ + " on Machine #" ++ (show sMachine) ++ "is not assigned to a Process: Defaulting to 1") 1 + +-------------------------------------------------------------------------------- +-- Legacy Code +-------------------------------------------------------------------------------- + + +-- legacy code of old haskell EdenTV +-- modified to work with new Tracefile Format +insertEvent :: (Timestamp -> E.Seconds) -> Lookuptable -> (E.MachineID, Event) -> E.OpenEvents -> Bool -> E.OpenEvents +insertEvent convertTimestamp lutable (mId, Event{time, spec}) + oldEvents@(oEvts@(ms,ps,ts),mts,ocMsgs,(minTime,maxTime,nP,maxLD)) ignoreMessages + | isMsgEvent && ignoreMessages = oldEvents + | isMsgEvent = newMsgEvents `seq` ((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) + +{- SendReceiveLocalMessage{ + mesTag, + senderProcess, + senderThread, + receiverProcess, + receiverInport} -> trace "insertEvent SRLM (unhandled)" (False, undefined, undefined, undefined) --will be something like (True, newOPenMEssageList, nms, nps) + --unfinished ... #todo + -} + _ -> (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} -> res where + res | status == ThreadFinished = (True, newEvents (E.KillThread (convertTimestamp time))) + | status `elem` blockList = trace (show status) (True, newEvents (E.BlockThread (convertTimestamp time) (0) (E.BlockReason))) -- ####hack inport? reason? + | otherwise = (True, newEvents (E.SuspendThread (convertTimestamp time))) + blockList = [ThreadBlocked,BlockedOnMVar,BlockedOnBlackHole,BlockedOnDelay,BlockedOnSTM, + BlockedOnDoProc,BlockedOnMsgThrowTo,ThreadMigrating,BlockedOnMsgGlobalise,BlockedOnBlackHoleOwnedBy 0] + 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] -> + EventInfo -> ([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) + SendReceiveLocalMessage {} -> ((i, aP, bP, (p, s+1, 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) + SendReceiveLocalMessage {} -> ((i, aT, bT, (t, s+1, 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 == E.Head = let ohl' = addHeadMsg (sp, out, rp, inp) headMessages + in seq ohl' (openMsgList, closedMessages, partMsgs,(ohl', hSize, closedHeads)) + | tag == E.DataMes = let (ohl,chl,hs') = searchHeadMsg (sp,out,rp,inp) headMessages + in cml `seq` chl `seq` (oml,cml,partMsgs,(ohl,max hs' hSize,chl)) + | tag == E.RFork = 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 sp newMessage openMsgList closedMessages + + 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) + + +-- insertClosedMessage :: Message -> OpenMessage -> OpenMessageList +-- insertClosedMessage m@(SendReceiveLocalMessage {}) (openMsgList,closedMessages,partMsgs,(headMessages,hSize,closedHeads)) = todo + + +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 + 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/RTSEventsParserOld.lhs b/RTSEventsParserOld.lhs new file mode 100644 --- /dev/null +++ b/RTSEventsParserOld.lhs @@ -0,0 +1,1009 @@ +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} diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/TinyZipper.lhs b/TinyZipper.lhs new file mode 100644 --- /dev/null +++ b/TinyZipper.lhs @@ -0,0 +1,31 @@ +This is -*- Literate Haskell -*- + +Our own wrappers around zip file handling in Haskell. + +Written by Oleg Lobachev, 2010. + +\begin{code} +module TinyZipper where + +import Prelude hiding (readFile) +import Codec.Archive.Zip +import Data.ByteString.Lazy (ByteString, readFile) +import System.IO.Unsafe (unsafePerformIO) -- yeah! +import Data.Maybe +\end{code} + +We need to read files from a zip archive, if possible: without unpacking it. + +Ideal is something like String (with zip file name) -> [FileContents]. + +\begin{code} +type FileContents = ByteString +readZip :: FilePath -> IO (Either String [FileContents]) +readZip filePath = do + zippedFile <- readFile filePath + let archive = toArchive zippedFile + fileList = filesInArchive archive + entries = catMaybes $ zipWith (findEntryByPath) fileList (repeat archive) + files = map (fromEntry) entries + return $ seq files $ Right files +\end{code} diff --git a/edentv.cabal b/edentv.cabal new file mode 100644 --- /dev/null +++ b/edentv.cabal @@ -0,0 +1,54 @@ +name: edentv +version: 4.1.0.0 +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 + (eventlog files) of Eden program runs. It is similar to + (and precedes) threadscope. However, it has been designed + to visualize not just threads, but also different + machines, processes, and messages between processes. + EdenTV can show you what has happened during the + execution of your program. This is very helpful to + optimize parallel programs. +license: GPL-3 +license-file: gpl.txt +homepage: http://www.mathematik.uni-marburg.de/~eden +author: Jost Berthold, Mischa Dieterle, Thomas Horstmeyer, Bernhard Pickenbrock, Tobias Sauerwein, Bjoern Struckmeier +maintainer: Eden group +copyright: Copyright (C) 2005-2012 Phillips Universitaet Marburg +category: Development, Eden, Profiling, Trace +build-type: Simple +cabal-version: >=1.6 + +data-files: edentv.glade + +source-repository head + type: git + location: git://james.mathematik.uni-marburg.de/edentv-hs.git + +executable edentv + main-is: EdenTV.hs + + build-depends: base == 4.*, + containers, + bytestring, + binary, + mtl, + filepath, + directory, + zip-archive, + gtk >= 0.12, + cairo >= 0.12, + glade >= 0.12, + array, + ghc-events-parallel >= 0.4 + + GHC-Options: -rtsopts + + other-modules: EdenTvBasic + EdenTvInteract + EdenTvType + EdenTvViewer + RTSEventsParser + RTSEventsParserOld + TinyZipper diff --git a/edentv.glade b/edentv.glade new file mode 100644 --- /dev/null +++ b/edentv.glade @@ -0,0 +1,3112 @@ + + + + + + + + + + + True + EdenTV + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + False + False + gtk-network + True + False + False + GDK_WINDOW_TYPE_HINT_NORMAL + GDK_GRAVITY_NORTH_WEST + True + False + + + + True + False + 0 + + + + True + GTK_PACK_DIRECTION_LTR + GTK_PACK_DIRECTION_LTR + + + + True + _File + True + + + + + + + True + _Open + True + + + + + + True + gtk-open + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + Open Without Messages + True + + + + + + + + True + + + + + + True + _Quit + True + + + + + + True + gtk-quit + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + + + + True + _Colors + True + + + + + + + + True + Color _Templates + True + + + + + True + gtk-color-picker + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + True + Default _Colors + True + True + + + + + + + True + Default _b/w + True + False + default_colors + + + + + + + + + + + + True + Set Colors + True + + + + + + + + + + + True + _Windows + True + + + + + + + + True + Refresh All + True + + + + + True + gtk-refresh + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + + + + True + _Help + True + + + + + + + True + _About + True + + + + + True + gtk-info + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + + + 0 + False + False + + + + + + True + GTK_ORIENTATION_HORIZONTAL + GTK_TOOLBAR_BOTH + True + False + + + + True + _Open + True + gtk-open + True + True + False + + + + + False + True + + + + + + True + True + True + True + + + False + False + + + + + + True + True + True + False + + + + True + 2 + 4 + False + 0 + 0 + + + + True + suspended color + True + False + suspended color + True + + + 1 + 2 + 1 + 2 + fill + + + + + + + 20 + True + gtk-media-play + 1 + 1 + 0.5 + 0 + 0 + + + 0 + 1 + 0 + 1 + fill + + + + + + 20 + True + gtk-media-pause + 1 + 1 + 0.5 + 0 + 0 + + + 0 + 1 + 1 + 2 + fill + fill + + + + + + True + running color + True + False + running color + True + + + 1 + 2 + 0 + 1 + fill + + + + + + + True + idle color + True + False + idle color + True + + + 3 + 4 + 1 + 2 + fill + + + + + + + True + blocked color + True + False + blocked color + True + + + 3 + 4 + 0 + 1 + fill + + + + + + + 20 + True + gtk-media-stop + 1 + 1 + 0.5 + 0 + 0 + + + 2 + 3 + 0 + 1 + fill + + + + + + 20 + True + gtk-execute + 1 + 1 + 0.5 + 0 + 0 + + + 2 + 3 + 1 + 2 + fill + fill + + + + + + + False + False + + + + + 0 + False + False + + + + + + + + True + Trace + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + 900 + 600 + True + True + gtk-zoom-fit + True + False + False + GDK_WINDOW_TYPE_HINT_NORMAL + GDK_GRAVITY_NORTH_WEST + True + False + + + + True + False + 0 + + + + True + GTK_PACK_DIRECTION_LTR + GTK_PACK_DIRECTION_LTR + + + + True + _File + True + + + + + + + True + _Open + True + + + + + + True + gtk-open + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + Open Without Messages + True + + + + + + + + True + _Save + True + + + + + + True + gtk-save + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + + + + + + True + Close _Window + True + + + + + + True + gtk-close + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + _Quit Application + True + + + + + + True + gtk-quit + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + + + + True + _View + True + + + + + + + True + _Show + True + + + + + True + gtk-execute + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + True + All _Machines + True + True + + + + + + + + True + All _Processes + True + False + showAllMachines + + + + + + + + True + All _Threads + True + False + showAllMachines + + + + + + + + True + All Processes p. Machines + True + False + showAllMachines + + + + + + + + + + + + True + Show _Marker + True + False + + + + + + + + True + Show Block Messages + False + + + + + + True + Show Startup-Marker + False + + + + + + True + Hide Startup-Phase + False + + + + + + True + + + + + + True + Show Data Messages + True + + + + + + True + Show System Messages + True + + + + + + True + + + + + + True + Sort + True + + + + + + True + gtk-sort-ascending + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + + True + + + + + + True + Zoom + True + + + + True + gtk-zoom-in + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + True + Zoom _in + True + + + + + + True + gtk-zoom-in + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + Zoom _out + True + + + + + + True + gtk-zoom-out + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + + + + + + True + Total View + True + + + + + + True + gtk-zoom-fit + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + + + + True + refresh view + _Refresh + True + + + + + + True + gtk-refresh + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + Show Range + True + + + + + + True + Configure Ticks + True + + + + + + + + + + + True + _Windows + True + + + + + + + + True + Refresh All + True + + + + + True + gtk-refresh + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + + + + True + _Help + True + + + + + + + True + _About + True + + + + + True + gtk-info + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + + + 0 + False + False + + + + + + True + GTK_ORIENTATION_HORIZONTAL + GTK_TOOLBAR_BOTH + True + True + + + + True + Save + True + gtk-save + True + True + False + + + + False + True + + + + + + True + True + True + True + + + False + False + + + + + + True + True + True + False + + + + True + 2 + 2 + False + 0 + 0 + + + + True + Machines +Processes +Threads +Processes/Machines + False + True + + + 0 + 2 + 1 + 2 + + + + + + True + 4 + gtk-execute + 0.5 + 0.5 + 0 + 0 + + + 0 + 1 + 0 + 1 + fill + fill + + + + + + True + View: + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 1 + 2 + 0 + 1 + + + + + + + + False + False + + + + + + True + True + True + True + + + False + False + + + + + + True + Info + True + gtk-info + True + True + False + + + + False + True + + + + + + True + Configure Msgs. + True + gtk-network + True + True + False + + + False + False + + + + + + True + Messages + True + gtk-copy + True + True + False + False + + + False + False + + + + + + True + Startup Sync. + True + gtk-goto-first + True + True + False + False + + + False + False + + + + + + True + True + True + True + + + False + False + + + + + True + True + True + False + + + True + 2 + 2 + False + 0 + 0 + + + + True + up + Up + True + gtk-go-up + True + True + False + + + + 0 + 1 + 1 + 2 + fill + + + + + + True + down + Down + True + gtk-go-down + True + True + False + + + + 1 + 2 + 1 + 2 + fill + fill + + + + + + True + Sort: + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 2 + 0 + 1 + fill + + + + + + + + False + False + + + + + + True + True + True + True + + + False + False + + + + + + True + True + True + False + + + + True + 2 + 2 + False + 0 + 0 + + + + True + + True + gtk-zoom-in + True + True + False + + + 0 + 1 + 1 + 2 + fill + + + + + + True + + True + gtk-zoom-out + True + True + False + + + 1 + 2 + 1 + 2 + fill + fill + + + + + + True + Horizontal: + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 2 + 0 + 1 + fill + + + + + + + + False + False + + + + + + True + True + True + True + + + False + False + + + + + + True + True + True + False + + + + True + 2 + 2 + False + 0 + 0 + + + + True + Vertical: + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 2 + 0 + 1 + fill + + + + + + + True + gtk-zoom-in + True + True + False + + + 0 + 1 + 1 + 2 + fill + + + + + + True + gtk-zoom-out + True + True + False + + + 1 + 2 + 1 + 2 + fill + fill + + + + + + + False + False + + + + + 0 + False + False + + + + + + True + True + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_SHADOW_NONE + GTK_CORNER_TOP_LEFT + + + + True + GTK_SHADOW_IN + + + + True + GDK_BUTTON1_MOTION_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + GDK_EXTENSION_EVENTS_ALL + + + + + + + 0 + True + True + + + + + + True + True + + + 0 + False + False + + + + + + + + True + Saving file + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + False + False + gtk-dialog-error + True + False + False + GDK_WINDOW_TYPE_HINT_DIALOG + GDK_GRAVITY_NORTH_WEST + True + False + True + + + + + True + False + 0 + + + + True + GTK_BUTTONBOX_END + + + + True + True + True + gtk-ok + True + GTK_RELIEF_NORMAL + True + -5 + + + + + 0 + False + True + GTK_PACK_END + + + + + + True + False + 0 + + + + True + gtk-dialog-error + 6 + 0.5 + 0.5 + 0 + 0 + + + 10 + False + False + + + + + + True + Filetype unknown! + +Use one of png, bmp, jpeg. + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + True + False + + + + + 0 + True + False + + + + + + + + True + Info + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_MOUSE + False + 400 + 300 + True + True + gtk-info + True + False + False + GDK_WINDOW_TYPE_HINT_NORMAL + GDK_GRAVITY_NORTH_WEST + True + False + + + + 5 + True + True + True + True + GTK_POS_TOP + False + False + + + + True + True + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_SHADOW_NONE + GTK_CORNER_TOP_LEFT + + + + True + GTK_SHADOW_IN + + + + True + label14 + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0 + 5 + 3 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + + + + + False + True + + + + + + True + Overview + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + tab + + + + + + True + True + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + True + False + True + True + False + False + False + + + + + False + True + + + + + + True + Machines + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + tab + + + + + + True + True + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + True + False + True + True + False + False + False + + + + + False + True + + + + + + True + Processes + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + tab + + + + + + True + True + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + True + False + True + True + False + False + False + + + + + False + True + + + + + + True + Threads + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + tab + + + + + + + + + + + + + + + + + + True + Configure Messages + mouse + 400 + 300 + True + gtk-info + + + True + True + + + True + vertical + + + 50 + True + + + Store + True + True + True + + + 0 + + + + + True + vertical + + + All (send) + True + True + True + + + 0 + + + + + None (send) + True + True + True + + + 1 + + + + + 1 + + + + + True + vertical + + + All (receive) + True + True + True + + + 0 + + + + + None (receive) + True + True + True + + + 1 + + + + + + 2 + + + + + False + False + 0 + + + + + True + True + automatic + automatic + + + True + True + + + + + 1 + + + + + + + True + Machines + + + False + tab + + + + + True + vertical + + + 50 + True + + + Store + True + True + True + + + 0 + + + + + True + vertical + + + All (send) + True + True + True + + + 0 + + + + + None (send) + True + True + True + + + 1 + + + + + 1 + + + + + True + vertical + + + All (receive) + True + True + True + + + 0 + + + + + None (receive) + True + True + True + + + 1 + + + + + 2 + + + + + False + 0 + + + + + True + True + automatic + automatic + + + True + True + + + + + 1 + + + + + 1 + + + + + True + Processes + + + 1 + False + tab + + + + + + + + + tab + + + + + + + + + + True + vertical + + + 50 + True + + + True + vertical + + + 21 + True + Draw Tick every x Seconds: + + + False + 0 + + + + + True + True + ● + + + False + 1 + + + + + 0 + + + + + True + vertical + + + 21 + True + Draw Time every x tick: + + + False + False + 0 + + + + + True + True + ● + + + False + 1 + + + + + 1 + + + + + False + False + 0 + + + + + + Auto + True + True + False + True + + + + + + Set Ticks + 26 + True + True + True + + + False + False + 1 + + + + + + + + + + True + vertical + + + 50 + True + + + True + vertical + + + 21 + True + Start Time: + + + False + 0 + + + + + True + True + ● + + + False + 1 + + + + + 0 + + + + + True + vertical + + + 21 + True + End Time: + + + False + False + 0 + + + + + True + True + ● + + + False + 1 + + + + + 1 + + + + + False + False + 0 + + + + + Show Range + 26 + True + True + True + + + False + False + 1 + + + + + + + + 5 + Set Colors + False + normal + True + False + preferences-other + GTK_WINDOW_TOPLEVEL + + + True + 2 + + + True + 2 + 2 + 3 + 3 + + + True + 0 + + + True + 12 + + + True + 4 + 2 + + + True + 0 + 4 + Running: + + + + + True + 0 + 4 + Suspended: + + + 1 + 2 + + + + + True + 0 + 4 + Blocked: + + + 2 + 3 + + + + + True + 0 + 4 + Idle: + + + 3 + 4 + + + + + True + True + True + True + Running + Running + #000000000000 + True + + + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Suspended + Suspended + #000000000000 + True + + + 1 + 2 + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Blocked + Blocked + #000000000000 + True + + + 1 + 2 + 2 + 3 + GTK_FILL + + + + + + True + True + True + True + Idle + Idle + #000000000000 + True + + + 1 + 2 + 3 + 4 + GTK_FILL + + + + + + + + + + True + <b>Status</b> + True + + + label_item + + + + + + + True + 0 + + + True + 12 + + + True + 5 + 2 + + + True + 0 + 4 + System-Messages: + + + + + True + 0 + 4 + Head-Messages: + + + 1 + 2 + + + + + True + 0 + 4 + Data-Messages: + + + 2 + 3 + + + + + True + 0 + 4 + Block-Messages: + + + 3 + 4 + + + + + True + 0 + 4 + Receive-Phase: + + + 4 + 5 + + + + + True + True + True + True + System-Messages + System-Messages + #000000000000 + True + + + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Head-Messages + Head-Messages + #000000000000 + True + + + 1 + 2 + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Data-Messages + Data-Messages + #000000000000 + True + + + 1 + 2 + 2 + 3 + GTK_FILL + + + + + + True + True + True + True + Block-Messages + Block-Messages + #000000000000 + False + + + 1 + 2 + 3 + 4 + GTK_FILL + + + + + + True + True + True + True + Receive-Phase + Receive-Phase + #000000000000 + True + + + 1 + 2 + 4 + 5 + GTK_FILL + + + + + + + + + + True + <b>Messages</b> + True + + + label_item + + + + + 1 + 2 + + + + + True + 0 + + + True + 12 + + + True + 3 + 2 + + + True + 0 + 4 + Marker-Line: + + + + + True + 0 + 4 + Marker-Label: + + + 1 + 2 + + + + + True + 0 + 4 + Startup-Marker: + + + 2 + 3 + + + + + True + True + True + True + Marker-Line + Marker-Line + #000000000000 + True + + + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Marker-Label + Marker-Label + #000000000000 + True + + + 1 + 2 + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Startup-Marker + Startup-Marker + #000000000000 + True + + + 1 + 2 + 2 + 3 + GTK_FILL + + + + + + + + + + True + <b>Marker</b> + True + + + label_item + + + + + 1 + 2 + + + + + True + 0 + + + True + 12 + + + True + 3 + 2 + + + True + 0 + 4 + Background: + + + + + True + 0 + 4 + Axes: + + + 1 + 2 + + + + + True + 0 + 4 + Axes-Label: + + + 2 + 3 + + + + + True + True + True + True + Background-Color + Background-Color + #000000000000 + True + + + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Axes + Axes + #000000000000 + True + + + 1 + 2 + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Axes-Label + Axes-Label + #000000000000 + True + + + 1 + 2 + 2 + 3 + GTK_FILL + + + + + + + + + + True + <b>Chart</b> + True + + + label_item + + + + + 1 + 2 + 1 + 2 + + + + + 1 + + + + + True + end + + + gtk-cancel + True + True + True + True + + + False + False + 0 + + + + + gtk-ok + -3 + True + True + True + True + + + False + False + 1 + + + + + False + end + 0 + + + + + + diff --git a/gpl.txt b/gpl.txt new file mode 100644 --- /dev/null +++ b/gpl.txt @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +.