On Thu, Feb 20, 2014 at 5:02 PM, Klaus Aehlig <[email protected]> wrote:
> Add a function to opportunistically allocate as many locks of a given > set as possible. This is equivalent to sequentially try the locks in > increasing lock order after restricting to those locks where the > required owner state is higher than the currently held one. > > Signed-off-by: Klaus Aehlig <[email protected]> > --- > src/Ganeti/Locking/Allocation.hs | 20 ++++++++++++++++++++ > 1 file changed, 20 insertions(+) > > diff --git a/src/Ganeti/Locking/Allocation.hs > b/src/Ganeti/Locking/Allocation.hs > index 215f68d..8d8a3c1 100644 > --- a/src/Ganeti/Locking/Allocation.hs > +++ b/src/Ganeti/Locking/Allocation.hs > @@ -35,11 +35,13 @@ module Ganeti.Locking.Allocation > , updateLocks > , freeLocks > , intersectLocks > + , opportunisticLockUnion > ) where > > import Control.Arrow (second, (***)) > import Control.Monad > import Data.Foldable (for_, find) > +import Data.List (sort) > import qualified Data.Map as M > import Data.Maybe (fromMaybe) > import qualified Data.Set as S > @@ -295,3 +297,21 @@ intersectLocks owner locks state = > toFree = filter (not . flip S.member lockset) > . M.keys $ listLocks owner state > in fst $ updateLocks owner (map requestRelease toFree) state > + > +-- | Opportunistically allocate locks for a given user; return the set > +-- of actually acquired. The signature is choosen to be suitable for > s/choosen/chosen/ > +-- atomicModifyIORef. > +opportunisticLockUnion :: (Lock a, Ord b) > + => b -> [(a, OwnerState)] > + -> LockAllocation a b -> (LockAllocation a b, > S.Set a) > +opportunisticLockUnion owner reqs state = > + let locks = listLocks owner state > + reqs' = sort $ filter (uncurry (<) . (flip M.lookup locks *** > Just)) reqs > + maybeAllocate (s, success) (lock, ownstate) = > + let (s', result) = updateLocks owner > + [(if ownstate == OwnShared > + then requestShared > + else requestExclusive) lock] > + s > + in (s', if result == Ok S.empty then lock:success else success) > + in second S.fromList $ foldl maybeAllocate (state, []) reqs' > -- > 1.9.0.rc1.175.g0b1dcb5 > > Otherwise LGTM, thanks.
