Commit 15208e95 authored by Klaus Aehlig's avatar Klaus Aehlig

Add function describing lock updates

Add the pure part of the mechanism of updating locks. To allow
for efficient waiting on locks, return the set of owners of the locks
on which the operation is blocked.
Signed-off-by: default avatarKlaus Aehlig <aehlig@google.com>
Reviewed-by: default avatarPetr Pudlak <pudlak@google.com>
parent a1da8a50
......@@ -28,12 +28,22 @@ module Ganeti.Locking.Allocation
, emptyAllocation
, OwnerState(..)
, listLocks
, LockRequest(..)
, requestExclusive
, requestShared
, requestRelease
, updateLocks
) where
import Control.Arrow (second, (***))
import Control.Monad
import Data.Foldable (for_)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import qualified Data.Set as S
import Ganeti.BasicTypes
{-
This module is parametric in the type of locks and lock owners.
......@@ -76,6 +86,111 @@ emptyAllocation =
, laOwned = M.empty
}
-- | Obtain the set of locks held by a given owner.
listLocks :: Ord b => b -> LockAllocation a b -> M.Map a OwnerState
listLocks owner = fromMaybe M.empty . M.lookup owner . laOwned
-- | Data Type describing a change request on a single lock.
data LockRequest a = LockRequest { lockAffected :: a
, lockRequestType :: Maybe OwnerState
}
deriving (Eq, Show)
-- | Lock request for an exclusive lock.
requestExclusive :: a -> LockRequest a
requestExclusive lock = LockRequest { lockAffected = lock
, lockRequestType = Just OwnExclusive }
-- | Lock request for a shared lock.
requestShared :: a -> LockRequest a
requestShared lock = LockRequest { lockAffected = lock
, lockRequestType = Just OwnShared }
-- | Request to release a lock.
requestRelease :: a -> LockRequest a
requestRelease lock = LockRequest { lockAffected = lock
, lockRequestType = Nothing }
-- | Internal function to update the state according to a single
-- lock request, assuming all prerequisites are met.
updateLock :: (Ord a, Ord b)
=> b
-> LockAllocation a b -> LockRequest a -> LockAllocation a b
updateLock owner state (LockRequest lock (Just OwnExclusive)) =
let locks' = M.insert lock (Exclusive owner) $ laLocks state
ownersLocks' = M.insert lock OwnExclusive $ listLocks owner state
owned' = M.insert owner ownersLocks' $ laOwned state
in state { laLocks = locks', laOwned = owned' }
updateLock owner state (LockRequest lock (Just OwnShared)) =
let ownersLocks' = M.insert lock OwnShared $ listLocks owner state
owned' = M.insert owner ownersLocks' $ laOwned state
locks = laLocks state
lockState' = case M.lookup lock locks of
Just (Shared s) -> Shared (S.insert owner s)
_ -> Shared $ S.singleton owner
locks' = M.insert lock lockState' locks
in state { laLocks = locks', laOwned = owned' }
updateLock owner state (LockRequest lock Nothing) =
let ownersLocks' = M.delete lock $ listLocks owner state
owned = laOwned state
owned' = if M.null ownersLocks'
then M.delete owner owned
else M.insert owner ownersLocks' owned
locks = laLocks state
lockRemoved = M.delete lock locks
locks' = case M.lookup lock locks of
Nothing -> locks
Just (Exclusive x) ->
if x == owner then lockRemoved else locks
Just (Shared s)
-> let s' = S.delete owner s
in if S.null s'
then lockRemoved
else M.insert lock (Shared s') locks
in state { laLocks = locks', laOwned = owned' }
-- | Update the locks of an owner according to the given request. Return
-- the pair of the new state and the result of the operation, which is the
-- the set of owners on which the operation was blocked on. so an empty set is
-- success, and the state is updated if, and only if, the returned set is emtpy.
-- In that way, it can be used in atomicModifyIORef.
updateLocks :: (Ord a, Show a, Ord b)
=> b
-> [LockRequest a]
-> LockAllocation a b -> (LockAllocation a b, Result (S.Set b))
updateLocks owner reqs state = genericResult ((,) state . Bad) (second Ok) $ do
runListHead (return ())
(fail . (++) "Inconsitent requests for lock " . show) $ do
r <- reqs
r' <- reqs
guard $ r /= r'
guard $ lockAffected r == lockAffected r'
return $ lockAffected r
let current = listLocks owner state
unless (M.null current) $ do
let (highest, _) = M.findMax current
notHolding = not
. any (uncurry (==) . ((M.lookup `flip` current) *** Just))
orderViolation l = fail $ "Order violation: requesting " ++ show l
++ " while holding " ++ show highest
for_ reqs $ \req -> case req of
LockRequest lock (Just OwnExclusive)
| lock < highest && notHolding [ (lock, OwnExclusive) ]
-> orderViolation lock
LockRequest lock (Just OwnShared)
| lock < highest && notHolding [ (lock, OwnExclusive)
, (lock, OwnExclusive)]
-> orderViolation lock
_ -> Ok ()
let blockedOn (LockRequest _ Nothing) = S.empty
blockedOn (LockRequest lock (Just OwnExclusive)) =
case M.lookup lock (laLocks state) of
Just (Exclusive x) -> S.singleton x
Just (Shared xs) -> xs
_ -> S.empty
blockedOn (LockRequest lock (Just OwnShared)) =
case M.lookup lock (laLocks state) of
Just (Exclusive x) -> S.singleton x
_ -> S.empty
let blocked = S.delete owner . S.unions $ map blockedOn reqs
let state' = foldl (updateLock owner) state reqs
return (if S.null blocked then state' else state, blocked)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment