Revision 381889dc

b/src/Ganeti/Locking/Allocation.hs
38 38

  
39 39
import Control.Arrow (second, (***))
40 40
import Control.Monad
41
import Data.Foldable (for_)
41
import Data.Foldable (for_, find)
42 42
import qualified Data.Map as M
43 43
import Data.Maybe (fromMaybe)
44 44
import qualified Data.Set as S
45 45

  
46 46
import Ganeti.BasicTypes
47
import Ganeti.Locking.Types
47 48

  
48 49
{-
49 50

  
......
55 56

  
56 57
-}
57 58

  
58
-- | The state of a lock that is taken.
59
data AllocationState a = Exclusive a | Shared (S.Set a) deriving (Eq, Show)
60

  
61 59
-- | Data type describing the way a lock can be owned.
62 60
data OwnerState = OwnShared | OwnExclusive deriving (Ord, Eq, Show)
63 61

  
62
-- | Type describing indirect ownership on a lock. We keep the set
63
-- of all (lock, owner)-pairs for locks that are implied in the given
64
-- lock, annotated with the type of ownership (shared or exclusive).
65
type IndirectOwners a b = M.Map (a, b) OwnerState
66

  
67
-- | The state of a lock that is taken. Besides the state of the lock
68
-- itself, we also keep track of all other lock allocation that affect
69
-- the given lock by means of implication.
70
data AllocationState a b = Exclusive b (IndirectOwners a b)
71
                         | Shared (S.Set b) (IndirectOwners a b)
72
                         deriving (Eq, Show)
