module Control.Concurrent.CHP.Base where
import Control.Applicative
import Control.Arrow
import Control.Concurrent (myThreadId, threadDelay)
import Control.Concurrent.STM
import qualified Control.Exception.Extensible as C
import Control.Monad
import Data.Function (on)
import Data.List (findIndex, nub)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
import qualified Data.Set as Set
import Data.Unique
import System.IO
import qualified Text.PrettyPrint.HughesPJ
import Control.Concurrent.CHP.Event
import Control.Concurrent.CHP.Guard
import Control.Concurrent.CHP.Poison
import Control.Concurrent.CHP.ProcessId
import Control.Concurrent.CHP.Traces.Base
newtype Enrolled b a = Enrolled (b a) deriving (Eq)
newtype CHP a = PoisonT {runPoisonT :: forall b. TraceStore -> (a -> CHP' b) -> CHP' b}
instance Functor CHP where
fmap f m = PoisonT $ \t c -> runPoisonT m t (c . f)
instance Monad CHP where
return a = PoisonT $ const ($ a)
m >>= k = PoisonT $ \t c -> runPoisonT m t (\a -> runPoisonT (k a) t c)
instance Applicative CHP where
pure = return
(<*>) = ap
instance Alternative CHP where
empty = stop
a <|> b = priAlt [a, b]
liftIO_CHP :: IO a -> CHP a
liftIO_CHP m = PoisonT $ const $ \f -> (Standard (liftM NoPoison m) >>= f)
data CHP' a = Return a
| Altable TraceStore [(Guard, IO (WithPoison a))]
| Standard (IO (WithPoison a))
class Monad m => MonadCHP m where
liftCHP :: CHP a -> m a
class Trace t where
runCHPAndTrace :: CHP a -> IO (Maybe a, t Unique)
emptyTrace :: t u
prettyPrint :: Ord u => t u -> Text.PrettyPrint.HughesPJ.Doc
labelAll :: Ord u => t u -> t String
class Poisonable c where
poison :: MonadCHP m => c -> m ()
checkForPoison :: MonadCHP m => c -> m ()
makeAltable :: [(Guard, IO (WithPoison a))] -> CHP a
makeAltable gas = PoisonT $ \t f -> Altable t (map (second (&>>= pullOutStandard . f)) gas)
makeAltable' :: (TraceStore -> [(Guard, IO (WithPoison a))]) -> CHP a
makeAltable' gas = PoisonT $ \t f -> Altable t (map (second (&>>= pullOutStandard . f)) (gas t))
pullOutStandard :: CHP' a -> IO (WithPoison a)
pullOutStandard (Return x) = return (NoPoison x)
pullOutStandard (Altable tr gas) = selectFromGuards tr gas
pullOutStandard (Standard m) = m
wrapPoison :: TraceStore -> CHP a -> CHP' a
wrapPoison t (PoisonT m) = m t return
checkPoison :: WithPoison a -> CHP a
checkPoison (NoPoison x) = return x
checkPoison PoisonItem = PoisonT $ \_ _ -> Standard $ return PoisonItem
liftPoison :: (TraceStore -> CHP' a) -> CHP a
liftPoison m = PoisonT ((>>=) . m)
throwPoison :: CHP a
throwPoison = checkPoison PoisonItem
onPoisonTrap :: CHP a -> CHP a -> CHP a
onPoisonTrap (PoisonT body) (PoisonT handler)
= PoisonT $ \t f ->
let trap PoisonItem = pullOutStandard $ handler t f
trap (NoPoison x) = pullOutStandard $ f x in
case body t return of
Return x -> f x
Altable tr gas -> Altable tr (map (second (>>= trap)) gas)
Standard m -> Standard $ m >>= trap
onPoisonRethrow :: CHP a -> CHP () -> CHP a
onPoisonRethrow (PoisonT body) (PoisonT handler)
= PoisonT $ \t f ->
let handle PoisonItem = PoisonItem <$ (pullOutStandard $ handler t return)
handle (NoPoison x) = pullOutStandard $ f x in
case body t return of
Return x -> f x
Altable tr gas -> Altable tr (map (second (>>= handle)) gas)
Standard m -> Standard $ m >>= handle
poisonAll :: (Poisonable c, MonadCHP m) => [c] -> m ()
poisonAll = mapM_ poison
getTrace :: CHP TraceStore
getTrace = PoisonT (flip ($))
liftSTM :: STM a -> CHP a
liftSTM = liftIO_CHP . atomically
getProcessId :: TraceStore -> ProcessId
getProcessId (Trace (pid,_,_)) = pid
getProcessId (NoTrace pid) = pid
wrapProcess :: CHP a -> TraceStore -> (CHP' a -> IO (WithPoison a)) -> IO (Maybe (WithPoison a))
wrapProcess (PoisonT proc) t unwrapInner
= (Just <$> unwrapInner (proc t return)) `C.catches` allHandlers
where
response :: C.Exception e => e -> IO (Maybe a)
response x = do hPutStrLn stderr $ "(CHP) Thread terminated with: " ++ show x
return Nothing
allHandlers = [C.Handler (response :: C.IOException -> IO (Maybe a))
,C.Handler (response :: C.AsyncException -> IO (Maybe a))
,C.Handler (response :: C.NonTermination -> IO (Maybe a))
#if __GLASGOW_HASKELL__ >= 611
,C.Handler (response :: C.BlockedIndefinitelyOnSTM -> IO (Maybe a))
#else
,C.Handler (response :: C.BlockedIndefinitely -> IO (Maybe a))
#endif
,C.Handler (response :: C.Deadlock -> IO (Maybe a))
]
runCHPProgramWith :: TraceStore -> CHP a -> IO (Maybe a)
runCHPProgramWith start p
= do r <- wrapProcess p start pullOutStandard
case r of
Nothing -> putStrLn "Deadlock" >> return Nothing
Just PoisonItem -> putStrLn "Uncaught Poison" >> return Nothing
Just (NoPoison x) -> return (Just x)
runCHPProgramWith' :: SubTraceStore -> (ChannelLabels Unique -> IO t) -> CHP a -> IO (Maybe a, t)
runCHPProgramWith' subStart f p
= do tv <- atomically $ newTVar Map.empty
x <- runCHPProgramWith (Trace (rootProcessId, tv, subStart)) p
l <- atomically $ readTVar tv
t' <- f l
return (x, t')
data ManyToOneTVar a = ManyToOneTVar
{ mtoIsFinalValue :: a -> Bool
, mtoReset :: STM a
, mtoInter :: TVar a
, mtoFinal :: TVar (Maybe a)
}
instance Eq (ManyToOneTVar a) where
(==) = (==) `on` mtoFinal
newManyToOneTVar :: (a -> Bool) -> STM a -> a -> STM (ManyToOneTVar a)
newManyToOneTVar f r x
= do tvInter <- newTVar x
tvFinal <- newTVar $ if f x then Just x else Nothing
return $ ManyToOneTVar f r tvInter tvFinal
writeManyToOneTVar :: (a -> a) -> ManyToOneTVar a -> STM a
writeManyToOneTVar f (ManyToOneTVar done reset tvInter tvFinal)
= do x <- readTVar tvInter
if done (f x)
then do writeTVar tvFinal $ Just $ f x
reset >>= writeTVar tvInter
else writeTVar tvInter $ f x
return $ f x
readManyToOneTVar :: ManyToOneTVar a -> STM a
readManyToOneTVar (ManyToOneTVar _done _reset _tvInter tvFinal)
= do x <- readTVar tvFinal >>= maybe retry return
writeTVar tvFinal Nothing
return x
resetManyToOneTVar :: ManyToOneTVar a -> a -> STM ()
resetManyToOneTVar (ManyToOneTVar done reset tvInter tvFinal) x
| done x = (reset >>= writeTVar tvInter) >> writeTVar tvFinal (Just x)
| otherwise = writeTVar tvInter x >> writeTVar tvFinal Nothing
instance MonadCHP CHP where
liftCHP = id
instance Monad CHP' where
m >>= f = case m of
Return x -> f x
Altable tr altBody -> Altable tr $ map (second (&>>= pullOutStandard . f)) altBody
Standard s -> Standard $ s &>>= pullOutStandard . f
return = Return
instance Functor CHP' where
fmap = liftM
infixr 8 &>>=
(&>>=) :: IO (WithPoison a) -> (a -> IO (WithPoison b)) -> IO (WithPoison b)
(&>>=) m f = do v <- m
case v of
PoisonItem -> return PoisonItem
NoPoison x -> f x
selectFromGuards :: forall a. TraceStore -> [(Guard, IO (WithPoison a))] -> IO (WithPoison a)
selectFromGuards tr items
| null (eventGuards guards)
= join $ liftM snd $ waitNormalGuards items Nothing
| otherwise = do
tv <- newTVarIO Nothing
tid <- myThreadId
mn <- atomically $ do
ret <- enableEvents tv (tid, pid)
(maybe id take earliestReady $ eventGuards guards)
(isNothing earliestReady)
either (const $ return ()) whenLast ret
return $ either Left (Right . getRec . fst) ret
case (mn, earliestReady) of
(Right r, _) -> recordAndRun r
(Left _, Just _) ->
join $ liftM snd $ waitNormalGuards items Nothing
(Left disable, Nothing) ->
do (wasAltingBarrier, pr) <- waitNormalGuards
guardsAndRec $ Just $ liftM getRec $ waitAlting tv
if wasAltingBarrier
then recordAndRun pr
else
do mn' <- atomically $ disable
case mn' of
Just pr' -> recordAndRun $ getRec pr'
Nothing -> recordAndRun pr
where
guards = map fst items
earliestReady = findIndex isSkipGuard guards
recordAndRun :: WithPoison ([RecordedIndivEvent Unique], IO (WithPoison a)) -> IO (WithPoison a)
recordAndRun PoisonItem = return PoisonItem
recordAndRun (NoPoison (r, m)) = recordEvent r tr >> m
guardsAndRec :: [(Guard, WithPoison ([RecordedIndivEvent Unique], IO (WithPoison a)))]
guardsAndRec = map (second (NoPoison . (,) [])) items
getRec :: (SignalValue, Map.Map Unique (Integer, RecordedEventType))
-> WithPoison ([RecordedIndivEvent Unique], IO (WithPoison a))
getRec (Signal PoisonItem, _) = PoisonItem
getRec (Signal (NoPoison n), m)
= case items !! n of
(EventGuard recF _ _, body) ->
NoPoison (recF (makeLookup m), body)
(_, body) -> NoPoison ([], body)
whenLast ((sigVal,_),es)
= do recordEventLast (nub es) tr
case sigVal of
Signal PoisonItem -> return ()
Signal (NoPoison n) ->
let EventGuard _ act _ = guards !! n
in actWhenLast act (Map.fromList $ map (snd *** Set.size) es)
pid = getProcessId tr
waitAlting :: SignalVar -> STM (SignalValue, Map.Map Unique (Integer, RecordedEventType))
waitAlting tv = do b <- readTVar tv
case b of
Nothing -> retry
Just ns -> return ns
makeLookup :: Map.Map Unique (Integer, RecordedEventType) -> Unique -> (Integer,
RecordedEventType)
makeLookup m u = fromMaybe (error "CHP: Unique not found in alt") $ Map.lookup u m
eventGuards :: [Guard] -> [((SignalValue, STM ()), [Event])]
eventGuards guards = [((Signal $ NoPoison n, actAlways acts), ab)
| (n, EventGuard _ acts ab) <- zip [0..] guards]
waitNormalGuards :: [(Guard, b)] -> Maybe (STM b) -> IO (Bool, b)
waitNormalGuards guards extra
= do enabled <- sequence $ mapMaybe enable guards
atomically $ foldr orElse retry $ maybe id ((:) . liftM ((,) True)) extra $ enabled
where
enable :: (Guard, b) -> Maybe (IO (STM (Bool, b)))
enable (SkipGuard, x) = Just $ return $ return (False, x)
enable (TimeoutGuard g, x) = Just $ liftM (>> return (False, x)) g
enable _ = Nothing
priAlt :: [CHP a] -> CHP a
priAlt xs = PoisonT $ \t f -> priAlt' t (map (wrapPoison t) xs) >>= f
priAlt' :: TraceStore -> [CHP' a] -> CHP' a
priAlt' tr = Altable tr . filter (not . isStopGuard . fst) . concatMap getAltable
where
getAltable :: CHP' a -> [(Guard, IO (WithPoison a))]
getAltable (Return x) = [(SkipGuard, return $ NoPoison x)]
getAltable (Altable _ gs) = gs
getAltable (Standard m) = [(SkipGuard, m)]
stop :: CHP a
stop = makeAltable [(stopGuard, hang)]
where
hang :: IO a
hang = forever $ threadDelay maxBound