diff --git a/EdenTV.hs b/EdenTV.hs --- a/EdenTV.hs +++ b/EdenTV.hs @@ -1,5 +1,6 @@ -{- 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 +{- The Eden Trace Viewer (or simply EdenTV) is a tool that can generate diagram + to visualize the behaviour of Eden programs. + Copyright (C) 2005-2014 Philipps 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 @@ -21,7 +22,7 @@ import Graphics.UI.Gtk.Gdk.Events import Graphics.UI.Gtk.Windows.MessageDialog -import Graphics.UI.Gtk.Glade +import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.General.StockItems import Graphics.Rendering.Cairo hiding (version) @@ -43,6 +44,7 @@ import System.IO import Data.List import RTSEventsParser +import System.IO.Unsafe import Debug.Trace @@ -50,41 +52,38 @@ getDataFileName ) -- this file is generated by cabal import qualified Paths_edentv -import Data.Version(versionBranch) -- to extract version from there +import Data.Version(showVersion) -- 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 - +{-# NOINLINE uiFile #-} +uiFile = unsafePerformIO $ do + let filename = "edentv.ui" -- change only here if desired + gladefile <- getDataFileName filename + inDataDir <- doesFileExist gladefile + inLocalDir <- doesFileExist filename + if inDataDir + then return gladefile -- prefer file in data dir + else if inLocalDir + then return filename -- otherwise assume local + else error "No UI file found in local or shared dir" -- 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 +-- using Gtk.Builder, which will throw exceptions on errors (could catch..) +edentvGladeFile :: [String] -> IO Builder +edentvGladeFile objs + = do b <- builderNew + if null objs + then builderAddFromFile b uiFile + else builderAddObjectsFromFile b uiFile objs + -- in case of xml problems: let it crash! + return b -version,subversion :: String --- version = "4.0" -version = show (head ( versionBranch Paths_edentv.version )) -subversion = "0" +version :: String +version = showVersion Paths_edentv.version regpath = "/apps/unimar/edentv/lastPath" @@ -125,7 +124,6 @@ -- 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 () @@ -184,8 +182,15 @@ 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 + let --((m,p,t),mt,(maxStartupTimeInSeconds, _), (msgs,amsgs,hmsgs,pTree,rcvtimes),(minT,maxT,maxST,_,maxD),(nm,allP,nt)) = traces + nm = noOfMachines traces + np = length $ processlist traces + allP = noOfProcesses traces + nt = noOfThreads traces + (msgs,_,hmsgs,_,_) = messagelist traces + minT = min_t traces + maxT = max_t traces + maxST = max_t_diff traces strRunT = formatFloat (maxT - minT) allMsgs = sum (map (\ (_,_,_,d) -> d) hmsgs) + length msgs time' <- getCPUTime @@ -194,55 +199,53 @@ 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\"!" + gladeXML <- edentvGladeFile ["EdTVTrace", "accelgroup1","liststore1"] + -- get access to the widgets from gladefile - window <- xmlGetWidget gladeXML castToWindow "EdTVTrace" - pic <- xmlGetWidget gladeXML castToDrawingArea "drawingarea" + window <- builderGetObject gladeXML castToWindow "EdTVTrace" + pic <- builderGetObject gladeXML castToDrawingArea "drawingarea" win <- widgetGetDrawWindow pic - viewport <- xmlGetWidget gladeXML castToViewport "viewport" - scrldWnd <- xmlGetWidget gladeXML castToScrolledWindow "scrolledwindow" + viewport <- builderGetObject gladeXML castToViewport "viewport" + scrldWnd <- builderGetObject 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" + buttonLocalNull <- builderGetObject gladeXML castToToggleToolButton "localNull" + buttonMessages <- builderGetObject gladeXML castToToggleToolButton "messages" + buttonInfo <- builderGetObject gladeXML castToToolButton "infoButton" + buttonConfMsgs <- builderGetObject gladeXML castToToolButton "msgs-relations" + traceZoomInH <- builderGetObject gladeXML castToToolButton "zoomInH" + traceZoomInV <- builderGetObject gladeXML castToToolButton "zoomInV" + traceZoomIn <- builderGetObject gladeXML castToMenuItem "zoom_in" + traceZoomOutH <- builderGetObject gladeXML castToToolButton "zoomOutH" + traceZoomOutV <- builderGetObject gladeXML castToToolButton "zoomOutV" + traceZoomOut <- builderGetObject gladeXML castToMenuItem "zoom_out" + moveUp <- builderGetObject gladeXML castToToolButton "go_up" + moveDown <- builderGetObject gladeXML castToToolButton "go_down" + viewselect <- builderGetObject gladeXML castToComboBox "viewselect" + buttonToPng <- builderGetObject gladeXML castToToolButton "saveAsPng" - winm <- xmlGetWidget gladeXML castToMenu "windows_menu" - menuClose <- xmlGetWidget gladeXML castToMenuItem "close" - menuQuit <- xmlGetWidget gladeXML castToMenuItem "tquit" - menuOpen <- xmlGetWidget gladeXML castToMenuItem "topen" + winm <- builderGetObject gladeXML castToMenu "windows_menuX" + menuClose <- builderGetObject gladeXML castToMenuItem "close" + menuQuit <- builderGetObject gladeXML castToMenuItem "tquit" + menuOpen <- builderGetObject 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" + menuOpenWithoutMsgs <- builderGetObject gladeXML castToMenuItem "topenWithoutMsgs" + menuSave <- builderGetObject gladeXML castToMenuItem "save" + menuAllM <- builderGetObject gladeXML castToRadioMenuItem "showAllMachines" + menuAllP <- builderGetObject gladeXML castToRadioMenuItem "showAllProcesses" + menuAllGP <- builderGetObject gladeXML castToRadioMenuItem "showAllGProcesses" + menuAllT <- builderGetObject gladeXML castToRadioMenuItem "showAllThreads" + menuSort <- builderGetObject gladeXML castToMenuItem "sort" + menuShowRange <- builderGetObject gladeXML castToMenuItem "edit_range" + menuEditTicks <- builderGetObject gladeXML castToMenuItem "edit_ticks" + menuTotal <- builderGetObject gladeXML castToMenuItem "totalView" + menuMarker <- builderGetObject gladeXML castToCheckMenuItem "show_marker" + menuStartupMarker <- builderGetObject gladeXML castToCheckMenuItem "show_startup" + menuHideStartupPhase <- builderGetObject gladeXML castToCheckMenuItem "hide_startup_phase" + menuBlockMsgs <- builderGetObject gladeXML castToCheckMenuItem "show_blockmsgs" + menuDataMsgs <- builderGetObject gladeXML castToCheckMenuItem "show_data_messages" + menuSystemMsgs <- builderGetObject gladeXML castToCheckMenuItem "show_system_messages" + menuRefresh <- builderGetObject gladeXML castToMenuItem "refresh" + menuAbout <- builderGetObject gladeXML castToMenuItem "tabout" -- add labels for tool-items so that a label is displayed in the toolbar overflow menu addMenuLabelToToolItem gladeXML "toolitemViewSelect" "Select View" @@ -251,10 +254,10 @@ addMenuLabelToToolItem gladeXML "toolitemZoomV" "Zoom Vertical" -- the statusbar: - statusbar <- xmlGetWidget gladeXML castToStatusbar "traceStatusBar" + statusbar <- builderGetObject gladeXML castToStatusbar "traceStatusBar" let statusString = " Runtime: " ++ strRunT ++ "s, " ++ show nm ++ " Machines, " ++ - show allP ++ " Processes, " ++ + show allP ++ " Processes, " ++ show nt ++ " Threads, " ++ show (length msgs + (length hmsgs)) ++ " Conversations, " ++ show allMsgs ++ " Messages" @@ -263,9 +266,9 @@ 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) + let listOfMachineIds = map getIdM (machinelist traces) + listOfProcessIds = map getIdP (processlist traces) + st <- newMVar (initMatrix nm np nt listOfMachineIds listOfProcessIds filename ignoreMessages) -- filename in titlebar let winTitle = "Trace " ++ (takeFileName filename) windowSetTitle window winTitle @@ -404,11 +407,11 @@ 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" + gladeXML <- edentvGladeFile ["range_win", "accelgroup1"] + rangeDlg <- builderGetObject gladeXML castToWindow "range_win" + spinBegin <- builderGetObject gladeXML castToSpinButton "range_begin" + spinEnd <- builderGetObject gladeXML castToSpinButton "range_end" + buttonShow <- builderGetObject gladeXML castToButton "show_intervall" viewRange <- viewportGetHAdjustment viewport @@ -426,7 +429,7 @@ hideStartupPhase <- checkMenuItemGetActive menuHideStartupPhase let minT' - | hideStartupPhase = maxStartupTimeInSeconds + | hideStartupPhase = maxStartup traces | otherwise = minT let getTimeFromPosition x | useDiff = posToTime minT' (maxT+maxST) ulx lrx x @@ -489,12 +492,12 @@ 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" + gladeXML <- edentvGladeFile ["ticks_win", "accelgroup1"] + ticksDlg <- builderGetObject gladeXML castToWindow "ticks_win" + ticksSkip <- builderGetObject gladeXML castToSpinButton "ticks_skip" + ticksMark <- builderGetObject gladeXML castToSpinButton "ticks_mark" + buttonSet <- builderGetObject gladeXML castToButton "set_ticks" + buttonAuto <- builderGetObject gladeXML castToCheckButton "auto_ticks" state <- readMVar st let useDiff = locTime state @@ -643,8 +646,8 @@ return False ) onToolButtonClicked buttonInfo ( do -- show traceinformation - (Just gladeXML) <- edentvGladeFile (Just "info_win") Nothing - infoDlg <- xmlGetWidget gladeXML castToWindow "info_win" + gladeXML <- edentvGladeFile ["info_win", "accelgroup1"] + infoDlg <- builderGetObject gladeXML castToWindow "info_win" windowSetTitle infoDlg ("Info - " ++ filename) windowSetTransientFor infoDlg window showTraceInfo traces filename (statusString {- ++ "\n(" @@ -652,8 +655,8 @@ ++ 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" + gladeXML <- edentvGladeFile ["confmsgs_win", "accelgroup1"] + confDlg <- builderGetObject gladeXML castToWindow "confmsgs_win" v <- comboBoxGetActive viewselect buildConfMsg st gladeXML pic v @@ -912,11 +915,8 @@ 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" + gladeXML <- edentvGladeFile ["dlg_err_save_filetype", "accelgroup1"] + dlg <- builderGetObject 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 @@ -950,34 +950,31 @@ 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\"!" + gladeXML <- edentvGladeFile ["EdTVMain", "accelgroup1"] + -- load Widgets from Glade-description -- main window - windowMain <- xmlGetWidget gladeXML castToWindow "EdTVMain" + windowMain <- builderGetObject 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" + iCB <- builderGetObject gladeXML castToColorButton "idle_colorbutton" + rCB <- builderGetObject gladeXML castToColorButton "running_colorbutton" + sCB <- builderGetObject gladeXML castToColorButton "suspended_colorbutton" + bCB <- builderGetObject gladeXML castToColorButton "blocked_colorbutton" -- other toolbar entries - toolbarOpen <- xmlGetWidget gladeXML castToToolButton "toolbar_Open" + toolbarOpen <- builderGetObject gladeXML castToToolButton "toolbar_Open" -- menu entries - menuFileOpen <- xmlGetWidget gladeXML castToMenuItem "menuFile_Open" - menuFileOpenWithoutMsgs <- xmlGetWidget gladeXML castToMenuItem "menuFile_OpenWithoutMsgs" - menuFileExit <- xmlGetWidget gladeXML castToMenuItem "menuFile_Quit" + menuFileOpen <- builderGetObject gladeXML castToMenuItem "menuFile_Open" + menuFileOpenWithoutMsgs <- builderGetObject gladeXML castToMenuItem "menuFile_OpenWithoutMsgs" + menuFileExit <- builderGetObject gladeXML castToMenuItem "menuFile_Quit" - cCol <- xmlGetWidget gladeXML castToRadioMenuItem "default_colors" - cBW <- xmlGetWidget gladeXML castToRadioMenuItem "default_colBW" - menuOptsSetColors <- xmlGetWidget gladeXML castToMenuItem "menuOptions_SetColors" + cCol <- builderGetObject gladeXML castToRadioMenuItem "default_colors" + cBW <- builderGetObject gladeXML castToRadioMenuItem "default_colBW" + menuOptsSetColors <- builderGetObject gladeXML castToMenuItem "menuOptions_SetColors" - menuWindows <- xmlGetWidget gladeXML castToMenu "windows_menu" - refreshWins <- xmlGetWidget gladeXML castToMenuItem "refresh_all" - menuHelpAbout <- xmlGetWidget gladeXML castToMenuItem "menuHelp_About" + menuWindows <- builderGetObject gladeXML castToMenu "windows_menu" + refreshWins <- builderGetObject gladeXML castToMenuItem "refresh_all" + menuHelpAbout <- builderGetObject gladeXML castToMenuItem "menuHelp_About" -- menuSetTitle menuWindows "active Documents" -- initial state with default colors @@ -1087,8 +1084,8 @@ -- 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" + gladeXML <- edentvGladeFile ["dialogColors","accelgroup1"] + colorsDialog <- builderGetObject gladeXML castToDialog "dialogColors" globalState <- readMVar edentvState updateDialogFromState gladeXML (colors globalState) @@ -1107,23 +1104,23 @@ return () where - updateDialogFromState :: GladeXML -> Colors -> IO () + updateDialogFromState :: Builder -> 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 :: Builder -> Colors -> ColorMapping -> IO () updateColorButtonById gladeXML colors (id, getter, _) = do let color = getter colors - colorButton <- xmlGetWidget gladeXML castToColorButton id + colorButton <- builderGetObject 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 :: Builder -> Colors -> IO (Colors) updateStateFromDialog gladeXML colors = do newColors <- mapM getColor colorMapping let colors' = foldr applyColor colors $ zip colorMapping newColors @@ -1136,9 +1133,9 @@ getColor :: ColorMapping -> IO (ColorRGBA) getColor (id, _, _) = getColorFromColorButtonById gladeXML id - getColorFromColorButtonById :: GladeXML -> String -> IO (ColorRGBA) + getColorFromColorButtonById :: Builder -> String -> IO (ColorRGBA) getColorFromColorButtonById gladeXML id = do - colorButton <- xmlGetWidget gladeXML castToColorButton id + colorButton <- builderGetObject gladeXML castToColorButton id getColorFromColorButton colorButton -- Stores new colors in the state, updates the main windows color buttons and @@ -1164,9 +1161,9 @@ return (RGBA {rgbColor = rgbColor, alpha = alpha}) -addMenuLabelToToolItem :: GladeXML -> String -> String -> IO () +addMenuLabelToToolItem :: Builder -> String -> String -> IO () addMenuLabelToToolItem gladeXML toolItemId labelCaption - = do toolItem <- xmlGetWidget gladeXML castToToolItem toolItemId + = do toolItem <- builderGetObject gladeXML castToToolItem toolItemId label <- imageMenuItemNewWithLabel labelCaption let labelId = toolItemId ++ "Label" toolItemSetProxyMenuItem toolItem labelId label @@ -1187,10 +1184,30 @@ dlg `aboutDialogSetName` "EdenTV" dlg `aboutDialogSetVersion` version dlg `aboutDialogSetComments` "Trace Viewer for Eden Trace Files" - dlg `aboutDialogSetLicense` Nothing + dlg `aboutDialogSetLicense` (Just gpl3) 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 `aboutDialogSetAuthors` ["Bjoern Struckmeier, Bernhard Pickenbrock, ", + "Tobias Sauerwein, Mischa Dieterle, ", + "Thomas Horstmeyer, Jost Berthold", + "","Betreuung:","Prof. Dr. Rita Loogen"] dlg `afterResponse` (\_ -> widgetDestroy dlg) widgetShowAll dlg +gpl3 = unlines + ["The Eden Trace Viewer (or simply EdenTV) is a tool that can generate" + ,"diagrams to visualize the behaviour of Eden programs." + ,"Copyright (C) 2005-2014 Philipps 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" + ] diff --git a/EdenTvBasic.hs b/EdenTvBasic.hs --- a/EdenTvBasic.hs +++ b/EdenTvBasic.hs @@ -1,5 +1,6 @@ -{- 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 +{- 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 Philipps 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 diff --git a/EdenTvInteract.hs b/EdenTvInteract.hs --- a/EdenTvInteract.hs +++ b/EdenTvInteract.hs @@ -1,5 +1,6 @@ -{- 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 +{- The Eden Trace Viewer (or simply EdenTV) is a tool that can generate + diagrams to visualize the behaviour of Eden programs. + Copyright (C) 2005-2014 Philipps 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 @@ -16,7 +17,7 @@ -} {-# OPTIONS_GHC -cpp #-} --- JB first draft: commented out features missing in Gtk2hs-0.9.11 + module EdenTvInteract where import EdenTvType @@ -24,9 +25,7 @@ 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.Builder import Graphics.UI.Gtk.ModelView.TreeView import Graphics.UI.Gtk.ModelView.ListStore import Graphics.Rendering.Cairo @@ -44,24 +43,24 @@ 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)) + 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 :: MVar ViewerState -> Builder -> 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" + confM <- builderGetObject glade castToTreeView "confM" + confP <- builderGetObject glade castToTreeView "confP" + noteb <- builderGetObject glade castToNotebook "notebook1X" -- Machine checkBoxes - mId <- treeViewColumnNew + mId <- treeViewColumnNew treeViewColumnSetTitle mId "machine id" treeViewAppendColumn confM mId rendererMId <- cellRendererTextNew @@ -73,7 +72,7 @@ rendererMSnt <- cellRendererToggleNew cellLayoutPackStart mSnt rendererMSnt True - mRcv <- treeViewColumnNew + mRcv <- treeViewColumnNew treeViewColumnSetTitle mRcv "show incoming" treeViewAppendColumn confM mRcv rendererMRcv <- cellRendererToggleNew @@ -107,13 +106,13 @@ cellLayoutSetAttributes mSnt rendererMSnt dataM $ \(_,(_,outb)) -> [ cellToggleActive := outb ] treeViewSetModel confM dataM - treeViewColumnsAutosize confM + 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" + buttonStoreM <- builderGetObject glade castToButton "store_m" + buttonAllInM <- builderGetObject glade castToButton "all_in_m" + buttonAllOutM <- builderGetObject glade castToButton "all_out_m" + buttonNoneInM <- builderGetObject glade castToButton "none_in_m" + buttonNoneOutM <- builderGetObject glade castToButton "none_out_m" onClicked buttonStoreM (do oldState <- takeMVar st val <- listStoreToList dataM @@ -144,7 +143,7 @@ -- Process checkBoxes - pId <- treeViewColumnNew + pId <- treeViewColumnNew treeViewColumnSetTitle pId "process id" treeViewAppendColumn confP pId rendererPId <- cellRendererTextNew @@ -156,7 +155,7 @@ rendererPSnt <- cellRendererToggleNew cellLayoutPackStart pSnt rendererPSnt True - pRcv <- treeViewColumnNew + pRcv <- treeViewColumnNew treeViewColumnSetTitle pRcv "show incoming" treeViewAppendColumn confP pRcv rendererPRcv <- cellRendererToggleNew @@ -181,13 +180,13 @@ cellLayoutSetAttributes pSnt rendererPSnt dataP $ \(_,(_,outb)) -> [ cellToggleActive := outb ] treeViewSetModel confP dataP - treeViewColumnsAutosize confP + 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" + buttonStoreP <- builderGetObject glade castToButton "store_p" + buttonAllInP <- builderGetObject glade castToButton "all_in_p" + buttonAllOutP <- builderGetObject glade castToButton "all_out_p" + buttonNoneInP <- builderGetObject glade castToButton "none_in_p" + buttonNoneOutP <- builderGetObject glade castToButton "none_out_p" onClicked buttonStoreP (do oldState <- takeMVar st val <- listStoreToList dataP @@ -235,48 +234,51 @@ 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: +showTraceInfo :: Events -> String -> String -> Builder -> IO () +showTraceInfo events filename statusString glade = do + --events was: ((ms,ps,ts),mt,mxst,(msgs,_,heads,pt,_),(minT,maxT,_,_,_),_) + let (_, _, _, pt,_) = messagelist events + + -- get access to the widgets: + infoA <- builderGetObject glade castToLabel "infoA" + infoM <- builderGetObject glade castToTreeView "infoM" + infoP <- builderGetObject glade castToTreeView "infoP" + infoT <- builderGetObject 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 + --skelM <- emptyListSkel + mId <- treeViewColumnNew treeViewColumnSetTitle mId "machine id" treeViewAppendColumn infoM mId rendererMId <- cellRendererTextNew cellLayoutPackStart mId rendererMId True - mTime <- treeViewColumnNew + mTime <- treeViewColumnNew treeViewColumnSetTitle mTime "runtime (s)" treeViewAppendColumn infoM mTime rendererMTime <- cellRendererTextNew cellLayoutPackStart mTime rendererMTime True - mPrcs <- treeViewColumnNew + mPrcs <- treeViewColumnNew treeViewColumnSetTitle mPrcs "processes" treeViewAppendColumn infoM mPrcs rendererMPrcs <- cellRendererTextNew cellLayoutPackStart mPrcs rendererMPrcs True - --mTrds <- treeViewColumnNew + --mTrds <- treeViewColumnNew --treeViewColumnSetTitle mTrds "threads" --treeViewAppendColumn infoM mTrds - mSent <- treeViewColumnNew + mSent <- treeViewColumnNew treeViewColumnSetTitle mSent "sent messages" treeViewAppendColumn infoM mSent rendererMSent <- cellRendererTextNew cellLayoutPackStart mSent rendererMSent True - mRcvd <- treeViewColumnNew + mRcvd <- treeViewColumnNew treeViewColumnSetTitle mRcvd "received messages" treeViewAppendColumn infoM mRcvd rendererMRcvd <- cellRendererTextNew @@ -285,8 +287,8 @@ dataM <- listStoreNew [] -- newListStore skelM - -- insert machine data - inspectMachine ms dataM + -- insert machine data + inspectMachine (machinelist events) dataM cellLayoutSetAttributes mId rendererMId dataM $ \row -> [ cellText := machId row ] cellLayoutSetAttributes mTime rendererMTime dataM $ \row -> [ cellText := runtime row ] @@ -294,51 +296,51 @@ cellLayoutSetAttributes mSent rendererMSent dataM $ \row -> [ cellText := numSent row ] cellLayoutSetAttributes mRcvd rendererMRcvd dataM $ \row -> [ cellText := numRcvd row ] - treeViewSetModel infoM dataM - treeViewColumnsAutosize infoM + treeViewSetModel infoM dataM + treeViewColumnsAutosize infoM - -- Process information: - --skelP <- emptyListSkel - pMid <- treeViewColumnNew + -- Process information: + --skelP <- emptyListSkel + pMid <- treeViewColumnNew treeViewColumnSetTitle pMid "on machine" treeViewAppendColumn infoP pMid rendererPMid <- cellRendererTextNew cellLayoutPackStart pMid rendererPMid True - pId <- treeViewColumnNew + pId <- treeViewColumnNew treeViewColumnSetTitle pId "process id" treeViewAppendColumn infoP pId rendererPId <- cellRendererTextNew cellLayoutPackStart pId rendererPId True - pTime <- treeViewColumnNew + pTime <- treeViewColumnNew treeViewColumnSetTitle pTime "runtime (s)" treeViewAppendColumn infoP pTime rendererPTime <- cellRendererTextNew cellLayoutPackStart pTime rendererPTime True - pTrds <- treeViewColumnNew + pTrds <- treeViewColumnNew treeViewColumnSetTitle pTrds "threads" treeViewAppendColumn infoP pTrds rendererPTrds <- cellRendererTextNew cellLayoutPackStart pTrds rendererPTrds True - pSent <- treeViewColumnNew + pSent <- treeViewColumnNew treeViewColumnSetTitle pSent "sent messages" treeViewAppendColumn infoP pSent rendererPSent <- cellRendererTextNew cellLayoutPackStart pSent rendererPSent True - pRcvd <- treeViewColumnNew + pRcvd <- treeViewColumnNew treeViewColumnSetTitle pRcvd "received messages" treeViewAppendColumn infoP pRcvd rendererPRcvd <- cellRendererTextNew cellLayoutPackStart pRcvd rendererPRcvd True - dataP <- listStoreNew [] - - inspectProcess (reverse ps) dataP + dataP <- listStoreNew [] + + inspectProcess (reverse $ processlist events) dataP @@ -350,13 +352,13 @@ cellLayoutSetAttributes pSent rendererPSent dataP $ \row -> [ cellText := numSentP row ] cellLayoutSetAttributes pRcvd rendererPRcvd dataP $ \row -> [ cellText := numRcvdP row ] - treeViewSetModel infoP dataP - treeViewColumnsAutosize infoP + treeViewSetModel infoP dataP + treeViewColumnsAutosize infoP - -- Thread information: - --skelT <- emptyListSkel + -- Thread information: + --skelT <- emptyListSkel tMid <- treeViewColumnNew treeViewColumnSetTitle tMid "on machine" treeViewAppendColumn infoT tMid @@ -381,62 +383,68 @@ rendererTTime <- cellRendererTextNew cellLayoutPackStart tTime rendererTTime True - dataT <- listStoreNew [] + 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 + inspectThread (threadlist events) dataT - treeViewSetModel infoT dataT - treeViewColumnsAutosize infoT + 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 + where mt = starttimeByMachine events - listStoreAppend store (ProcessInfo {machIdP=(show m), - procId=("Process " ++ show i ++ "/" ++ show n), + inspectMachine (m:ms) store = do + let i = getIdM m + listStorePrepend store (MachineInfo {machId=("Machine " ++ show i), + runtime=(formatFloat (getEventTime (head $ eventlistM m) - (getStartTime i mt))), + numProcesses=(show $ totalProcesses m), + numSent=(show $ sentMessagesM m), + numRcvd=(show $ receivedMessagesM m)}) + + inspectMachine ms store + inspectMachine _ _ = return () + inspectProcess :: [Process] -> ListStore ProcessInfo -> IO () + --inspectProcess (((m,i),_,_,stat,evts):ps) store = do + insectProcess (p:ps) store = do + let evts = eventlistP p + -- because of the processIDs being reused, there may be more then one + -- StartProcess-/KillProcess-Events in evts. One fkt. to find them all: + filterProcesses evts (totalThreads p, sentMessagesP p, receivedMessagesP p) (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 $ pId2mId $ getIdP p), + procId=("Process " ++ show (pId $ getIdP p) ++ "/" ++ 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 () + 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), + inspectThread (((pid,i),evts):ts) store = do + + listStorePrepend store (ThreadInfo{ machIdT=(show $ pId2mId pid), + procIdT=if isSystemProcess pid then "System" else (show $ pId pid), thrdId=("Thread " ++ show i), runtimeT=(formatFloat (getEventTime (head evts) - (getEventTime (last evts))))}) - - inspectThread ts store - inspectThread _ _ = return () + + inspectThread ts store + inspectThread _ _ = return () - commaToNewline c - | c == ',' = '\n' - | otherwise = c + commaToNewline c + | c == ',' = '\n' + | otherwise = c @@ -446,34 +454,34 @@ 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 + --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 + --drawWindowProcessUpdates win False + renderWithDrawable win $ do --colorWhite - --rectangle (fromIntegral vx) lry (50) (uly-lry) + --rectangle (fromIntegral vx) lry (50) (uly-lry) --fill - colorRedA - moveTo ((fromIntegral vx)+20) (my) - lineTo ((fromIntegral vx)+30) (my) - stroke - - else return () + 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 + 1 -> matrixP state + _ -> matrixM state ySkip = (lry - uly) / (fromIntegral (length matrix)) index = fromIntegral (floor (1 + ((my - uly) / ySkip))) oldIndex = head $ sort $ selRow state @@ -520,45 +528,46 @@ 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 () +handleMouseMove st edentvState hideStartupPhase pic events mx my = do + -- events was (_,_,(maxStartupTimeInSeconds, _),_,(minT,maxT,maxST,_,_),_) + ((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 = maxStartup events --in seconds + | otherwise = min_t events + + let time + | useDiff = posToTime minT' (max_t events + max_t_diff events) ulx lrx mx + | otherwise = posToTime minT' (max_t events) ulx lrx mx + text = formatFloat time + + win <- widgetGetDrawWindow pic + drawWindowProcessUpdates win False + renderWithDrawable win $ do + 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) @@ -567,18 +576,26 @@ 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 +handleButtonPress pic v st e events = do + --events was ((m,p,t),mt,(mxs,mxst),_,(minT,maxT,maxST,_,maxD),_) + (_,(ulx,uly,lrx,lry)) <- getCorners pic + oldState <- readMVar st - let matrix = case v of + let m = machinelist events + p = processlist events + t = threadlist events + minT = min_t events + maxT = max_t events + maxST = max_t_diff events + + 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 + 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 @@ -588,7 +605,7 @@ findRow i _ [] = i numProcs :: [(MachineID, Int)] - numProcs = map (\(mId,_,_,(numP,_,_),_) -> (mId, numP)) m + numProcs = map (\m -> (getIdM m, totalProcesses m)) m numM = fromIntegral $ length m procSkip = (lry - uly - ((numM-1)*10) )/ (fromIntegral (length (matrixP oldState))) @@ -606,142 +623,142 @@ 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 + 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 + 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) + --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) + 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 + --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 = eventlistP (p!!line') + mData = eventlistM (m!!line') + (selMachine,selName) = case v of + 2 -> case t!!line' of ((pid,t),_) -> (pId2mId pid,'T': show pid ++ ':': show t) + 1 -> let p' = getIdP (p!!line') in (pId2mId p','P': show p') + 0 -> let m' = getIdM (m!!line') in (m','M': show m') + diffTime = (getStartTime selMachine $ startupOffsets events) + 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]) @@ -800,93 +817,93 @@ 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 + 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 + 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 + (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 + (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 + (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 + (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 + | 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 + | 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 + 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 + 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 + (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 + (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 + (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 + (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 --- a/EdenTvType.hs +++ b/EdenTvType.hs @@ -1,5 +1,6 @@ -{- 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 +{- 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 Philipps 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 @@ -53,7 +54,7 @@ , 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 @@ -62,229 +63,276 @@ show x = "pixbuf" data EdenTvState = ES - { lastPath :: String - , colors :: Colors - } deriving Show + { lastPath :: String + , colors :: Colors + } deriving Show data ColorRGBA = RGBA - { rgbColor :: Color - , alpha :: Word16 - } deriving Show + { 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 + { 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 +type Seconds = Double +type InportID = Int +type OutportID = Int class EdenEvent e where - getEventTime :: e -> Seconds - setEventTime :: e -> Seconds -> e + 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]) +type MachineID = Int +--type Machine = (MachineID,Int,Int,(Int,Int,Int),[MachineEvent]) -- (mID, allP,blkP,(#Proc,#sent,#rcv),events) +data Machine = Machine { + getIdM :: {-# UNPACK #-} !MachineID, + aliveProcesses :: {-# UNPACK #-} !Int, + runningProcesses :: {-# UNPACK #-} !Int, + blockedProcesses :: {-# UNPACK #-} !Int, + totalProcesses :: {-# UNPACK #-} !Int, + sentMessagesM :: {-# UNPACK #-} !Int, + receivedMessagesM :: {-# UNPACK #-} !Int, + eventlistM :: [MachineEvent] +} +newMachine :: MachineID -> Machine +newMachine mId = Machine mId 0 0 0 0 0 0 [] + 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) + = StartMachine {-# UNPACK #-} !Seconds -- Event 137 + | EndMachine {-# UNPACK #-} !Seconds -- Event 145 + | GCMachine {-# UNPACK #-} !Seconds {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- Event 849 (Garbage Collection) + | IdleMachine {-# UNPACK #-} !Seconds -- virtual event (no processes available) + | RunningMachine {-# UNPACK #-} !Seconds -- virtual event (process running) + | SuspendedMachine {-# UNPACK #-} !Seconds -- virtual event (no process running but runnable waiting) + | BlockedMachine {-# UNPACK #-} !Seconds -- virtual event (all processes blocked) + | MNewProcess {-# UNPACK #-} !Seconds -- other virtual events triggert by ProcessEvents + | MKillRProcess {-# UNPACK #-} !Seconds + | MKillSProcess {-# UNPACK #-} !Seconds + | MKillBProcess {-# UNPACK #-} !Seconds + | MRunProcess {-# UNPACK #-} !Seconds + | MSuspendProcess {-# UNPACK #-} !Seconds + | MBlockProcess {-# UNPACK #-} !Seconds + | MDeblockProcess {-# UNPACK #-} !Seconds + | MIdleProcess {-# UNPACK #-} !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) + 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 + 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 + 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) +--type ProcessID = (MachineID,Int) -- (MachineID,ProcessID) +data ProcessID = UserProcess { + pId2mId :: {-# UNPACK #-} !MachineID, + pId :: {-# UNPACK #-} !Int + } | + System { + pId2mId :: {-# UNPACK #-} !MachineID + } deriving (Eq, Ord) + +instance Show ProcessID where + show (UserProcess m p) = (show m) ++ ':':(show p) + show (System m) = (show m) ++ ":Sys" + +isSystemProcess :: ProcessID -> Bool +isSystemProcess (System {}) = True +isSystemProcess _ = False + +--type Process = (ProcessID,Int,Int,(Int,Int,Int),[ProcessEvent]) +-- (pID,allT alive,blockedT,(#Threads total,#sent,#rec),events) +data Process = Process { + getIdP :: !ProcessID, + aliveThreads :: {-# UNPACK #-} !Int, + runningThreads :: {-# UNPACK #-} !Int, + blockedThreads :: {-# UNPACK #-} !Int, + totalThreads :: {-# UNPACK #-} !Int, + sentMessagesP :: {-# UNPACK #-} !Int, + receivedMessagesP :: {-# UNPACK #-} !Int, + eventlistP :: ![ProcessEvent] +} + +newProcess :: ProcessID -> Process +newProcess pid = Process pid 0 0 0 0 0 0 [] + +getMIdFromP :: Process -> MachineID +getMIdFromP = pId2mId . getIdP + 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) + = NewProcess {-# UNPACK #-} !Seconds -- Event 153 + | LabelProcess {-# UNPACK #-} !Seconds String + | KillProcess {-# UNPACK #-} !Seconds (Int,Int,Int) -- Event 161 + | GCProcess {-# UNPACK #-} !Seconds !Int !Int !Int !Int + | IdleProcess {-# UNPACK #-} !Seconds -- virtual event (no threads available) + | RunningProcess {-# UNPACK #-} !Seconds -- virtual event (thread running) + | SuspendedProcess {-# UNPACK #-} !Seconds -- virtual event (no thread running but runnable waiting) + | BlockedProcess {-# UNPACK #-} !Seconds -- virtual event (all threads blocked) + | PNewThread {-# UNPACK #-} !Seconds + | PKillRThread {-# UNPACK #-} !Seconds + | PKillSThread {-# UNPACK #-} !Seconds + | PKillBThread {-# UNPACK #-} !Seconds + | PRunThread {-# UNPACK #-} !Seconds + | PSuspendThread {-# UNPACK #-} !Seconds + | PBlockThread {-# UNPACK #-} !Seconds + | PDeblockThread {-# UNPACK #-} !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 + 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 + 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 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) + = NewThread {-# UNPACK #-} !Seconds {-# UNPACK #-} !OutportID -- Event 169 + | KillThread {-# UNPACK #-} !Seconds -- Event 177 + | GCThread {-# UNPACK #-} !Seconds {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | RunThread {-# UNPACK #-} !Seconds -- Event 185 + | SuspendThread {-# UNPACK #-} !Seconds -- Event 193 + | BlockThread {-# UNPACK #-} !Seconds {-# UNPACK #-} !InportID !Reason -- Event 201 + | DeblockThread {-# UNPACK #-} !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 + 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 + 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 + 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) + 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 +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 +-- 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 @@ -303,30 +351,30 @@ -- All other information of the message is already contained in the map key. -- data SmallOpenMessageEvent - = SmallORM !Seconds !Size - | SmallOSM !Seconds - deriving (Show,Eq) + = SmallORM {-# UNPACK #-} !Seconds {-# UNPACK #-} !Size + | SmallOSM {-# UNPACK #-} !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) + = ORM {-# UNPACK #-} !Seconds !ProcessID {-# UNPACK #-} !OutportID {-# UNPACK #-} !InportID !Reason {-# UNPACK #-} !Size + | OSM {-# UNPACK #-} !Seconds !ProcessID {-# UNPACK #-} !OutportID {-# UNPACK #-} !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 + 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 +data Message = MSG {-# UNPACK #-} !ChannelID {-# UNPACK #-} !Seconds {-# UNPACK #-} !Seconds !Reason {-# UNPACK #-} !Size -- channel stime rtime tag size - deriving (Show,Eq) + deriving (Show,Eq) {-instance DeepSeq Message where - deepSeq (MSG times procs ports info) y = deepSeq times $ deepSeq procs $ deepSeq ports $ deepSeq info y + deepSeq (MSG times procs ports info) y = deepSeq times $ deepSeq procs $ deepSeq ports $ deepSeq info y -} -- the time it took to receive a message @@ -344,13 +392,13 @@ 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 - ) - + [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]) @@ -365,18 +413,35 @@ (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 - ) +-- 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 +-- ) +data Events = Events { + machinelist :: [Machine], + processlist :: [Process], + threadlist :: [Thread], + starttimeByMachine :: [(MachineID, Double)], + maxStartup :: {-# UNPACK #-} !Seconds, + startupOffsets :: [(MachineID, Seconds)], + messagelist :: MessageList, + min_t :: {-# UNPACK #-} !Seconds, + max_t :: {-# UNPACK #-} !Seconds, + max_t_diff :: {-# UNPACK #-} !Seconds, + maxMsgSize :: {-# UNPACK #-} !Double, + maxLD :: {-# UNPACK #-} !Double, + noOfMachines :: {-# UNPACK #-} !Int, + noOfProcesses :: {-# UNPACK #-} !Int, + noOfThreads :: {-# UNPACK #-} !Int +} #if __GLASGOW_HASKELL__ < 606 #warning __GLASGOW_HASKELL__ diff --git a/EdenTvViewer.hs b/EdenTvViewer.hs --- a/EdenTvViewer.hs +++ b/EdenTvViewer.hs @@ -1,974 +1,1027 @@ -{- 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 - +{- 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 Philipps 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 Control.Monad.State +import Control.Concurrent.MVar +import Data.List (foldl') +import qualified Data.Map.Strict as MS +import Graphics.UI.Gtk hiding (get) +import Graphics.UI.Gtk.Gdk.Pixbuf +import Graphics.Rendering.Cairo +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' = if hideStartupPhase + then setMinTimeToStartUpTime traces + else traces + minTime = min_t traces' + maxTime = max_t traces' + maxSTime = max_t_diff 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 events = events {min_t = maxStartup events} + +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 events pic state colorsMap = do + --events was ((ms,ps,_),mTimes,(mxs,mxst),(msgs,amsgs,hmsgs,_,rcvtimes),(minTime,maxTime,maxSTime,maxSize,maxLD),_) + 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 + + ms = machinelist events + ps = processlist events + minTime = min_t events + mxst = startupOffsets events + (msgs,amsgs,hmsgs,_,rcvtimes) = messagelist events + + -- 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 (p:pss) + | (getMIdFromP p) == m' = rowPosP m' (i+1) pss + | otherwise = i:(rowPosP (getMIdFromP p) (i+1) pss) + rowPosM :: Num a => a -> [Machine] -> [a] + rowPosM _ [] = [] + rowPosM i (_:mss) = i:(rowPosM (i+1) mss) + + numProcs :: MS.Map MachineID Int --was: [(MachineID, Int)] + numProcs = foldl' (\c m -> MS.insert (getIdM m) (totalProcesses m) c) MS.empty ms + --was: 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 = MS.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 (pId2mId sender) activeMachs + Just (rin,_) = lookup (pId2mId 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.getIdP) $ filter ((== mId).getMIdFromP) 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 = MS.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 = MS.lookup m numProcs + drawMsg [] l = setLineWidth l + drawMsg (m@(MSG (spid,o,rpid,i) st rt t s):ms) thickness = do + let sm = pId2mId spid + sp = pId spid + rm = pId2mId rpid + rp = pId rpid + when ((and (map (0<=) [sm,sp,rm,rp])) && (messageActive spid rpid)) + (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 = MS.lookup m numProcs + compSize = 2 * (maxMsgSize events) + relSize s = 0.15 + (s / compSize) + drawHead (((spid,_,rpid,_),(ts1,tr1,ts2,tr2),size,_):hs) = + let sm = pId2mId spid + sp = pId spid + rm = pId2mId rpid + rp = pId rpid + in if ((min sp rp) < 0) || (not (messageActive spid rpid)) + 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 events= do + --events was ((ms,ps,_),mTimes,(mxs,mxst),(msgs,amsgs,hmsgs,_,rcvtimes),(minTime,maxTime,maxSTime,maxSize,maxLD),_) + win <- widgetGetDrawWindow pic + (_,(ulx,uly,lrx,lry)) <- getCorners pic + let ms = machinelist events + xSkip = (lrx - ulx) + ySkip = (lry - uly) / nRows + rows = selRow state + + numProcs :: MS.Map MachineID Int --was: [(MachineID, Int)] + numProcs = foldl' (\c m -> MS.insert (getIdM m) (totalProcesses m) c) MS.empty ms + --was: 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 = MS.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 = MS.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 events color pic state getDiffTime scaledTime = do + --events was ((_,_,threads),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) + win <- widgetGetDrawWindow pic + (cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic + let threads = threadlist events + numT = (fromIntegral (length threads))::Double + ySkip = (lry - uly) / numT + xSkip = (lrx - ulx) + sort = matrixT state + names = map (\((pid,t),_) -> ('T':(show pid) ++ ':': (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 maxTime = max_t events + maxSTime = max_t_diff events + 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 + minTime = min_t events + + drawLocalThreads, drawGlobalThreads :: [Thread] -> [Double] -> Render () + drawLocalThreads (((pid,_),evts):ts) (s:ss) = do + let diff = getDiffTime (pId2mId pid) (startupOffsets events) 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 events) + +drawProcesses :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ()) +drawProcesses hideStartupPhase visX visY target events color pic state getDiffTime scaledTime = do + --events was ((_,processes,_),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) + win <- widgetGetDrawWindow pic + (cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic + let processes = processlist events + numP = (fromIntegral (length processes))::Double + ySkip = (lry - uly) / numP + xSkip = (lrx - ulx) + sort = matrixP state + names = map (\p' -> let pid = getIdP p' in ('P':(show pid))) 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 maxTime = max_t events + maxSTime = max_t_diff events + 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 + minTime = min_t events + + drawLocalProcesses, drawGlobalProcesses :: [Process] -> [Double] -> Render () + drawLocalProcesses (p:ps) (s:ss) = do + let diff = getDiffTime (getMIdFromP p) (startupOffsets events) minTime + + drawEvents (eventlistP p) 1 s diff + drawLocalProcesses ps ss + drawLocalProcesses _ _ = return () + drawGlobalProcesses (p:ps) (s:ss) = do + drawEvents (eventlistP p) 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) + _ -> trace ("getTimeAndColor: unknown case "++(show e)) (0, getColor chartBackground color, 0, 0) + barO = line - 0.8 + barG = line - 0.1 + barP = line - 0.5 + barH = 0.7 + barI = 0.4 + ldScale = (-barH) / (maxLD events) + + +drawGroupProcesses :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ()) +drawGroupProcesses hideStartupPhase visX visY target events color pic state getDiffTime scaledTime = do + --events was ((machines,processes,_),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) + let machines = machinelist events + processes = processlist events + win <- widgetGetDrawWindow pic + let groupedProcesses = map (\m -> let mId = getIdM m in filter (\p -> getMIdFromP p == 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 (\p' -> let pid = getIdP p' in ('P':(show pid))) processes + sortGroup = map (pos 1 sort) [1..numM] + where pos :: Double -> [Double] -> Double -> Double + pos i (y:ys) x + | 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 [p] (s:ss) skip = do + let pid = getIdP p + drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show pid)) + drawNameTick (fromIntegral vx + ulx -5) (lry-uly) ((s*ySkip)+skip+5) + drawPNames (p:ps) (s:ss) skip = do + let pid = getIdP p + drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (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 maxTime = max_t events + maxSTime = max_t_diff events + 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 minTime = min_t events + + drawLocalProcesses :: [Process] -> [Double] -> Double -> Render () + drawLocalProcesses (p:ps) (s:ss) skip = do + let diff = getDiffTime (getMIdFromP p) (startupOffsets events) minTime + + drawEvents (eventlistP p) 1 s diff skip + drawLocalProcesses ps ss skip + drawLocalProcesses _ _ _ = return () + drawGlobalProcesses (p:ps) (s:ss) skip = do + drawEvents (eventlistP p) 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) + _ -> trace ("getTimeAndColor: unknown case "++(show e)) (0, getColor chartBackground color, 0, 0) + barO = line - 1 -- - 0.7 + barG = line - 0.1 + barP = line - 0.5 + barH = 1 + barI = 0.4 + ldScale = (-barH) / (maxLD events) + + + +drawMachines :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ()) +drawMachines hideStartupPhase visX visY target events color pic state getDiffTime scaledTime = do + --events was ((machines,_,_),mTimes,(mxs,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_) + win <- widgetGetDrawWindow pic + (cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic + let machines = machinelist events + maxTime = max_t events + maxSTime = max_t_diff events + numM = (fromIntegral (length machines))::Double + ySkip = (lry - uly) / numM + xSkip = (lrx - ulx) + sort = matrixM state + names = map (\m -> ('M':(show $ getIdM 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 + minTime = min_t events + -- startup sync activated + drawLocalMachines, drawGlobalMachines :: [Machine] -> [Double] -> Render () + drawLocalMachines (m:ms) (s:ss) = do + let diffTime = getDiffTime (getIdM m) (startupOffsets events) minTime + + drawEvents (eventlistM m) 1 s diffTime + drawLocalMachines ms ss + drawLocalMachines _ _ = return () + + -- startup sync deactivated + drawGlobalMachines (m:ms) (s:ss) = do + drawEvents (eventlistM m) 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) + _ -> trace ("getTimeAndColor: unknown case "++(show e)) (0, getColor chartBackground color, 0, 0) + barO = line + 0.2 + barG = line + 0.9 + barP = line + 0.5 + drawEvents _ _ _ _ = return () + barH = 0.7 + barI = 0.4 + ldScale = (-barH) / (maxLD events) + +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 events pic state colorsMap + = do + win <- widgetGetDrawWindow pic + (_,(ulx,uly,lrx,lry)) <- getCorners pic + + drawMarker win pixelsPerSecond ulx uly (lry - uly) + where + --events was (_, _, (maxStartupTimeInSeconds,_),_ , (minTime, maxTime, maxSTime,_ ,_ ), _) + 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 (maxStartup events) + + 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 --- a/RTSEventsParser.hs +++ b/RTSEventsParser.hs @@ -1,6 +1,6 @@ {- 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 + Copyright (C) 2005-2012 Philipps 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 @@ -27,15 +27,18 @@ import GHC.RTS.Events import qualified Control.Exception as C -import Control.Monad.Error +import Control.Monad.Error (runErrorT) import Data.Binary.Get import Data.ByteString.Lazy (ByteString) import Data.Either import Data.Maybe import Data.Tree +import System.FilePath (takeExtension) +import qualified Data.ByteString.Lazy as BS import qualified Data.Map as M import qualified Data.Sequence as S + import Debug.Trace type RTSEvents = (E.MachineID, [Event]) @@ -44,7 +47,7 @@ ---------------------------------- -- --- Reader function: parseRawFile +-- Reader function: parseZipFile -- Reads a zip File containing binary eventlog files -- to a List of RTSEvents -- @@ -52,11 +55,15 @@ -- 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 +parseZipFile :: FilePath -> IO (Either String [RTSEvents]) +parseZipFile 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)++")")) + catchBadFile e = return (Left ("ParseZipFile: Bad File (due to: "++(show e)++")")) +parseEventlogFile :: FilePath -> IO (Either String [RTSEvents]) +parseEventlogFile f = do s <- BS.readFile f + log <- readGhcEventsSingle s + return $ log >>= eventLogToEvents >>= (return . (:[])) -- similar to readEventLogFromFile, but uses a ByteString -- parses a binary *.eventlog file @@ -76,7 +83,11 @@ getMachineID ((Event{time, spec=CreateMachine{machine}}):_) = Right $ fromIntegral machine getMachineID (_:xs) = getMachineID xs - getMachineID [] = Left "eventLogToEvents: No CreateMachine Event!" + --TH: removed error with a default machine 1 + -- machineid 0 might be better, but 1 is assumed to be the main machine + -- machines only exist in Eden (parevents) traces + --getMachineID [] = Left "eventLogToEvents: No CreateMachine Event!" + getMachineID [] = Right 1 -- now we can read all files contained in a zip archive readAll :: FilePath -> IO (Either String [RTSEvents]) @@ -185,11 +196,11 @@ receiverMachine, receiverProcess, receiverInport} - -> insertLeftOutMessages (mID, (fromIntegral senderProcess)) - (E.OSM (convertTimestamp time) - (fromIntegral receiverMachine, fromIntegral receiverProcess) - (fromIntegral senderThread) - (fromIntegral receiverInport) + -> insertLeftOutMessages (E.UserProcess mID (fromIntegral senderProcess)) + (E.OSM (convertTimestamp time) + (E.UserProcess (fromIntegral receiverMachine) (fromIntegral receiverProcess)) + (fromIntegral senderThread) + (fromIntegral receiverInport) (readTag mesTag)) oe ReceiveMessage{ mesTag, @@ -199,12 +210,12 @@ senderProcess, senderThread, messageSize} - -> insertLeftOutMessages ((fromIntegral senderMachine), (fromIntegral senderProcess)) - (E.ORM (convertTimestamp time) - (mID, fromIntegral receiverProcess) - (fromIntegral senderThread) - (fromIntegral receiverInport) - (readTag mesTag) + -> insertLeftOutMessages (E.UserProcess (fromIntegral senderMachine) (fromIntegral senderProcess)) + (E.ORM (convertTimestamp time) + (E.UserProcess mID (fromIntegral receiverProcess)) + (fromIntegral senderThread) + (fromIntegral receiverInport) + (readTag mesTag) (fromIntegral messageSize)) oe SendReceiveLocalMessage{ mesTag, @@ -212,9 +223,9 @@ senderThread, receiverProcess, receiverInport} - -> insertLeftOutLocalMessage (E.MSG ((mID, fromIntegral senderProcess), + -> insertLeftOutLocalMessage (E.MSG (E.UserProcess mID (fromIntegral senderProcess), fromIntegral senderThread, - (mID, fromIntegral receiverProcess), + (E.UserProcess mID (fromIntegral receiverProcess)), fromIntegral receiverInport) (convertTimestamp time) (convertTimestamp time) @@ -332,10 +343,9 @@ -> (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 + = if (min (E.pId senderProcessId) (E.pId receiveProcessId)) >= 0 + then openMessages' `seq` closedMessages' `seq` (openMessages', closedMessages') + else ocMsgs | otherwise = ocMsgs where (receiveProcessId, tag) = case newMessage of E.ORM _ p _ _ r _ -> (p, r) @@ -477,7 +487,9 @@ -------------------------------------------------------------------------------- traceRTSFile :: FilePath -> Bool -> IO (Err E.Events) traceRTSFile file ignoreMessages = - do ghcevents' <- parseRawFile file + do ghcevents' <- if isPareventsFile file + then parseZipFile file + else parseEventlogFile file case ghcevents' of Left err -> return (Failed err) Right ghcevents -> @@ -488,8 +500,15 @@ 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) +-- 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) + finish events = let !(maxSU, startupOffs) = ai_startupDiff additionalInfo + !(ml, aml, hml, pt, rcvl) = E.messagelist events + in events { E.maxStartup = maxSU, + E.startupOffsets = startupOffs, + E.messagelist = (ml, ai_leftMsgs additionalInfo, hml, pt, ai_rcvLengths additionalInfo), + E.max_t_diff = ai_maxSUDiff additionalInfo + } {- @@ -511,15 +530,16 @@ 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) - + --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) + injectProcMessages events = let (ml, aml, hml, pt, rcvl) = E.messagelist events + in events { E.messagelist = (ml++procMessages,aml,hml,processTree, rcvl) } 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)) + processTree = unfoldTree buildTree (E.UserProcess 1 1, fromJust (lookup (E.UserProcess 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 @@ -530,7 +550,7 @@ 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) + senderProc = E.UserProcess mID (fromIntegral sProc) receiverMach = fromIntegral receiverMachine sMach = fromIntegral mID sProc = senderProcess @@ -541,7 +561,7 @@ (childId, remainingEvents, child) = nextChildId rcvEvents - childProcess = (receiverMach, childId) + childProcess = E.UserProcess receiverMach childId newRcvers = updateReceivers receiverMach rcvers remainingEvents newTable = addChild table senderProc childProcess @@ -564,7 +584,7 @@ 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) + channelID = (senderProc, 0, E.UserProcess 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) @@ -597,7 +617,7 @@ -- 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,[])) + fml t = (M.empty,[],([(1,[(E.UserProcess 1 1,E.OSM t (E.UserProcess 0 0) (-1) (-1) E.RFork)],[(E.UserProcess 0 0,E.ORM t (E.UserProcess 1 1) (-1) (-1) E.RFork 4)],[])],[(E.UserProcess 0 0,[])],Node (E.UserProcess 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 @@ -650,6 +670,7 @@ -- finds the matching Process# to a given MachineId and Thread# -- inside the ThreadTable +-- returns -1 for unassigned processes lookupProcess :: ThreadTable -> E.MachineID -> Int -> Int lookupProcess ((machine, es):ts) sMachine sThread = if machine == sMachine @@ -658,11 +679,12 @@ 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 + lookupProcess' [] stnum = -1 +lookupProcess [] sMachine sThread = -1 +isPareventsFile :: FilePath -> Bool +isPareventsFile = (flip elem [".parevents", ".zip"]) . takeExtension + -------------------------------------------------------------------------------- -- Legacy Code -------------------------------------------------------------------------------- @@ -704,15 +726,15 @@ senderThread, receiverMachine, receiverProcess, - receiverInport} -> (True, createNewMsgEvents - (mId, fromIntegral senderProcess) - (E.OSM (convertTimestamp time) - (fromIntegral receiverMachine, fromIntegral receiverProcess) - (fromIntegral senderThread) - (fromIntegral receiverInport) + receiverInport} -> (True, createNewMsgEvents + (E.UserProcess mId (fromIntegral senderProcess)) + (E.OSM (convertTimestamp time) + (E.UserProcess (fromIntegral receiverMachine) (fromIntegral receiverProcess)) + (fromIntegral senderThread) + (fromIntegral receiverInport) (readTag mesTag)), nms, nps) - + ReceiveMessage{ mesTag, receiverProcess, @@ -721,14 +743,14 @@ 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) + (E.UserProcess (fromIntegral senderMachine) (fromIntegral senderProcess)) + (E.ORM (convertTimestamp time) + (E.UserProcess mId (fromIntegral receiverProcess)) + (fromIntegral senderThread) + (fromIntegral receiverInport) + (readTag mesTag) + (fromIntegral messageSize)), + nms, nps) {- SendReceiveLocalMessage{ mesTag, @@ -742,18 +764,17 @@ 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 + (nms, nps) = increaseMsgCount (E.UserProcess 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 + CreateThread { + thread } -> (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? + | status `elem` blockList = (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] @@ -763,15 +784,17 @@ _ -> (False, undefined) where proc = lookupProcess lutable mId thre -- hack thre = fromIntegral (thread spec) -- hack - newEvents evt = insertThreadEvent ((mId, proc), thre) evt ts + newEvents evt = let pid = if proc == -1 then E.System mId + else E.UserProcess mId proc + in insertThreadEvent (pid, 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) + process} -> (True, newEvents (E.KillProcess (convertTimestamp time) (0,0,0)), delFromProcList (E.UserProcess mId (fromIntegral process)) ocMsgs, nP) _ -> (False, undefined, undefined, undefined) - where newEvents evt = insPEvent (mId, fromIntegral (process spec)) evt ps - + where newEvents evt = insPEvent (E.UserProcess 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) @@ -789,56 +812,82 @@ 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: + --insMEvent i1 evt lst@(e@(i2,allP,blkP,stat@(p,s,r),evts):es) -- insert in existing list of machines + insMEvent i1 evt (m:ms) -- insert in existing list of machines + | E.getIdM m > i1 = let ms' = (insMEvent i1 evt ms) in seq ms' (m : ms') -- go on + | E.getIdM m == i1 = m' `seq` (m' : ms) -- existing machine + | otherwise = (E.newMachine i1) {E.eventlistM = [evt]} : m : ms -- new machine => no processes + where + evts = E.eventlistM m + m' = case evt of + E.MSuspendProcess sec -> let newRunP = E.runningProcesses m - 1 + newEvts = (E.SuspendedMachine sec):evts + in m {E.eventlistM = newEvts, + E.runningProcesses = newRunP} + E.MRunProcess sec -> let newRunP = E.runningProcesses m + 1 + in m {E.eventlistM = (E.RunningMachine sec):evts, + E.runningProcesses = newRunP} + E.MBlockProcess sec -> let newRunP = E.runningProcesses m - 1 + newBlkP = E.blockedProcesses m + 1 + newEvts = if newRunP == 0 + then (E.BlockedMachine sec):evts + else evts + in m {E.runningProcesses = newRunP, + E.blockedProcesses = newBlkP, + E.eventlistM = newEvts} + E.MDeblockProcess sec -> let newBlkP = E.blockedProcesses m - 1 + newEvts = if (E.blockedProcesses m == E.aliveProcesses m) then (E.SuspendedMachine sec):evts else evts - in (i2,allP + 1,blkP,(p+1,s,r),newEvts) - E.MKillRProcess sec -> let newAllP = allP - 1 + in m {E.blockedProcesses = newBlkP, + E.eventlistM = newEvts} + E.GCMachine _ _ _ _ _ -> m + E.MNewProcess sec -> let newAllP = E.aliveProcesses m + 1 + newTotP = E.totalProcesses m + 1 + newEvts = if (E.blockedProcesses m == E.aliveProcesses m) -- test if evt may be skipped: + then (E.SuspendedMachine sec):evts + else evts + in m {E.aliveProcesses = newAllP, + E.totalProcesses = newTotP, + E.eventlistM = newEvts} + E.MKillRProcess sec -> let newRunP = E.runningProcesses m - 1 + newAllP = E.aliveProcesses m - 1 newEvts = if newAllP > 0 then (E.SuspendedMachine sec):evts else (E.IdleMachine sec):evts - in (i2,newAllP,blkP,stat,newEvts) - E.MKillSProcess sec -> let newAllP = allP - 1 + in m {E.aliveProcesses = newAllP, + E.eventlistM = newEvts} + E.MKillSProcess sec -> let newAllP = E.aliveProcesses m - 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 + in m {E.aliveProcesses = newAllP, + E.eventlistM = newEvts} + E.MKillBProcess sec -> let newAllP = E.aliveProcesses m - 1 + newBlkP = E.blockedProcesses m - 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) + in m {E.aliveProcesses = newAllP, + E.blockedProcesses = newBlkP, + E.eventlistM = newEvts} + E.MIdleProcess sec -> let newRunP = E.runningProcesses m - 1 + newEvts = if newRunP == 0 + then (E.IdleMachine sec) : evts + else evts + in m {E.runningProcesses = newRunP} + E.EndMachine _ -> m {E.runningProcesses = 0, + E.aliveProcesses = 0, + E.blockedProcesses = 0, + E.eventlistM = evt:evts} _ -> error ("insMEvent: unknown event: " ++ show evt) - insMEvent i1 evt [] = [(i1,0,0,(0,0,0),[evt])] -- brand new machine => no processes + insMEvent i1 evt [] = [(E.newMachine i1) {E.eventlistM = [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 @@ -849,82 +898,133 @@ 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 + insPeByMID i evt lst@(e:es) + | i == E.getMIdFromP e = 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? + where insertHere lst@(e:es) + | i == E.getMIdFromP e = let es' = insertHere es + evts = E.eventlistP e + in case take 1 evts of + [E.KillProcess _ _] -> seq es' ( e : es') -- process not alive + [E.BlockedProcess _] -> seq es' (e {E.eventlistP = E.BlockedProcess (convertTimestamp time):evt:evts}:es') + [E.SuspendedProcess _] -> seq es' (e {E.eventlistP = E.SuspendedProcess (convertTimestamp time):evt:evts}:es') + _ -> seq es' (e {E.eventlistP = 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 + insPEvent i1 evt lst@(e:es) --e@(i2,allT,blkT,stat@(t,s,r),evts) + | i1 < E.getIdP e = let (es',mEvt) = insPEvent i1 evt es in seq es' (seq mEvt (e : es', mEvt)) + | i1 == E.getIdP e = (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) +-- | otherwise = ((i1,0,0,(0,0,0),[evt]):lst,Just (E.MNewProcess (convertTimestamp time))) -- new Process => evt == NewProcess + | otherwise = insPEvent i1 evt (E.newProcess i1 : lst) -- evt for new process => create it and handle event normally + where (insertHere,vMachineEvent) = let allT = E.aliveThreads e + runT = E.runningThreads e + blkT = E.blockedThreads e + evts = E.eventlistP e + in case evt of + E.PNewThread sec -> let !newAllT = allT + 1 + !newTotT = E.totalThreads e + 1 + !newEvts = if blkT == allT --process was blocked or is newborn + then (E.SuspendedProcess sec) : evts + else evts + !newMEvt = if evts == [] -- process is newborn + then Just (E.MNewProcess sec) -- inform machine here... CreateProcess event will follow directly only if this is not system thread + else if blkT == allT -- process was blocked + then Just (E.MDeblockProcess sec) + else Nothing + in (e {E.aliveThreads = newAllT, + E.totalThreads = newTotT, + E.eventlistP = newEvts}, + newMEvt) + E.PKillRThread sec -> let !newAllT = allT - 1 + !newRunT = runT - 1 + !(newEvts,newMEvt) = if newAllT > 0 + then if E.blockedThreads e < newAllT -- process was running, now suspended or blocked? + 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) + _ -> case E.getIdP e of + E.UserProcess _ _ -> ((E.IdleProcess sec):evts, Just (E.MIdleProcess sec)) + E.System _ -> (E.KillProcess sec (E.totalThreads e, 0, 0):evts, Just (E.MKillRProcess sec)) + in (e {E.aliveThreads = newAllT, + E.runningThreads = newRunT, + E.eventlistP = newEvts}, + newMEvt) + E.PKillSThread sec -> let !newAllT = allT - 1 + !(newEvts,newMEvt) = if newAllT > 0 + then if blkT < newAllT -- process was suspended, now still suspended or blocked? + then (evts, Nothing) + else ((E.BlockedProcess sec):evts, Just (E.MBlockProcess sec)) + else case evts of + (E.KillProcess _ _:_) -> (evts, Nothing) + _ -> case E.getIdP e of + E.UserProcess _ _ -> ((E.IdleProcess sec):evts, Just (E.MIdleProcess sec)) + E.System _ -> (E.KillProcess sec (E.totalThreads e, 0, 0):evts, Just (E.MKillSProcess sec)) + in (e {E.aliveThreads = newAllT, + E.eventlistP = 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) + _ -> case E.getIdP e of + E.UserProcess _ _ -> ((E.IdleProcess sec):evts, Just (E.MIdleProcess sec)) + E.System _ -> (E.KillProcess sec (E.totalThreads e, 0, 0):evts, Just (E.MKillBProcess sec)) + in (e {E.aliveThreads = newAllT, + E.blockedThreads = newBlkT, + E.eventlistP = newEvts}, + newMEvt) + E.PRunThread sec -> let !newRunT = runT + 1 + !newEvts = (E.RunningProcess sec):evts + in (e {E.runningThreads = newRunT, + E.eventlistP = newEvts}, + Just (E.MRunProcess sec)) + E.PSuspendThread sec -> let !newRunT = runT - 1 + !newEvts = (E.SuspendedProcess sec):evts + in (e {E.runningThreads = newRunT, + E.eventlistP = newEvts}, + Just (E.MSuspendProcess sec)) + E.PBlockThread sec -> let !newBlkT = blkT + 1 + !newRunT = runT - 1 + !(newEvts,newMEvt) = if newBlkT < allT + then if newRunT > 0 + then (evts, Nothing) + else ((E.SuspendedProcess sec):evts, Just (E.MSuspendProcess sec)) + else ((E.BlockedProcess sec):evts,Just (E.MBlockProcess sec)) + in (e {E.blockedThreads = newBlkT, + E.runningThreads = newRunT, + E.eventlistP = newEvts}, + newMEvt) + E.PDeblockThread sec -> let !newBlkT = blkT - 1 + !(newEvts,newMEvt) = if blkT == allT -- was process blocked? + then ((E.SuspendedProcess sec):evts,Just (E.MDeblockProcess sec)) + else (evts,Nothing) + in (e {E.blockedThreads = newBlkT, + E.eventlistP = newEvts}, + newMEvt) + E.NewProcess sec -> (e {E.eventlistP = evt:evts}, Nothing) -- note that MNewProcessEvent was already generated for preceding PNewThread event + E.LabelProcess sec _ -> (e {E.eventlistP = evt:evts}, Nothing) -- KillProcess holds the statistic information for the ending process - E.KillProcess sec _ -> let evt' = E.KillProcess sec (t,s,r) + E.KillProcess sec _ -> let stat = (E.totalThreads e, E.sentMessagesP e, E.receivedMessagesP e) + evt' = E.KillProcess sec stat + e' = (E.newProcess (E.getIdP e)) {E.eventlistP = evt':evts} 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)) + (E.RunningProcess _:_) -> (e',Just (E.MKillRProcess sec)) + (E.BlockedProcess _:_) -> (e',Just (E.MKillBProcess sec)) + _ -> (e',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 +-- insPEvent i1 evt [] = ([(i1,0,0,(0,0,0),[evt])],Just (E.MNewProcess (convertTimestamp time))) -- new Process => evt == NewProcess + insPEvent i1 evt [] = insPEvent i1 evt [E.newProcess i1] -- evt for new process => create it and handle event normally 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) + | i == m = (m,((E.UserProcess m (-1),-1),evt),insertHere ts):es -- machine i found, insert event into threads; the ((E.UserProcess 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 @@ -939,10 +1039,10 @@ 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 + insertThreadEvent i@(pid,_) evt tl@(t@(im,(lti,lte),ts):tls) + | E.pId2mId pid < 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.pId2mId pid == im = case lte of E.SuspendThread _ -> case evt of E.RunThread _ -> if i == lti then ((im,(i,E.DummyThread),ts):tls,[]) -- suppress flattering @@ -951,21 +1051,21 @@ 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 + otherwise -> trace "should this really happen?" $ insertThreadEvent i evt tls + | otherwise = ((E.pId2mId pid,(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 [])]) + insertThreadEvent i@(pid,_) evt [] = ([(E.pId2mId pid,(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) + insTEvent' i@(pid,t) ne lst@(e@(ib@(ipid,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) + i' = (E.pId2mId pid,t) + ib' = (E.pId2mId ipid,it) insTEvent' i evt _ = ([(i,[evt])],vProcessEvent evt []) vProcessEvent :: E.ThreadEvent -> [E.ThreadEvent] -> E.ProcessEvent @@ -978,7 +1078,7 @@ E.SuspendThread sec -> E.PSuspendThread sec E.BlockThread sec _ _ -> E.PBlockThread sec E.DeblockThread sec -> E.PDeblockThread sec - E.NewThread _ _ -> E.PNewThread (convertTimestamp time) + E.NewThread sec _ -> E.PNewThread sec @@ -986,24 +1086,27 @@ increaseMsgCount :: E.ProcessID -> [E.Machine] -> [E.Process] -> EventInfo -> ([E.Machine], [E.Process]) -increaseMsgCount pID@(mID,_) ml pl spec = (incM ml, incP pl) +increaseMsgCount pID 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) + --incM (m@(i, aP, bP, (p,s,r), es):ms) + incM (m:ms) + | (E.getIdM m) > (E.pId2mId pID) = m : incM ms -- go on + | (E.getIdM m) == (E.pId2mId pID) = case spec of + SendMessage _ _ _ _ _ _ -> m {E.sentMessagesM = E.sentMessagesM m + 1} : ms + ReceiveMessage _ _ _ _ _ _ _ -> m {E.receivedMessagesM = E.receivedMessagesM m + 1} : ms + SendReceiveLocalMessage {} -> m {E.sentMessagesM = E.sentMessagesM m + 1, + E.receivedMessagesM = E.receivedMessagesM m + 1} : 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) + incP (p:ps) + | E.getIdP p > pID = p : incP ps + | E.getIdP p == pID = case spec of + SendMessage _ _ _ _ _ _ -> p {E.sentMessagesP = E.sentMessagesP p + 1} : ps + ReceiveMessage _ _ _ _ _ _ _ -> p {E.receivedMessagesP = E.receivedMessagesP p + 1} : ps + SendReceiveLocalMessage {} -> p {E.sentMessagesP = E.sentMessagesP p + 1, + E.receivedMessagesP = E.receivedMessagesP p + 1} : ps otherwise -> p:ps -- should not occur | otherwise = p:ps -- not found? nevermind... incP _ = [] @@ -1051,13 +1154,14 @@ | 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)) + in cml `seq` chl `seq` (oml,cml,partMsgs,(ohl,max hs' hSize,chl)) | tag == E.RFork = ocMsgs - | otherwise = let ((_,sp'),(_,rp')) = (sp,rp) + | otherwise = let sp' = E.pId sp + rp' = E.pId 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 + where (time, rp,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 @@ -1110,14 +1214,32 @@ 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)))) + mEvents `seq` minTime `seq` allHeadMessages `seq` + E.Events { + E.machinelist = mEvents, + E.processlist = pEvents, + E.threadlist = newThreadEvents, + E.starttimeByMachine = mTimes, + E.maxStartup = 0, + E.startupOffsets = undefined, + E.messagelist = (closedMessages,[],allHeadMessages,reversedProcTree, []), + E.min_t = minTime, + E.max_t = maxTime, + E.max_t_diff = 0, + E.maxMsgSize = hSize, + E.maxLD = fromIntegral maxLD, + E.noOfMachines = length mEvents, + E.noOfProcesses = numP, + E.noOfThreads = length newThreadEvents + } + +-- ((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) [] + then Node (E.UserProcess 0 0) [] else reverseSubForests (head pTrees) reverseSubForests :: E.ProcessTree -> E.ProcessTree reverseSubForests (Node i f) = Node i (map reverseSubForests (reverse f)) diff --git a/edentv.cabal b/edentv.cabal --- a/edentv.cabal +++ b/edentv.cabal @@ -1,5 +1,5 @@ name: edentv -version: 4.1.0.0 +version: 4.3.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 @@ -20,7 +20,7 @@ build-type: Simple cabal-version: >=1.6 -data-files: edentv.glade +data-files: edentv.ui source-repository head type: git @@ -30,7 +30,7 @@ main-is: EdenTV.hs build-depends: base == 4.*, - containers, + containers >= 0.5, bytestring, binary, mtl, @@ -39,7 +39,6 @@ zip-archive, gtk >= 0.12, cairo >= 0.12, - glade >= 0.12, array, ghc-events-parallel >= 0.4 diff --git a/edentv.glade b/edentv.glade deleted file mode 100644 --- a/edentv.glade +++ /dev/null @@ -1,3112 +0,0 @@ - - - - - - - - - - - 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/edentv.ui b/edentv.ui new file mode 100644 --- /dev/null +++ b/edentv.ui @@ -0,0 +1,2383 @@ + + + + + + + True + EdenTV + False + gtk-network + + + True + + + True + + + True + _File + True + + + + + _Open + True + True + True + accelgroup1 + + + + + + + Open Without Messages + True + True + True + accelgroup1 + + + + + + + True + + + + + _Quit + True + True + True + accelgroup1 + + + + + + + + + + + True + _Colors + True + + + + + + Color _Templates + True + True + True + accelgroup1 + + + + + + True + Default _Colors + True + True + + + + + + True + Default _b/w + True + default_colors + + + + + + + + + + Set Colors + True + True + True + accelgroup1 + + + + + + + + + True + _Windows + True + + + + + + Refresh All + True + True + True + accelgroup1 + + + + + + + + + + True + _Help + True + + + + + _About + True + True + True + accelgroup1 + + + + + + + + + + False + False + 0 + + + + + True + both + False + + + True + _Open + True + gtk-open + + + + + False + True + + + + + True + + + False + + + + + True + + + True + 2 + 4 + + + True + True + False + suspended color + suspended color + + + 1 + 2 + 1 + 2 + GTK_FILL + + + + + + 20 + True + 1 + gtk-media-play + 1 + + + GTK_FILL + + + + + 20 + True + 1 + gtk-media-pause + 1 + + + 1 + 2 + GTK_FILL + GTK_FILL + + + + + True + True + False + running color + running color + + + 1 + 2 + GTK_FILL + + + + + + True + True + False + idle color + idle color + + + 3 + 4 + 1 + 2 + GTK_FILL + + + + + + True + True + False + blocked color + blocked color + + + 3 + 4 + GTK_FILL + + + + + + 20 + True + 1 + gtk-media-stop + 1 + + + 2 + 3 + GTK_FILL + + + + + 20 + True + 1 + gtk-execute + 1 + + + 2 + 3 + 1 + 2 + GTK_FILL + GTK_FILL + + + + + + + False + + + + + False + False + 1 + + + + + + + True + Trace + 900 + 600 + True + gtk-zoom-fit + + + + + + True + + + True + + + True + _File + True + + + + + _Open + True + True + True + accelgroup1 + + + + + + + Open Without Messages + True + True + True + accelgroup1 + + + + + + + _Save + True + True + True + accelgroup1 + + + + + + + True + + + + + Close _Window + True + True + True + accelgroup1 + + + + + + + _Quit Application + True + True + True + accelgroup1 + + + + + + + + + + + True + _View + True + + + + + _Show + True + True + True + accelgroup1 + + + + + + True + All _Machines + True + True + + + + + + + True + All _Processes + True + showAllMachines + + + + + + + True + All _Threads + True + showAllMachines + + + + + + + True + All Processes p. Machines + True + showAllMachines + + + + + + + + + + True + Show _Marker + True + + + + + + + True + Show Block Messages + + + + + True + Show Startup-Marker + + + + + True + Hide Startup-Phase + + + + + True + + + + + True + Show Data Messages + True + + + + + True + Show System Messages + True + + + + + True + + + + + Sort + True + True + True + accelgroup1 + + + + + + + True + + + + + Zoom + True + True + True + accelgroup1 + + + + + Zoom _in + True + True + True + accelgroup1 + + + + + + + Zoom _out + True + True + True + accelgroup1 + + + + + + + True + + + + + Total View + True + True + True + accelgroup1 + + + + + + + + + + + _Refresh + True + refresh view + True + True + accelgroup1 + + + + + + + Show Range + True + True + True + accelgroup1 + + + + + Configure Ticks + True + True + True + accelgroup1 + + + + + + + + + True + _Windows + True + + + + + + Refresh All + True + True + True + accelgroup1 + + + + + + + + + + True + _Help + True + + + + + _About + True + True + True + accelgroup1 + + + + + + + + + + False + False + 0 + + + + + True + both + + + True + Save + True + gtk-save + + + + False + True + + + + + True + + + False + + + + + True + + + True + 2 + 2 + + + True + liststore1 + + + + 0 + + + + + 2 + 1 + 2 + + + + + True + gtk-execute + + + GTK_FILL + GTK_FILL + + + + + True + View: + + + 1 + 2 + + + + + + + + False + + + + + True + + + False + + + + + True + Info + True + gtk-info + + + + False + True + + + + + True + Configure Msgs. + True + gtk-network + + + False + + + + + True + Messages + True + gtk-copy + + + False + + + + + True + Startup Sync. + True + gtk-goto-first + + + False + + + + + True + + + False + + + + + True + + + True + 2 + 2 + + + True + up + Up + True + gtk-go-up + + + + 1 + 2 + GTK_FILL + + + + + True + down + Down + True + gtk-go-down + + + + 1 + 2 + 1 + 2 + GTK_FILL + GTK_FILL + + + + + True + Sort: + + + 2 + GTK_FILL + + + + + + + + False + + + + + True + + + False + + + + + True + + + True + 2 + 2 + + + True + True + gtk-zoom-in + + + 1 + 2 + GTK_FILL + + + + + True + True + gtk-zoom-out + + + 1 + 2 + 1 + 2 + GTK_FILL + GTK_FILL + + + + + True + Horizontal: + + + 2 + GTK_FILL + + + + + + + + False + + + + + True + + + False + + + + + True + + + True + 2 + 2 + + + True + Vertical: + + + 2 + GTK_FILL + + + + + + True + gtk-zoom-in + + + 1 + 2 + GTK_FILL + + + + + True + gtk-zoom-out + + + 1 + 2 + 1 + 2 + GTK_FILL + GTK_FILL + + + + + + + False + + + + + False + False + 1 + + + + + True + True + + + True + + + True + GDK_BUTTON1_MOTION_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + all + + + + + + + 2 + + + + + True + + + False + False + 3 + + + + + + + True + Saving file + False + gtk-dialog-error + dialog + + + + True + + + True + + + True + gtk-dialog-error + 6 + + + False + False + 10 + 0 + + + + + True + Filetype unknown! + +Use one of png, bmp, jpeg. + + + False + 1 + + + + + False + 2 + + + + + True + end + + + gtk-ok + True + True + True + False + True + + + False + False + 0 + + + + + False + end + 0 + + + + + + okbutton1 + + + + + + + + + + Machines + + + Processes + + + Threads + + + Processes/Machines + + + + + True + Info + mouse + 400 + 300 + True + gtk-info + + + True + True + 5 + + + True + True + + + True + + + True + 0 + 0 + 5 + 3 + label14 + + + + + + + + + True + Overview + + + False + + + + + True + True + in + + + True + True + True + + + + + 1 + + + + + True + Machines + + + 1 + False + + + + + True + True + in + + + True + True + True + + + + + 2 + + + + + True + Processes + + + 2 + False + + + + + True + True + in + + + True + True + True + + + + + 3 + + + + + True + Threads + + + 3 + False + + + + + + + True + Configure Messages + mouse + 400 + 300 + True + gtk-info + + + True + True + + + True + + + 50 + True + + + Store + True + True + True + + + 0 + + + + + True + + + All (send) + True + True + True + + + 0 + + + + + None (send) + True + True + True + + + 1 + + + + + 1 + + + + + True + + + 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 + + + + + True + + + 50 + True + + + Store + True + True + True + + + 0 + + + + + True + + + All (send) + True + True + True + + + 0 + + + + + None (send) + True + True + True + + + 1 + + + + + 1 + + + + + True + + + 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 + + + + + + + + + + + + + + + True + + + 50 + True + + + True + + + 21 + True + Draw Tick every x Seconds: + + + False + 0 + + + + + True + True + ● + + + False + 1 + + + + + 0 + + + + + True + + + 21 + True + Draw Time every x tick: + + + False + False + 0 + + + + + True + True + ● + + + False + 1 + + + + + 1 + + + + + False + False + 0 + + + + + Set Ticks + 26 + True + True + True + + + False + False + 1 + + + + + Auto + True + True + False + True + + + 1 + + + + + + + + + True + + + 50 + True + + + True + + + 21 + True + Start Time: + + + False + 0 + + + + + True + True + ● + + + False + 1 + + + + + 0 + + + + + True + + + 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 + True + preferences-other + normal + False + + + 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 + True + Running + #000000000000 + + + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Suspended + True + Suspended + #000000000000 + + + 1 + 2 + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Blocked + True + Blocked + #000000000000 + + + 1 + 2 + 2 + 3 + GTK_FILL + + + + + + True + True + True + True + Idle + True + Idle + #000000000000 + + + 1 + 2 + 3 + 4 + GTK_FILL + + + + + + + + + + True + <b>Status</b> + True + + + + + + + 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 + True + System-Messages + #000000000000 + + + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Head-Messages + True + Head-Messages + #000000000000 + + + 1 + 2 + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Data-Messages + True + Data-Messages + #000000000000 + + + 1 + 2 + 2 + 3 + GTK_FILL + + + + + + True + True + True + True + Block-Messages + Block-Messages + #000000000000 + + + 1 + 2 + 3 + 4 + GTK_FILL + + + + + + True + True + True + True + Receive-Phase + True + Receive-Phase + #000000000000 + + + 1 + 2 + 4 + 5 + GTK_FILL + + + + + + + + + + True + <b>Messages</b> + True + + + + + 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 + True + Marker-Line + #000000000000 + + + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Marker-Label + True + Marker-Label + #000000000000 + + + 1 + 2 + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Startup-Marker + True + Startup-Marker + #000000000000 + + + 1 + 2 + 2 + 3 + GTK_FILL + + + + + + + + + + True + <b>Marker</b> + True + + + + + 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 + True + Background-Color + #000000000000 + + + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Axes + True + Axes + #000000000000 + + + 1 + 2 + 1 + 2 + GTK_FILL + + + + + + True + True + True + True + Axes-Label + True + Axes-Label + #000000000000 + + + 1 + 2 + 2 + 3 + GTK_FILL + + + + + + + + + + True + <b>Chart</b> + True + + + + + 1 + 2 + 1 + 2 + + + + + 1 + + + + + True + end + + + gtk-cancel + True + True + True + True + + + False + False + 0 + + + + + gtk-ok + True + True + True + True + + + False + False + 1 + + + + + False + end + 0 + + + + + + btnColorsCancel + btnColorsSave + + + +