+{-# LANGUAGE BangPatterns #-}
{-| Implementation of lock allocation.
-}
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
=> (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' }
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
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
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.
+{-# LANGUAGE BangPatterns #-}
{-| Implementation of a priority waiting structure for locks.
-}
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
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''
-> 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)
-> (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
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
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.