module Control.CUtils.Deadlock (Res(Lift, Acq, Rel, Fork, Plus, Id), run, lft) where
import Control.Category
import Control.Arrow
import Control.Monad
import Data.Map (Map)
import Data.List (inits, tails, elemIndex, deleteBy)
import Data.Maybe
import Data.Function (on)
import qualified Data.Map as M
import System.IO.Unsafe
import Control.Concurrent
import Prelude hiding (id, (.))
data Res t u where
Lift :: Kleisli IO t v -> Res v u -> Res t u
Acq :: MVar () -> Res t u -> Res t u
Rel :: MVar () -> Res t u -> Res t u
Fork :: Res t () -> Res t u -> Res t u
Plus :: Res t v -> Res u v -> Res (Either t u) v
Id :: Res t t
instance Category Res where
id = Id
a . Lift k a2 = Lift k (a . a2)
a . Acq m a2 = Acq m (a . a2)
a . Rel m a2 = Rel m (a . a2)
a . Fork a2 a3 = Fork a2 (a . a3)
a . Plus a2 a3 = Plus (a . a2) (a . a3)
a . Id = a
instance Arrow Res where
arr f = Lift (arr f) Id
first (Lift k a) = Lift (first k) (first a)
first (Acq m a) = Acq m (first a)
first (Rel m a) = Rel m (first a)
first (Fork a a2) = Fork (a . arr fst) (first a2)
first Id = Id
instance ArrowChoice Res where
left a = Plus (arr Left . a) (arr Right)
resource :: MVar (Map ThreadId [(MVar (), [MVar ()])])
resource = unsafePerformIO (newMVar M.empty)
selects ls = [ (y, xs ++ ys) | xs <- inits ls | y:ys <- tails ls ]
generateSequences ls lock = if null ls then
return []
else do
((t, m), xs) <- selects ls
lock' <- maybe [] id $ lookup lock m
liftM (lock':) $ generateSequences xs lock'
hazard mp m = msum $ map (\(x:xs) -> guard (m `elem` xs) >> return x) $ generateSequences (M.assocs mp) m
acquired :: Res t u -> MVar () -> [MVar ()]
acquired (Lift _ a) m = acquired a m
acquired (Acq m' a) m = m' : acquired a m
acquired (Rel m' _) m | m' == m = []
acquired (Rel _ a) m = acquired a m
acquired (Fork a a2) m = acquired a m ++ acquired a2 m
acquired (Plus a a2) m = acquired a m ++ acquired a2 m
acquired Id _ = []
insert x y ((x1, _):xs) | x == x1 = (x, y) : xs
insert x y (pr:xs) = pr : insert x y xs
insert x y [] = [(x, y)]
run :: Res t u -> t -> IO u
run (Lift k a) x = runKleisli k x >>= run a
run (Acq m a) x = do
mp <- takeMVar resource
thd <- myThreadId
let mp' = M.alter (Just . insert m (acquired a m) . maybe [] id) thd mp
let may = hazard mp' m
maybe
(do
putMVar resource mp'
takeMVar m
run a x)
(\m' -> do
putMVar resource mp
run (Acq m' $ Rel m' $ Acq m a) x)
may
run (Rel m a) x = do
putMVar m ()
thd <- myThreadId
modifyMVar_ resource (return . M.adjust (deleteBy ((==) `on` fst) (m, [])) thd)
run a x
run (Fork a a2) x = forkIO (run a x) >> run a2 x
run (Plus a a2) ei = either (run a) (run a2) ei
run Id x = return x
lft m = Lift $ Kleisli $ \x -> m >> return x
test = do
m1 <- newMVar ()
m2 <- newMVar ()
run (Fork (lft (print "Thd1 done") Id . Rel m1 Id . Rel m2 Id . Acq m1 Id . lft (threadDelay 1000000) Id . Acq m2 Id)
(lft (print "Thd2 done") Id . Rel m1 Id . Rel m2 Id . Acq m2 Id . lft (threadDelay 1000000) Id . Acq m1 Id))
()