module Control.Concurrent.CHP.Traces.Base where
import Control.Concurrent.STM
import Control.Monad.State
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Unique
import Control.Concurrent.CHP.Event
import Control.Concurrent.CHP.ProcessId
type RecordedEvent u = (RecordedEventType, u)
data RecordedIndivEvent u =
ChannelWrite u Integer
| ChannelRead u Integer
| BarrierSyncIndiv u Integer
| ClockSyncIndiv u Integer String
deriving (Eq, Ord, Read, Show)
recordedIndivEventLabel :: RecordedIndivEvent u -> u
recordedIndivEventLabel (ChannelWrite x _) = x
recordedIndivEventLabel (ChannelRead x _) = x
recordedIndivEventLabel (BarrierSyncIndiv x _) = x
recordedIndivEventLabel (ClockSyncIndiv x _ _) = x
recordedIndivEventSeq :: RecordedIndivEvent u -> Integer
recordedIndivEventSeq (ChannelWrite _ n) = n
recordedIndivEventSeq (ChannelRead _ n) = n
recordedIndivEventSeq (BarrierSyncIndiv _ n) = n
recordedIndivEventSeq (ClockSyncIndiv _ n _) = n
indivRec :: (u -> Integer -> RecordedIndivEvent u)
-> u -> (u -> Integer) -> (RecordedIndivEvent u)
indivRec r u f = r u (f u)
indivRecJust :: (u -> Integer -> RecordedIndivEvent u)
-> u -> (u -> Integer) -> Maybe (RecordedIndivEvent u)
indivRecJust r u f = Just $ indivRec r u f
type RecEvents = ([RecordedEvent Unique], [RecordedIndivEvent Unique])
getName :: Ord u => String -> u -> State (Map.Map u String) String
getName prefix u
= do m <- get
case Map.lookup u m of
Just x -> return x
Nothing -> let x = prefix ++ show (Map.size m) in
do put $ Map.insert u x m
return x
nameEvent :: Ord u => RecordedEvent u -> State (Map.Map u String) String
nameEvent (t, c) = liftM (++ suffix) $ getName prefix c
where
(prefix, suffix) = case t of
ChannelComm -> ("_c","")
BarrierSync -> ("_b","")
ClockSync st -> ("_t", ':' : st)
nameEvent' :: Ord u => RecordedEvent u -> State (Map.Map u String) (RecordedEvent String)
nameEvent' (t, c) = do c' <- getName prefix c
return (t, c' ++ suffix)
where
(prefix, suffix) = case t of
ChannelComm -> ("_c","")
BarrierSync -> ("_b","")
ClockSync st -> ("_t", ':' : st)
nameIndivEvent :: Ord u => RecordedIndivEvent u -> State (Map.Map u String) String
nameIndivEvent (ChannelWrite c n) = do c' <- getName "_c" c
return $ c' ++ "![" ++ show n ++ "]"
nameIndivEvent (ChannelRead c n) = do c' <- getName "_c" c
return $ c' ++ "?[" ++ show n ++ "]"
nameIndivEvent (BarrierSyncIndiv c n) = do c' <- getName "_b" c
return $ c' ++ "[" ++ show n ++ "]"
nameIndivEvent (ClockSyncIndiv c n t) = do c' <- getName "_t" c
return $ c' ++ ":" ++ t
++ "[" ++ show n ++ "]"
nameIndivEvent' :: Ord u => RecordedIndivEvent u -> State (Map.Map u String) (RecordedIndivEvent String)
nameIndivEvent' (ChannelWrite c n) = do c' <- getName "_c" c
return $ ChannelWrite c' n
nameIndivEvent' (ChannelRead c n) = do c' <- getName "_c" c
return $ ChannelRead c' n
nameIndivEvent' (BarrierSyncIndiv c n) = do c' <- getName "_b" c
return $ BarrierSyncIndiv c' n
nameIndivEvent' (ClockSyncIndiv c n t) = do c' <- getName "_t" c
return $ ClockSyncIndiv c' n t
type TraceT = StateT TraceStore
data TraceStore =
NoTrace
| Trace (ProcessId, TVar (ChannelLabels Unique), SubTraceStore)
mapSubTrace :: (SubTraceStore -> SubTraceStore) -> TraceStore -> TraceStore
mapSubTrace _ NoTrace = NoTrace
mapSubTrace f (Trace (pid, tv, s)) = Trace (pid, tv, f s)
type ChannelLabels u = Map.Map u String
data SubTraceStore =
Hierarchy (Structured (RecordedIndivEvent Unique))
| CSPTraceRev (TVar [(Int, [RecordedEvent Unique])])
| VCRTraceRev (TVar [Set.Set (Set.Set ProcessId, RecordedEvent Unique)])
data Ord a => Structured a =
StrEvent a
| Par [Structured a]
| RevSeq [(Int, [Structured a])]
deriving (Eq, Ord)
recordEventLast :: [(RecordedEvent Unique, Set.Set ProcessId)] -> TraceStore -> STM ()
recordEventLast news y
= case y of
Trace (_,_,CSPTraceRev tv) ->
do t <- readTVar tv
writeTVar tv $! foldl (flip addRLE) t (map fst news)
Trace (pid, _, VCRTraceRev tv) -> do
t <- readTVar tv
let pidSet = (foldl Set.union (Set.singleton pid) $ map snd news)
news' = map (\(a,b) -> (b,a)) news
t' = case t of
[] -> [Set.fromList news']
(z:zs) | shouldMakeNewSetVCR pidSet z
-> Set.fromList news' : t
| otherwise
-> foldl (flip Set.insert) z news' : zs
writeTVar tv $! t'
_ -> return ()
recordEvent :: [RecordedIndivEvent Unique] -> TraceT IO ()
recordEvent e = modify $ mapSubTrace $ \(Hierarchy es) ->
Hierarchy (addParEventsH (map StrEvent e) es)
mergeSubProcessTraces :: [TraceStore] -> TraceT IO ()
mergeSubProcessTraces ts
= modify $ mapSubTrace $ \(Hierarchy es) -> Hierarchy (addParEventsH ts' es)
where
ts' = [t | Trace (_,_,Hierarchy t) <- ts]
shouldMakeNewSetVCR :: Set.Set ProcessId -> Set.Set (Set.Set ProcessId, RecordedEvent Unique)
-> Bool
shouldMakeNewSetVCR newIds existingSet
= exists existingSet $ \(bigP,_) -> exists bigP $ \p -> exists newIds $ \q ->
p `pidLessThanOrEqual` q
where
exists :: Ord a => Set.Set a -> (a -> Bool) -> Bool
exists s f = not . Set.null $ Set.filter f s
compress :: (Eq a, Ord a) => Structured a -> Structured a
compress (RevSeq ((1,s):(n,s'):ss))
| n == 1 && (s `isPrefixOf` s') = compress $ RevSeq $ (2,s):(1,drop (length s) s'):ss
| s == s' = compress $ RevSeq $ (n+1,s'):ss
compress x = x
addParEventsH :: (Eq a, Ord a) => [Structured a] -> Structured a -> Structured a
addParEventsH es t = let n = es in case t of
StrEvent _ -> RevSeq [(1, [Par n, t])]
Par _ -> RevSeq [(1, [Par n, t])]
RevSeq ((1,s):ss) -> compress $ RevSeq $ (1,Par n : s) : ss
RevSeq ss -> compress $ RevSeq $ (1, [Par n]):ss
addSeqEventH :: (Eq a, Ord a) => a -> Structured a -> Structured a
addSeqEventH e (StrEvent e') = RevSeq [(1,[StrEvent e, StrEvent e'])]
addSeqEventH e (Par p) = RevSeq [(1,[StrEvent e, Par p])]
addSeqEventH e (RevSeq ((1,s):ss))
| (StrEvent e) `notElem` s = compress $ RevSeq $ (1,StrEvent e:s):ss
addSeqEventH e (RevSeq ss) = compress $ RevSeq $ (1,[StrEvent e]):ss
addRLE :: Eq a => a -> [(Int,[a])] -> [(Int,[a])]
addRLE x ((n,[e]):nes)
| x == e = (n+1,[e]):nes
addRLE x allEs@[(1,es)]
| x == head es = [(2, [x]), (1, tail es)]
| x `elem` es = (1,[x]):allEs
| otherwise = [(1,x:es)]
addRLE x allEs@((1,es):(n,es'):nes)
| x == head es' && es == tail es' = (n+1,es'):nes
| x `elem` es = (1,[x]):allEs
| otherwise = (1,x:es):(n,es'):nes
addRLE x nes = (1,[x]):nes
labelEvent :: Event -> String -> StateT TraceStore IO ()
labelEvent e l
= labelUnique (getEventUnique e) l
labelUnique :: Unique -> String -> StateT TraceStore IO ()
labelUnique u l
= do t <- get
case t of
NoTrace -> return ()
Trace (_,tvls,_) -> add tvls
where
add :: TVar (Map.Map Unique String) -> StateT TraceStore IO ()
add tv = liftIO $ atomically $ do
m <- readTVar tv
writeTVar tv $ Map.insert u l m
blankTraces :: TraceStore -> Int -> IO [TraceStore]
blankTraces NoTrace n = return $ replicate n NoTrace
blankTraces (Trace (pid, tvls, subT)) n =
return [Trace (newId, tvls, newSubT) | newId <- newIds]
where
newIds :: [ProcessId]
newIds = let ProcessId parts = pid in
[ProcessId $ parts ++ [ParSeq i 0] | i <- [0 .. (n 1)]]
newSubT :: SubTraceStore
newSubT = case subT of
Hierarchy {} -> Hierarchy $ RevSeq []
_ -> subT