Compute lock allocation strictly

Given that on updates it has to be fully computed anyway, do not
accumulate thunks during the computation.

Signed-off-by: Klaus Aehlig <aehlig@google.com>
Reviewed-by: Oleg Ponomarev <oponomarev@google.com>

diff --git a/src/Ganeti/Locking/Allocation.hs b/src/Ganeti/Locking/Allocation.hs
index 2875d70..d1caa2a 100644 (file)
--- 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..9f03e6e 100644 (file)
--- 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,16 @@ 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 +190,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 +217,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 +334,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
 
@@ -397,7 +400,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.