-- | | Implements locks which can be locked "globally" or "locally".-- A global lock prevents any other lock; a local lock allows other local-- locks.---- There are some subtle decisions to be made about when to give preference-- to local, and when to global, locks. There are two important cases:-- (1) When we free a global lock, and there is another queued global lock,-- we take that global lock (or the earliest for which someone is-- waiting, if there's a choice), irrespective of whether anyone is-- waiting for a local lock.-- (2) When at least one local lock is held, we allow people to acquire-- further local locks, even if there are queued global locks.---- A bad consequence of (2) is that a global lock can be indefinitely not-- satisfied by a carefully-timed sequence of finite local locks:---- local locks : --- --- --- --- . . .-- --- --- --- . . .-- no global lock can be acquired at all.---- However the alternative, of not permitting any fresh local locks when-- a global lock is queued, is worse (in my opinion), since if a thread-- attempts to acquire two local locks, one inside the other, and another-- attempts to acquire a global lock, the whole thing can deadlock.---- Thread 1 : acquire local lock attempt to acquire second local lock => DEADLOCK.-- Thread 2 : wait for global lock---- We could deal with this partially by allowing local locks for free-- to a thread which already holds one, but this is more complicated and-- I suspect theoretically dodgy.---- A consequence of this decision is that threads should avoid creating-- automated repeated sequences of local locks on the same VSem.moduleUtil.VSem(VSem,newVSem,synchronizeLocal,synchronizeGlobal,acquireLocal,-- :: VSem -> IO ()releaseLocal,-- :: VSem -> IO ())whereimportControl.ConcurrentimportControl.ExceptionimportUtil.ComputationimportUtil.QueuedataVSemState=VSemState{queuedGlobals::Queue(MVar()),queuedLocals::[MVar()],nLocalLocks::Int-- ^ -1 if the vSem is globally locked, otherwise the number of local-- locks.}-- | A lock which can be globally or locally locked.-- At any time, a @VSem@ is either globally locked once, or locally locked-- zero or more times. Global locks always take priority over local locks.newtypeVSem=VSem(MVarVSemState)-- | Creates a 'VSem'.newVSem::IOVSemnewVSem=domVar<-newMVar(VSemState{queuedGlobals=emptyQ,queuedLocals=[],nLocalLocks=0})return(VSemmVar)-- | Perform an action while locking a 'VSem' locally.synchronizeLocal::VSem->IOb->IObsynchronizeLocalvSemact=doacquireLocalvSemfinallyact(releaseLocalvSem)-- | Perform an action while locking a 'VSem' globally.synchronizeGlobal::VSem->IOb->IObsynchronizeGlobalvSemact=doacquireGlobalvSemfinallyact(releaseGlobalvSem)vSemAct::VSem->(VSemState->IO(VSemState,b))->IObvSemAct(VSemmVar)update=modifyMVarmVarupdate-- | Acquire a local lock on a 'VSem'acquireLocal::VSem->IO()acquireLocalvSem=doact<-vSemActvSem(\vSemState->ifnLocalLocksvSemState<0thendomVar<-newEmptyMVarreturn(vSemState{queuedLocals=mVar:queuedLocalsvSemState},takeMVarmVar)elsereturn(vSemState{nLocalLocks=nLocalLocksvSemState+1},done))act-- | Release a local lock on a 'VSem'releaseLocal::VSem->IO()releaseLocalvSem=vSemActvSem(\vSemState->doletnLocalLocks0=nLocalLocksvSemStatenLocalLocks1=nLocalLocks0-1case(nLocalLocks1,removeQ(queuedGlobalsvSemState))of(0,Just(mVar,queuedGlobals1))->doputMVarmVar()return(vSemState{nLocalLocks=-1,queuedGlobals=queuedGlobals1},())_->return(vSemState{nLocalLocks=nLocalLocks1},()))-- | Acquire a global lock on a 'VSem'acquireGlobal::VSem->IO()acquireGlobalvSem=doact<-vSemActvSem(\vSemState->doletnLocalLocks0=nLocalLocksvSemStateifnLocalLocks0==0thenreturn(vSemState{nLocalLocks=-1},done)elsedomVar<-newEmptyMVarreturn(vSemState{queuedGlobals=insertQ(queuedGlobalsvSemState)mVar},takeMVarmVar))act-- | Release a global lock on a 'VSem'releaseGlobal::VSem->IO()releaseGlobalvSem=vSemActvSem(\vSemState->case(removeQ(queuedGlobalsvSemState),queuedLocalsvSemState)of(Just(mVar,queuedGlobals1),_)->doputMVarmVar()return(vSemState{queuedGlobals=queuedGlobals1},())(Nothing,queuedLocals0)->domapM_(\mVar->putMVarmVar())queuedLocals0return(vSemState{queuedLocals=[],nLocalLocks=lengthqueuedLocals0},()))