73

  
74
-- | Compute the set of indirect owners from the information about
75
-- indirect ownership.
76
indirectOwners :: (Ord a, Ord b) => M.Map (a, b) OwnerState -> S.Set b
77
indirectOwners = S.map snd . M.keysSet
78

  
79
-- | Compute the (zero or one-elment) set of exclusive indirect owners.
80
indirectExclusives :: (Ord a, Ord b) => M.Map (a, b) OwnerState -> S.Set b
81
indirectExclusives = indirectOwners . M.filter (== OwnExclusive)
82

  
64 83
{-| Representation of a Lock allocation
65 84

  
66 85
To keep queries for locks efficient, we keep two
......
75 94
-}
76 95

  
77 96
data LockAllocation a b =
78
  LockAllocation { laLocks :: M.Map a (AllocationState b)
97
  LockAllocation { laLocks :: M.Map a (AllocationState a b)
79 98
                 , laOwned :: M.Map b (M.Map a OwnerState)
80 99
                 }
81 100
  deriving (Eq, Show)
......
114 133
requestRelease lock = LockRequest { lockAffected = lock
115 134
                                  , lockRequestType = Nothing }
116 135

  
136
-- | Update the Allocation state of a lock according to a given
137
-- function.
138
updateAllocState :: (Ord a, Ord b)
139
                  => (Maybe (AllocationState a b) -> AllocationState a b)
140
                  -> LockAllocation a b -> a -> LockAllocation a b
141
updateAllocState f state lock =
142
  let locks' = M.alter (find (/= Shared S.empty M.empty) . Just . f)
143
                        lock (laLocks state)
144
  in state { laLocks = locks' }
145

  
117 146
-- | Internal function to update the state according to a single
118 147
-- lock request, assuming all prerequisites are met.
119 148
updateLock :: (Ord a, Ord b)
120 149
           => b
121 150
           -> LockAllocation a b -> LockRequest a -> LockAllocation a b
122 151
updateLock owner state (LockRequest lock (Just OwnExclusive)) =
123
  let locks' = M.insert lock (Exclusive owner) $ laLocks state
152
  let locks = laLocks state
153
      lockstate' = case M.lookup lock locks of
154
        Just (Exclusive _ i) -> Exclusive owner i
155
        Just (Shared _ i) -> Exclusive owner i
156
        Nothing -> Exclusive owner M.empty
157
      locks' = M.insert lock lockstate' locks
124 158
      ownersLocks' = M.insert lock OwnExclusive $ listLocks owner state
125 159
      owned' = M.insert owner ownersLocks' $ laOwned state
126 160
  in state { laLocks = locks', laOwned = owned' }
......
129 163
      owned' = M.insert owner ownersLocks' $ laOwned state
130 164
      locks = laLocks state
131 165
      lockState' = case M.lookup lock locks of
132
        Just (Shared s) -> Shared (S.insert owner s)
133
        _ -> Shared $ S.singleton owner
166
        Just (Exclusive _ i) -> Shared (S.singleton owner) i
167
        Just (Shared s i) -> Shared (S.insert owner s) i
168
        _ -> Shared (S.singleton owner) M.empty
134 169
      locks' = M.insert lock lockState' locks
135 170
  in state { laLocks = locks', laOwned = owned' }
136 171
updateLock owner state (LockRequest lock Nothing) =
......
139 174
      owned' = if M.null ownersLocks'
140 175
                 then M.delete owner owned
141 176
                 else M.insert owner ownersLocks' owned
142
      locks = laLocks state
143
      lockRemoved = M.delete lock locks
144
      locks' = case M.lookup lock locks of
145
                 Nothing -> locks
146
                 Just (Exclusive x) ->
147
                   if x == owner then lockRemoved else locks
148
                 Just (Shared s)
149
                   -> let s' = S.delete owner s
150
                      in if S.null s'
151
                        then lockRemoved
152
                        else M.insert lock (Shared s') locks
153
  in state { laLocks = locks', laOwned = owned' }
177
      update (Just (Exclusive x i)) = if x == owner
178
                                        then Shared S.empty i
179
                                        else Exclusive x i
180
      update (Just (Shared s i)) = Shared (S.delete owner s) i
181
      update Nothing = Shared S.empty M.empty
182
  in updateAllocState update (state { laOwned = owned' }) lock
183

  
184
-- | Update the set of indirect ownerships of a lock by the given function.
185
updateIndirectSet :: (Ord a, Ord b)
186
                  => (IndirectOwners a b -> IndirectOwners a b)
187
                  -> LockAllocation a b -> a -> LockAllocation a b
188
updateIndirectSet f =
189
  let update (Just (Exclusive x i)) = Exclusive x (f i)
190
      update (Just (Shared s i)) = Shared s (f i)
191
      update Nothing = Shared S.empty (f M.empty)
192
  in updateAllocState update
193

  
194
-- | Update all indirect onwerships of a given lock.
195
updateIndirects :: (Lock a, Ord b)
196
                => b
197
                -> LockAllocation a b -> LockRequest a -> LockAllocation a b
198
updateIndirects owner state req =
199
  let lock = lockAffected req
200
      fn = case lockRequestType req of
201
             Nothing -> M.delete (lock, owner)
202
             Just tp -> M.insert (lock, owner) tp
203
  in foldl (updateIndirectSet fn) state $ lockImplications lock
154 204

  
155 205
-- | Update the locks of an owner according to the given request. Return
156 206
-- the pair of the new state and the result of the operation, which is the
157 207
-- the set of owners on which the operation was blocked on. so an empty set is
158 208
-- success, and the state is updated if, and only if, the returned set is emtpy.
159 209
-- In that way, it can be used in atomicModifyIORef.
160
updateLocks :: (Ord a, Show a, Ord b)
161
               => b
162
               -> [LockRequest a]
163
               -> LockAllocation a b -> (LockAllocation a b, Result (S.Set b))
210
updateLocks :: (Lock a, Ord b)
211
            => b
212
            -> [LockRequest a]
213
            -> LockAllocation a b -> (LockAllocation a b, Result (S.Set b))
164 214
updateLocks owner reqs state = genericResult ((,) state . Bad) (second Ok) $ do
165 215
  runListHead (return ())
166 216
              (fail . (++) "Inconsitent requests for lock " . show) $ do
......
188 238
  let blockedOn (LockRequest  _ Nothing) = S.empty
189 239
      blockedOn (LockRequest lock (Just OwnExclusive)) =
190 240
        case M.lookup lock (laLocks state) of
191
          Just (Exclusive x) -> S.singleton x
192
          Just (Shared xs) -> xs
241
          Just (Exclusive x i) ->
242
            S.singleton x `S.union` indirectOwners i
243
          Just (Shared xs i) ->
244
            xs `S.union` indirectOwners i
193 245
          _ -> S.empty
194 246
      blockedOn (LockRequest lock (Just OwnShared)) =
195 247
        case M.lookup lock (laLocks state) of
196
          Just (Exclusive x) -> S.singleton x
248
          Just (Exclusive x i) ->
249
            S.singleton x `S.union` indirectExclusives i
250
          Just (Shared _ i) -> indirectExclusives i
251
          _ -> S.empty
252
  let indirectBlocked Nothing _ = S.empty
253
      indirectBlocked (Just OwnShared) lock =
254
        case M.lookup lock (laLocks state) of
255
          Just (Exclusive x _) -> S.singleton x
256
          _ -> S.empty
257
      indirectBlocked (Just OwnExclusive) lock =
258
        case M.lookup lock (laLocks state) of
259
          Just (Exclusive x _) -> S.singleton x
260
          Just (Shared xs _) -> xs
197 261
          _ -> S.empty
198
  let blocked = S.delete owner . S.unions $ map blockedOn reqs
262
  let direct = S.unions $ map blockedOn reqs
263
      indirect = reqs >>= \req ->
264
        map (indirectBlocked (lockRequestType req))
265
          . lockImplications $ lockAffected req
266
  let blocked = S.delete owner . S.unions $ direct:indirect
199 267
  let state' = foldl (updateLock owner) state reqs
200
  return (if S.null blocked then state' else state, blocked)
268
      state'' = foldl (updateIndirects owner) state' reqs
269
  return (if S.null blocked then state'' else state, blocked)
201 270

  
202 271
-- | Compute the state after an onwer releases all its locks.
203 272
freeLocks :: (Lock a, Ord b) => LockAllocation a b -> b -> LockAllocation a b

Also available in: Unified diff