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 = (RecordedEventType, Unique)
data RecordedIndivEvent =
ChannelWrite Unique
| ChannelRead Unique
| BarrierSyncIndiv Unique
| ClockSyncIndiv Unique String
deriving (Eq, Ord)
type RecEvents = ([RecordedEvent], [RecordedIndivEvent])
getName :: String -> Unique -> State (Map.Map Unique 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 :: RecordedEvent -> State (Map.Map Unique String) String
nameEvent (t, c) = liftM (++ suffix) $ getName prefix c
where
(prefix, suffix) = case t of
ChannelComm -> ("_c","")
BarrierSync -> ("_b","")
ClockSync st -> ("_t", ':' : st)
nameIndivEvent :: RecordedIndivEvent -> State (Map.Map Unique String) String
nameIndivEvent (ChannelWrite c) = do c' <- getName "_c" c
return $ c' ++ "!"
nameIndivEvent (ChannelRead c) = do c' <- getName "_c" c
return $ c' ++ "?"
nameIndivEvent (BarrierSyncIndiv c) = do c' <- getName "_b" c
return $ c' ++ "*"
nameIndivEvent (ClockSyncIndiv c t) = do c' <- getName "_t" c
return $ c' ++ ":" ++ t
ensureAllNamed :: Map.Map Unique String -> [RecordedEvent] -> Map.Map Unique String
ensureAllNamed m es = execState (mapM_ nameEvent es) m
ensureAllNamedIndiv :: Map.Map Unique String -> [RecordedIndivEvent] -> Map.Map Unique String
ensureAllNamedIndiv m es = execState (mapM_ nameIndivEvent es) m
type TraceT = StateT ([Int], TraceStore)
data TraceStore =
NoTrace
| Trace (ProcessId, TVar ChannelLabels, SubTraceStore)
type ChannelLabels = Map.Map Unique String
data SubTraceStore =
Hierarchy (Structured RecordedIndivEvent)
| CSPTraceRev (TVar [(Int, [RecordedEvent])])
| VCRTraceRev (TVar [Set.Set (Set.Set ProcessId, RecordedEvent)])
data Ord a => Structured a =
StrEvent a
| Par [Structured a]
| RevSeq [(Int, [Structured a])]
deriving (Eq, Ord)
recordEventLast :: [(RecordedEvent, 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] -> TraceT IO ()
recordEvent e
= do (x,y) <- get
case (x, y) of
(as, Trace (pid,tvls,Hierarchy es)) ->
put (as, Trace (pid, tvls, Hierarchy (foldl (flip addSeqEventH) es e)))
_ -> return ()
mergeSubProcessTraces :: [TraceStore] -> TraceT IO ()
mergeSubProcessTraces ts
= do s <- get
case s of
(as, Trace (pid, tvls, Hierarchy es)) ->
put (as, Trace (pid, tvls, Hierarchy $ addParEventsH ts' es))
where ts' = [t | Trace (_,_,Hierarchy t) <- ts]
_ -> return ()
shouldMakeNewSetVCR :: Set.Set ProcessId -> Set.Set (Set.Set ProcessId, RecordedEvent)
-> 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 (a, TraceStore) IO ()
labelEvent e l
= labelUnique (getEventUnique e) l
labelUnique :: Unique -> String -> StateT (a, 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 (a, 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