-- 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"