edentv-4.9.1: EdenTvType.hs
{- 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
-}
{-# LANGUAGE CPP #-}
-- JB: adapted instances (see end of file)
module EdenTvType where
import Data.Tree
import Data.Word
import qualified Data.Map as M
import qualified Data.Sequence as S
--import DeepSeq
import GHC.RTS.Events (ThreadStopStatus(..))
import Graphics.UI.Gtk.Gdk.Pixbuf
import Graphics.UI.Gtk.Gdk.GC
-- A State to carry around:
-- What has to be drawn and how?
data ViewerState = VS
{ selRow :: [Double] -- currently selected row, [] if none
, selView :: Int -- machine- (0), process- (1) or threadView (2)
, locTime :: Bool -- all machines starting simultaneously
, showMsg :: Bool -- draw messages?
, matrixM :: [Double] -- \ :-)
, matrixP :: [Double] -- these lists control sorting in diffrent views
, matrixT :: [Double] -- /
, matrixGP :: [Double]
, ommitRedraw :: Bool
, clicked :: Bool
, deleteSel :: Bool
, noDND :: Bool
, oldView :: Maybe Pixbuf
, confMachines :: [(MachineID, (Bool,Bool))] -- show in/out Messages Machines
, confProcesses :: [(ProcessID, (Bool,Bool))] -- show in/out Messages Procs
, autoTicks :: Bool
, tickSkip :: Seconds
, tickMark :: Int
, filename :: String -- the trace file the data was read from
, ignoreMessages :: Bool -- indicates if the trace file was parsed without messages
} deriving Show
instance Show Pixbuf where
show x = "pixbuf"
data EdenTvState = ES
{ lastPath :: String
, colors :: Colors
} deriving Show
data ColorRGBA = RGBA
{ rgbColor :: Color
, alpha :: Word16
} deriving Show
data Colors = Colors
{ statusRunning :: ColorRGBA
, statusSuspended :: ColorRGBA
, statusBlocked :: ColorRGBA
, statusIdle :: ColorRGBA
, messagesSystem :: ColorRGBA
, messagesHead :: ColorRGBA
, messagesData :: ColorRGBA
, messagesHeadLocal :: ColorRGBA
, messagesDataLocal :: ColorRGBA
, messagesBlock :: ColorRGBA
, messagesReceive :: ColorRGBA
, markerLine :: ColorRGBA
, markerLabel :: ColorRGBA
, markerStartup :: ColorRGBA
, chartBackground :: ColorRGBA
, chartAxes :: ColorRGBA
, chartAxesLabel :: ColorRGBA
} deriving Show
rgba :: Word16 -> Word16 -> Word16 -> Word16 -> ColorRGBA
rgba r g b a = RGBA {rgbColor = (Color r g b), alpha = a}
rgb :: Word16 -> Word16 -> Word16 -> ColorRGBA
rgb r g b = rgba r g b 65535
type Seconds = Double
type InportID = Int
type OutportID = Int
class EdenEvent e where
getEventTime :: e -> Seconds
setEventTime :: e -> Seconds -> e
-- A machine consists of an id and a list of related events
type MachineID = Int
--type Machine = (MachineID,Int,Int,(Int,Int,Int),[MachineEvent])
-- (mID, allP,blkP,(#Proc,#sent,#rcv),events)
data 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 {-# 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)
setEventTime (StartMachine _) s = StartMachine s
setEventTime (EndMachine _) s = EndMachine s
setEventTime (GCMachine _ g a c l) s = GCMachine s g a c l
setEventTime (IdleMachine _) s = IdleMachine s
setEventTime (RunningMachine _) s = RunningMachine s
setEventTime (SuspendedMachine _) s = SuspendedMachine s
setEventTime (BlockedMachine _) s = BlockedMachine s
setEventTime (MNewProcess _) s = MNewProcess s
setEventTime (MKillBProcess _) s = MKillBProcess s
setEventTime (MRunProcess _) s = MRunProcess s
setEventTime (MSuspendProcess _) s = MSuspendProcess s
setEventTime (MBlockProcess _) s = MBlockProcess s
setEventTime (MIdleProcess _) s = MIdleProcess s
{-instance DeepSeq MachineEvent where
deepSeq (StartMachine sec) y = deepSeq sec y
deepSeq (EndMachine sec) y = deepSeq sec y
-}
-- A process is identified by its own id and the machine's id
-- it is running on, completed with it's events
--type ProcessID = (MachineID,Int) -- (MachineID,ProcessID)
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 {-# 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
setEventTime (NewProcess _) s = NewProcess s
setEventTime (LabelProcess _ l) s = LabelProcess s l
setEventTime (KillProcess _ i) s = KillProcess s i
setEventTime (GCProcess _ g a c l) s = GCProcess s g a c l
setEventTime (IdleProcess _) s = IdleProcess s
setEventTime (RunningProcess _) s = RunningProcess s
setEventTime (SuspendedProcess _) s = SuspendedProcess s
setEventTime (BlockedProcess _) s = BlockedProcess s
setEventTime (PNewThread _) s = PNewThread s
setEventTime (PKillRThread _) s = PKillRThread s
setEventTime (PKillSThread _) s = PKillSThread s
setEventTime (PKillBThread _) s = PKillBThread s
setEventTime (PRunThread _) s = PRunThread s
setEventTime (PSuspendThread _) s = PSuspendThread s
setEventTime (PBlockThread _) s = PBlockThread s
setEventTime (PDeblockThread _) s = PDeblockThread s
-- Threads also have events and an identifier.
type ThreadID = (ProcessID,Int) -- (MachineID,ProcessID,ThreadID)
type Thread = (ThreadID,[ThreadEvent])
type OpenThread = (MachineID,(ThreadID,ThreadEvent),[Thread])
data ThreadEvent
= NewThread {-# 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 !BlockReason -- 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
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
-}
type BlockReason = GHC.RTS.Events.ThreadStopStatus
instance Eq ThreadStopStatus where
NoStatus == NoStatus = True
HeapOverflow == HeapOverflow = True
StackOverflow == StackOverflow = True
ThreadYielding == ThreadYielding = True
ThreadBlocked == ThreadBlocked = True
ThreadFinished == ThreadFinished = True
ForeignCall == ForeignCall = True
BlockedOnMVar == BlockedOnMVar = True
BlockedOnMVarRead == BlockedOnMVarRead = True
-- since GHC-7.8.2/ghc-events-0.4.3.1
BlockedOnBlackHole == BlockedOnBlackHole = True
BlockedOnRead == BlockedOnRead = True
BlockedOnWrite == BlockedOnWrite = True
BlockedOnDelay == BlockedOnDelay = True
BlockedOnSTM == BlockedOnSTM = True
BlockedOnDoProc == BlockedOnDoProc = True
BlockedOnCCall == BlockedOnCCall = True
BlockedOnCCall_NoUnblockExc == BlockedOnCCall_NoUnblockExc = True
BlockedOnMsgThrowTo == BlockedOnMsgThrowTo = True
ThreadMigrating == ThreadMigrating = True
BlockedOnMsgGlobalise == BlockedOnMsgGlobalise = True
(BlockedOnBlackHoleOwnedBy _) == (BlockedOnBlackHoleOwnedBy _) = True
_ == _ = False
-- Messages:
data ReasonType =
RFork | -- legacy code: 85
Connect | -- legacy code: 86
DataMes | -- legacy code: 87
Head | -- legacy code: 88
Constr | -- legacy code: 89
Part | -- legacy code: 90
Terminate | -- legacy code: 91
Default | -- legacy code: -1
BlockReason | -- legacy code: 1
LocalHead | -- new: optimized message on local machine
LocalDataMes -- new: optimized message on local machine
deriving (Show, Eq, Ord)
type Reason = ReasonType
type Size = Int
-- Map of open messages per process.
--
-- Key: sender process id
-- Value: all message events (send and receive) that were
-- triggered for messages sent by this process
--
type OpenMessagesPerProcess = M.Map ProcessID OpenMessages
-- Map of open messages for a process. The key used in this map (`OpenMessageKey`)
-- is not unique for a message event. It groups messages sent to the same process
-- through the same channel (inport/outport) and with the same type and reason.
-- These messages with the same key are organized in a sequence/queue, so that
-- the message events can be matched in the right order.
--
type OpenMessages = M.Map OpenMessageKey (S.Seq SmallOpenMessageEvent)
type OpenMessageKey = (OpenMessageType, ProcessID, OutportID, InportID, Reason)
data OpenMessageType = TORM | TOSM deriving (Show, Eq, Ord)
-- This type is used to store an open message as value in `OpenMessages`.
-- All other information of the message is already contained in the map key.
--
data SmallOpenMessageEvent
= SmallORM {-# 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 {-# 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
-}
-- Message: Complete message with send- and receive information
type ChannelID = (ProcessID,OutportID,ProcessID,InportID)
data Message = MSG {-# UNPACK #-} !ChannelID {-# UNPACK #-} !Seconds {-# UNPACK #-} !Seconds !Reason {-# UNPACK #-} !Size
-- channel stime rtime tag size
deriving (Show,Eq)
{-instance DeepSeq Message where
deepSeq (MSG times procs ports info) y = deepSeq times $ deepSeq procs $ deepSeq ports $ deepSeq info y
-}
-- the time it took to receive a message
type ReceiveLength = ((MachineID, [(Int,Seconds)]), Seconds, Seconds)
-- HeadMessage: Messages of type 100
type Count = Int
type DSize = Double
type OpenHeadMessage = (ChannelID,Size,Count,[Seconds],[Seconds])
-- channel, sum of sizes, quantity, sending/receiving times
type HeadMessage = (ChannelID,(Seconds,Seconds,Seconds,Seconds),DSize,Count)
-- channel stimeA,rtimeA stimeO,rtimeO size num
type OpenProcMessage = (MachineID,[(ProcessID,OpenMessageEvent)],[(ProcessID,OpenMessageEvent)],[ProcessID])
-- rcvMach sent Messages rcvd Messages NewProcess
type OpenMessageList = (OpenMessagesPerProcess,[Message],([OpenProcMessage],ProcessList,ProcessTree),([OpenHeadMessage],Double,[HeadMessage]))
type MessageList = (
[Message], --
[Message], -- additional messages: messages sent in a stream (bulk messages)
[HeadMessage], -- msgs from
ProcessTree,
[ReceiveLength] -- time to receive the messages
)
type ProcessList = [(ProcessID,[ProcessID])]
type ProcessTree = (Tree ProcessID) -- Node ProcessID [ProcessTree])
-- (Trace-)Events:
type EventID = Int
type NewEvent = ((EventID,Seconds,[Int]),Maybe String)
-- datatype used within the calculation
type OpenEvents = (
([Machine], [Process], [OpenThread]), -- list of machines/processes/threads
[(MachineID,Double)], -- machine starttimes
OpenMessageList, -- o/c Msgs
(Seconds,Seconds,Int,Int)) -- min_t max_t #P maxLD
-- The main datatype for the generated list of information
-- type Events = (
-- ([Machine], [Process], [Thread]), -- list of machines/processes/threads
-- [(MachineID, Double)], -- start-times per machine
-- (Seconds, [(MachineID, Seconds)]), -- maxStartup msgs/heads
-- MessageList,
-- ( Seconds, -- min_t
-- Seconds, -- max_t
-- Seconds, -- max_t_diff
-- Double, -- maxMsgSize
-- Double), -- MaxLD
-- (Int, Int, Int) -- number of machines/processes/threads
-- )
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__
instance (Show a,Show b,Show c,Show d,Show e,Show f) => Show (a,b,c,d,e,f)
instance (Show a,Show b,Show c,Show d,Show e,Show f,Show g) => Show (a,b,c,d,e,f,g)
instance (Show a,Show b,Show c,Show d,Show e,Show f,Show g,Show h) => Show (a,b,c,d,e,f,g,h)
instance (Show a,Show b,Show c,Show d,Show e,Show f,Show g,Show h,Show i) => Show (a,b,c,d,e,f,g,h,i)
instance (Show a,Show b,Show c,Show d,Show e,Show f,Show g,Show h,Show i,Show j) => Show (a,b,c,d,e,f,g,h,i,j)
#endif