chp-1.0.1: Control/Concurrent/CHP/Alt.hs
-- Communicating Haskell Processes.
-- Copyright (c) 2008, University of Kent.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
-- * Redistributions of source code must retain the above copyright
-- notice, this list of conditions and the following disclaimer.
-- * Redistributions in binary form must reproduce the above copyright
-- notice, this list of conditions and the following disclaimer in the
-- documentation and/or other materials provided with the distribution.
-- * Neither the name of the University of Kent nor the names of its
-- contributors may be used to endorse or promote products derived from
-- this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
-- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-- | A module containing the ALT constructs. An ALT (a term inherited from
-- occam) is a choice between several events. In CHP, we say that an event
-- must support alting to be a valid choice. Events that /do/ support alting are:
--
-- * 'Control.Concurrent.CHP.Monad.skip'
--
-- * 'Control.Concurrent.CHP.Monad.waitFor'
--
-- * Reading from a channel (including extended reads)
--
-- * Writing to a channel
--
-- * Synchronising on a barrier
--
-- * An alting construct (that is, you can nest alts)
--
-- * A sequential composition, if the first event supports alting
--
-- Examples of events that do /NOT/ support alting are:
--
-- * Enrolling and resigning with a barrier
--
-- * Poisoning a channel
--
-- * Processes composed in parallel
--
-- * Any lifted IO event
--
-- * Creating channels, barriers, etc
--
-- * Claiming a shared channel (yet...)
--
-- It is not easily possible to represent this at the type level (while still
-- making CHP easy to use). Therefore it is left to you to not try to alt
-- over something that does not support it. Given how much of the library
-- does support alting, that should hopefully be straightforward.
--
-- Here are some examples of using alting:
--
-- * Wait for an integer channel, or 1 second to elapse:
--
-- > liftM Just (readChannel c) <-> (waitFor 1000000 >> return Nothing)
--
-- * Check if a channel is ready, otherwise return immediately. Note that you must use the
-- alt operator with priority here, otherwise your skip guard might be chosen,
-- even when the channel is ready.
--
-- > liftM Just (readChannel c) </> (skip >> return Nothing)
--
-- * Wait for input from one of two (identically typed) channels
--
-- > readChannel c0 <-> readChannel c1
--
-- * Check if a channel is ready; if so send, it on, otherwise return immediately:
--
-- > (readChannel c >>= writeChannel d) </> skip
module Control.Concurrent.CHP.Alt (alt, (<->), priAlt, (</>)) where
import Control.Concurrent.STM
import Control.Monad.State
import Control.Monad.Trans
import Data.List
import Data.Maybe
import qualified Data.Set as Set
import System.IO
import Control.Concurrent.CHP.Base
import Control.Concurrent.CHP.Event
import Control.Concurrent.CHP.Guard
import Control.Concurrent.CHP.Traces.Base
-- | An alt between several actions, with arbitrary priority. The first
-- available action is chosen (with an arbitrary choice if many guards are
-- available at the same time), its body run, and its value returned.
alt :: [CHP a] -> CHP a
alt = priAlt
-- | An alt between several actions, with arbitrary priority. The first
-- available action is chosen (biased towards actions nearest the beginning
-- of the list), its body run, and its value returned.
priAlt :: [CHP a] -> CHP a
priAlt items = (liftPoison $ priAlt' $ map wrapPoison items) >>= checkPoison
-- | A useful operator to perform an 'alt'. This operator is associative,
-- and has arbitrary priority. When you have lots of guards, it is probably easier
-- to use the 'alt' function. 'alt' /may/ be more efficent than
-- foldl1 (\<-\>)
(<->) :: CHP a -> CHP a -> CHP a
(<->) a b = alt [a,b]
-- | A useful operator to perform a 'priAlt'. This operator is
-- associative, and has descending priority (that is, it is
-- left-biased). When you have lots of actions, it is probably easier
-- to use the 'priAlt' function. 'priAlt' /may/ be more efficent than
-- foldl1 (\<\/\>)
(</>) :: CHP a -> CHP a -> CHP a
(</>) a b = priAlt [a,b]
infixl </>
infixl <->
-- ALTing is implemented as follows in CHP. The CHP monad has [Int] in its
-- state. When you choose between N events, you form one body, that pulls
-- the next number from the head of the state and executes the body for the
-- event corresponding to that index. Nested ALTs prepend to the list.
-- So for example, if you choose between:
--
-- > (a <-> b) <-> c
--
-- The overall number corresponding to a is [0,0], b is [0,1], c is [1]. The
-- outer choice peels off the head of the list. On 1 it executes c; on 0 it
-- descends to the nested choice, which takes the next number in the list and
-- executes a or b given 0 or 1 respectively.
--
-- If an event is poisoned, an integer (of arbitrary value) is /appended/ to
-- the list. Thus when an event-based guard is executed, if the list in the
-- state is non-empty, it knows it has been poisoned.
--
-- I did try implementing this in a more functional manner, making each event
-- in the monad take [Int] and return the body, rather than using state. However,
-- I had some memory efficiency problems so I went with the state-monad-based
-- approach instead.
priAlt' :: forall a. [CHP' a] -> CHP' a
priAlt' items
-- Our guard is a nested guard of all our sub-guards.
-- Our action-if-not-guard is to do the selection ourselves.
-- Our body is to read the numbered list, strip one off and follow the path,
-- ignoring the action-if-not-guard of the chosen body
= AltableT (NestedGuards $ wrappedGuards
,executeNumberedBody)
(selectFromGuards >> executeNumberedBody)
where
wrappedGuards :: [Guard]
wrappedGuards = map wrap flattenedGuards
where
wrap :: (Int, Guard) -> Guard
wrap (n, SkipGuard ns) = SkipGuard $ n : ns
wrap (n, EventGuard ns e act ab) = EventGuard (n:ns) e act ab
wrap (n, TimeoutGuard g) = TimeoutGuard $
do g' <- g
return $ do ns <- g'
return (n : ns)
wrap (_, _) = BadGuard
-- Polls the available guards, but ignores timeout guards and alting barrier
-- guards
checkNormalGuards :: STM (Maybe Int)
checkNormalGuards = foldl1 orElse $
(map checkGuard flattenedGuards) ++ [return Nothing]
where
checkGuard :: (Int, Guard) -> STM (Maybe Int)
checkGuard (n, BadGuard) = return $ Just n
checkGuard (n, SkipGuard {}) = return $ Just n
checkGuard (_, _) = retry
-- Waits for one of the normal (non-alting barrier) guards to be ready,
-- or the given transaction to complete
waitNormalGuards :: STM [Int] -> IO (Bool, [Int])
waitNormalGuards extra
= do guards <- mapM enable wrappedGuards
atomically $ foldl1 orElse (wrap True extra : map (wrap False) guards)
where
enable :: Guard -> IO (STM [Int])
enable (BadGuard) = return $ return []
enable (SkipGuard ns) = return $ return ns
enable (TimeoutGuard g) = g
enable _ = return retry -- This effectively ignores other guards
wrap :: Bool -> STM [Int] -> STM (Bool, [Int])
wrap b m = do x <- m
return (b, x)
-- The list of guards without any NestedGuards or StopGuards:
flattenedGuards :: [(Int, Guard)]
flattenedGuards = (flatten $ zip [0..] $ map (fst . getAltable) items)
where
flatten :: [(Int, Guard)] -> [(Int,Guard)]
flatten [] = []
flatten ((n,x):xs) = case x of
NestedGuards gs -> flatten $ zip (repeat n) gs ++ xs
StopGuard -> flatten xs
g -> (n, g) : flatten xs
-- The alting barrier guards:
eventGuards :: [(RecEvents, [Int], STM (), Event)]
eventGuards = [(rec,ns,act,ab) | EventGuard ns rec act ab <- wrappedGuards]
-- We must use isPrefixOf, because things are added in the case of poison
findEventAssoc :: [Int] -> RecEvents
findEventAssoc x = case filter (\(_,y,_,_) -> y `isPrefixOf` x) eventGuards of
[(rec,_,_,_)] -> rec
_ -> error "Could not find associated event in alt, internal logic error"
-- Stores a list of ints in the state
storeChoice :: [Int] -> TraceT IO ()
storeChoice ns = modify (\(_, es) -> (ns, es))
-- Performs the select operation on all the guards. The choice is stored
-- in the state ready to execute the bodies
selectFromGuards :: TraceT IO ()
selectFromGuards
| null eventGuards
= do (_,ns) <- liftIO $ waitNormalGuards retry
storeChoice ns
| otherwise
= do earliestReady <- liftIO $ atomically checkNormalGuards
tv <- liftIO . atomically $ newTVar Nothing
pid <- getProcessId
(_, tr) <- get
mn <- liftIO . atomically $ do
ret <- enableEvents tv pid
(maybe id take earliestReady eventGuards)
(isNothing earliestReady)
case ret of
Just ((e,_), pids, _) ->
do recordEventLast e (Set.fromList pids) tr
return ret
Nothing -> return ret
case (mn, earliestReady) of
-- An event -- and we were the last person to arrive:
-- The event must have been higher priority than any other
-- ready guards
(Just (rec, _, ns), _) ->
do recordEvent (snd rec)
storeChoice ns
-- No events were ready, but there was an available normal
-- guards. Re-run the normal guards; at least one will be ready
(Nothing, Just _) ->
do (_, ns) <- liftIO $ waitNormalGuards retry
storeChoice ns
-- No events ready, no other guards ready either
-- Events will have been enabled; wait for everything:
(Nothing, Nothing) ->
do (wasAltingBarrier, ns) <- liftIO $ waitNormalGuards $ waitAlting tv
if wasAltingBarrier
then recordEvent (snd $ findEventAssoc ns) >> storeChoice ns -- It was a barrier, all done
else
-- Another guard fired, but we must check in case
-- we have meanwhile been committed to taking an
-- event:
do mn' <- liftIO . atomically $ disableEvents tv (map fourth eventGuards)
case mn' of
-- An event overrides our non-event choice:
Just bns -> recordEvent (snd $ findEventAssoc bns) >> storeChoice bns
-- Go with the original option, no events
-- became ready:
Nothing -> storeChoice ns
where
waitAlting :: TVar (Maybe [Int]) -> STM [Int]
waitAlting tv = do b <- readTVar tv
case b of
Nothing -> retry
Just ns -> return ns
fourth (_,_,_,c) = c
executeNumberedBody :: TraceT IO a
executeNumberedBody
= do st <- get
case st of
((g:gs), es) ->
do put (gs, es)
snd $ getAltable (items !! g)
([], _) -> liftIO $
do hPutStrLn stderr "ALTing not supported on given guard"
ioError $ userError "ALTing not supported on given guard"