Given that on updates it has to be fully computed anyway, do not accumulate thunks during the computation.
Signed-off-by: Klaus Aehlig <[email protected]> --- src/Ganeti/Locking/Allocation.hs | 18 ++++++++++-------- src/Ganeti/Locking/Waiting.hs | 25 +++++++++++++------------ 2 files changed, 23 insertions(+), 20 deletions(-) diff --git a/src/Ganeti/Locking/Allocation.hs b/src/Ganeti/Locking/Allocation.hs index 2875d70..d1caa2a 100644 --- a/src/Ganeti/Locking/Allocation.hs +++ b/src/Ganeti/Locking/Allocation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-| Implementation of lock allocation. -} @@ -53,6 +54,7 @@ import Control.Applicative (liftA2, (<$>), (<*>), pure) import Control.Arrow (second, (***)) import Control.Monad import Data.Foldable (for_, find) +import Data.List (foldl') import qualified Data.Map as M import Data.Maybe (fromMaybe) import qualified Data.Set as S @@ -193,7 +195,7 @@ updateAllocState :: (Ord a, Ord b) => (Maybe (AllocationState a b) -> AllocationState a b) -> LockAllocation a b -> a -> LockAllocation a b updateAllocState f state lock = - let locks' = M.alter (find (/= Shared S.empty M.empty) . Just . f) + let !locks' = M.alter (find (/= Shared S.empty M.empty) . Just . f) lock (laLocks state) in state { laLocks = locks' } @@ -208,19 +210,19 @@ updateLock owner state (LockRequest lock (Just OwnExclusive)) = Just (Exclusive _ i) -> Exclusive owner i Just (Shared _ i) -> Exclusive owner i Nothing -> Exclusive owner M.empty - locks' = M.insert lock lockstate' locks + !locks' = M.insert lock lockstate' locks ownersLocks' = M.insert lock OwnExclusive $ listLocks owner state - owned' = M.insert owner ownersLocks' $ laOwned 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 + !owned' = M.insert owner ownersLocks' $ laOwned state locks = laLocks state lockState' = case M.lookup lock locks of Just (Exclusive _ i) -> Shared (S.singleton owner) i Just (Shared s i) -> Shared (S.insert owner s) i _ -> Shared (S.singleton owner) M.empty - locks' = M.insert lock lockState' locks + !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 @@ -254,7 +256,7 @@ updateIndirects owner state req = fn = case lockRequestType req of Nothing -> M.delete (lock, owner) Just tp -> M.insert (lock, owner) tp - in foldl (updateIndirectSet fn) state $ lockImplications lock + in foldl' (updateIndirectSet fn) state $ lockImplications lock -- | 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 @@ -331,8 +333,8 @@ updateLocks owner reqs state = genericResult ((,) state . Bad) (second Ok) $ do map (indirectBlocked (lockRequestType req)) . lockImplications $ lockAffected req let blocked = S.delete owner . S.unions $ direct:indirect - let state' = foldl (updateLock owner) state reqs - state'' = foldl (updateIndirects owner) state' reqs + let state' = foldl' (updateLock owner) state reqs + state'' = foldl' (updateIndirects owner) state' reqs return (if S.null blocked then state'' else state, blocked) -- | Manipluate all locks of the owner with a given property. diff --git a/src/Ganeti/Locking/Waiting.hs b/src/Ganeti/Locking/Waiting.hs index 9dec4be..bdac2ec 100644 --- a/src/Ganeti/Locking/Waiting.hs +++ b/src/Ganeti/Locking/Waiting.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-| Implementation of a priority waiting structure for locks. -} @@ -56,7 +57,7 @@ module Ganeti.Locking.Waiting import Control.Arrow ((&&&), (***), second) import Control.Monad (liftM) -import Data.List (sort) +import Data.List (sort, foldl') import qualified Data.Map as M import Data.Maybe (fromMaybe) import qualified Data.Set as S @@ -162,14 +163,14 @@ revisitRequests notify todo state = let getRequests (pending, reqs) owner = (M.delete owner pending , fromMaybe S.empty (M.lookup owner pending) `S.union` reqs) - (pending', requests) = S.foldl getRequests (lwPending state, S.empty) todo + (pending', requests) = S.foldl' getRequests (lwPending state, S.empty) todo revisitedOwners = S.map (\(_, o, _) -> o) requests - pendingOwners' = S.foldl (flip M.delete) (lwPendingOwners state) + pendingOwners' = S.foldl' (flip M.delete) (lwPendingOwners state) revisitedOwners state' = state { lwPending = pending', lwPendingOwners = pendingOwners' } - (state'', notify') = S.foldl tryFulfillRequest (state', notify) requests + (!state'', !notify') = S.foldl' tryFulfillRequest (state', notify) requests done = notify `S.union` todo - newTodo = notify' S.\\ done + !newTodo = notify' S.\\ done in if S.null todo then (notify, state) else revisitRequests done newTodo state'' @@ -187,9 +188,9 @@ updateLocks' :: (Lock a, Ord b, Ord c) -> LockWaiting a b c -> (LockWaiting a b c, (Result (S.Set b), S.Set b)) updateLocks' owner reqs state = - let (allocation', result) = L.updateLocks owner reqs (lwAllocation state) + let (!allocation', !result) = L.updateLocks owner reqs (lwAllocation state) state' = state { lwAllocation = allocation' } - (notify, state'') = revisitRequests S.empty (S.singleton owner) state' + (!notify, !state'') = revisitRequests S.empty (S.singleton owner) state' in if M.member owner $ lwPendingOwners state then ( state , (Bad "cannot update locks while having pending requests", S.empty) @@ -214,7 +215,7 @@ updateLocksWaiting' :: (Lock a, Ord b, Ord c) -> (LockWaiting a b c, (Result (S.Set b), S.Set b)) updateLocksWaiting' prio owner reqs state = let (state', (result, notify)) = updateLocks' owner reqs state - state'' = case result of + !state'' = case result of Bad _ -> state' -- bad requests cannot be queued Ok empty | S.null empty -> state' Ok blocked -> let blocker = S.findMin blocked @@ -331,8 +332,8 @@ releaseResources owner state = fromExtRepr :: (Lock a, Ord b, Ord c) => ExtWaiting a b c -> LockWaiting a b c fromExtRepr (alloc, pending) = - S.foldl (\s (prio, owner, req) -> - fst $ updateLocksWaiting prio owner req s) + S.foldl' (\s (prio, owner, req) -> + fst $ updateLocksWaiting prio owner req s) (emptyWaiting { lwAllocation = alloc }) pending @@ -371,7 +372,7 @@ downGradeLocksPredicate :: (Lock a, Ord b, Ord c) -> LockWaiting a b c -> (LockWaiting a b c, S.Set b) downGradeLocksPredicate = manipulateLocksPredicate L.requestShared --- | Intersect locks to a given set. +-- | Itersect locks to a given set. intersectLocks :: (Lock a, Ord b, Ord c) => [a] -> b @@ -397,7 +398,7 @@ opportunisticLockUnion owner reqs state = else L.requestExclusive) lock] s in (s', if result == Ok S.empty then lock:success else success) - in second (flip (,) S.empty) $ foldl maybeAllocate (state, []) reqs' + in second (flip (,) S.empty) $ foldl' maybeAllocate (state, []) reqs' -- | A guarded version of opportunisticLockUnion; if the number of fulfilled -- requests is not at least the given amount, then do not change anything. -- 2.6.0.rc2.230.g3dd15c0
