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.
