> On Dec 28, 2018, at 12:44 PM, Bertram Felgenhauer via Haskell-Cafe <haskell-cafe@haskell.org> wrote:
>
> This is awkward to fix. Basically, when abandoning the lock before it
> has been released by the previous owner, we need a new thread to wait
> for the 'current' IVar and notify the 'next' one, since the current
> thread is being interrupted.
I think that work can be delegated to the waiting thread, by making
locks (really barriers) optionally chain to a parent barrier that
also needs to be waited for (recursively). This is cheap, because
unless threads are actually interrupted, the chain is always one
deep. When a thread is interrupted, the next thread will wait
for 2 barriers, ...
--
Viktor.
module Main (main) where
import Control.Concurrent.MVar -- should be an IVar
import Control.Concurrent
import Control.Exception (bracket)
import Data.IORef
-- Really a recursive barrier
newtype Lock = Lock (MVar (Maybe Lock))
type Mutex = IORef Lock
type Chain = IORef (Maybe Lock)
newMutex :: IO Mutex
newMutex = Lock <$> newMVar Nothing >>= newIORef
withMutex :: Mutex -> IO a -> IO a
withMutex m =
bracket swapShared signalPrivate . (\act -> (>> act) . waitChain . snd)
where
-- Return a new IORef containing the old barrier from the mutex, and a new
-- barrier, that has been atomically swapped into the old mutex.
swapShared :: IO (Lock, Chain)
swapShared = Lock <$> newEmptyMVar >>= \b' ->
atomicModifyIORef m (\b -> (b', b)) >>= \b ->
newIORef (Just b) >>= \chain -> return (b', chain)
signalPrivate :: (Lock, Chain) -> IO ()
signalPrivate (Lock b, chain) = readIORef chain >>= putMVar b
-- The last barrier that we were waiting on (if we're interrupted)
-- will be left in our chain as a "continuation" for whoever
-- next gets the mutex. It may be already signalled by the time they
-- see it, and that's OK. On normal return it will be 'Nothing'.
waitChain :: Chain -> IO ()
waitChain c = readIORef c >>= go
where
go = mapM_ $ \(Lock a) -> readMVar a >>= \b -> writeIORef c b >> go b
mkThread :: Mutex -> String -> IO ThreadId
mkThread m name = do
tid <- forkIO $ withMutex m $ do
putStrLn $ unwords ["thread", name, "running"]
threadDelay 200000
putStrLn $ unwords ["thread", name, "stopping"]
yield
return tid
main :: IO ()
main = do
m <- newMutex
_ <- mkThread m "A"
threadB <- mkThread m "B"
_ <- mkThread m "C"
killThread threadB
threadDelay 1000000
_______________________________________________
Haskell-Cafe mailing list
To (un)subscribe, modify options or view archives go to:
http://mail.haskell.org/cgi-bin/mailman/listinfo/haskell-cafe
Only members subscribed via the mailman list are allowed to post.