module PrioritySync.Internal.RoomCore
(Room,
newRoom,
Claim,
ClaimMode(..),
claimedRoom,
claimedThread,
userData,
approve,
claim_,
inUse,
isEmpty)
where
import PrioritySync.Internal.UserData
import Data.Unique
import Data.Set as Set
import Data.Map as Map
import GHC.Conc
import Control.Monad
import Control.Exception
data Room u = Room {
room_user_data :: (u,Unique),
room_occupants :: (TVar (Set ThreadId)),
room_is_empty :: (TVar Bool) }
type instance UserData (Room u) = u
instance Eq (Room u) where
(==) r1 r2 = snd (room_user_data r1) == snd (room_user_data r2)
instance Ord (Room u) where
compare r1 r2 = compare (snd $ room_user_data r1) (snd $ room_user_data r2)
data Claim u = Claim (Room u) ThreadId ClaimMode (TVar Bool)
type instance UserData (Claim u) = u
data ClaimMode = Acquire | Release deriving (Eq)
newRoom :: u -> IO (Room u)
newRoom u = return Room `ap` liftM ((,) u) newUnique `ap` newTVarIO Set.empty `ap` newTVarIO True
userData :: Room u -> u
userData = fst . room_user_data
claimMode :: Claim u -> ClaimMode
claimMode (Claim _ _ b _) = b
claimedRoom :: Claim u -> Room u
claimedRoom (Claim m _ _ _) = m
claimedThread :: Claim u -> ThreadId
claimedThread (Claim _ t _ _) = t
approve :: Claim u -> STM ()
approve (Claim r me want claim_var) =
do claim_state <- readTVar claim_var
when (claim_state == False) $
do writeTVar claim_var True
writeTVar (room_occupants r) . (case want of Acquire -> Set.insert; Release -> Set.delete) me =<< readTVar (room_occupants r)
watchRoom r
watchRoom :: Room u -> STM ()
watchRoom r =
do is_empty <- readTVar (room_is_empty r)
occus <- readTVar (room_occupants r)
when (is_empty && (not $ Set.null occus)) $ writeTVar (room_is_empty r) True
when (not is_empty && Set.null occus) $ writeTVar (room_is_empty r) False
claim_ :: Map (Room u) ClaimMode -> ([Claim u] -> STM ()) -> ([Claim u] -> STM ()) -> STM () -> IO a -> IO a
claim_ entering_rooms_map approveEnteringSTM approveExitingSTM waitingSTM actionIO =
do let entering_rooms = Map.toList entering_rooms_map
me <- myThreadId
let transition rooms approveSTM = atomically $
(\claims -> approveSTM (Prelude.filter ((== Acquire) . claimMode) claims) >> return claims) =<<
(mapM $ \c -> when (claimMode c == Release) (approve c) >> return c) =<<
(mapM $ \(m,want) -> liftM (Claim m me want) (newTVar False)) =<<
filterM (\(m,want) -> liftM ((/= (want == Acquire)) . Set.member me) $ inUse m) rooms
let confirm claims = forM_ claims $ \(Claim _ _ _ claim_var) ->
do claim_state <- readTVar claim_var
unless claim_state retry
let confirmWithWaitAction claims=
do done <- atomically $ (confirm claims >> return True) `orElse` (waitingSTM >> return False)
unless done $ confirmWithWaitAction claims
let transitionAndConfirm approveSTM rooms = flip finally (transition rooms $ mapM_ approve) $
do claims <- transition rooms approveSTM
confirmWithWaitAction claims
return $ Prelude.map (\(Claim m _ want _) -> (m,case want of Acquire -> Release; Release -> Acquire)) claims
bracket (transitionAndConfirm approveEnteringSTM entering_rooms)
(transitionAndConfirm approveExitingSTM)
(const actionIO)
inUse :: Room u -> STM (Set ThreadId)
inUse = readTVar . room_occupants
isEmpty :: Room u -> STM Bool
isEmpty = readTVar . room_is_empty