diff --git a/Control/Concurrent/RLock.hs b/Control/Concurrent/RLock.hs --- a/Control/Concurrent/RLock.hs +++ b/Control/Concurrent/RLock.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, UnicodeSyntax #-} +{-# LANGUAGE BangPatterns, DeriveDataTypeable, NoImplicitPrelude, UnicodeSyntax #-} -------------------------------------------------------------------------------- -- | @@ -66,84 +66,87 @@ import Data.Eq ( Eq ) import Data.Function ( ($) ) import Data.Maybe ( Maybe(Nothing, Just), maybe ) -import Data.List ( (++) ) +import Data.Tuple ( fst, snd ) import Data.Typeable ( Typeable ) -import Prelude ( Integer, fromInteger, succ, pred, error, seq ) +import Prelude ( Integer, fromInteger, succ, pred, error ) import System.IO ( IO ) -- from base-unicode-symbols import Data.Eq.Unicode ( (≡) ) import Data.Function.Unicode ( (∘) ) +import Data.Monoid.Unicode ( (⊕) ) -- from ourselves: import Control.Concurrent.Lock ( Lock ) import qualified Control.Concurrent.Lock as Lock - ( newAcquired, acquire, release ) + ( new, newAcquired, acquire, release ) -------------------------------------------------------------------------------- -- Reentrant locks -------------------------------------------------------------------------------- -newtype RLock = RLock {un ∷ MVar (Maybe (ThreadId, Integer, Lock))} +newtype RLock = RLock {un ∷ MVar (Maybe (ThreadId, Integer), Lock)} deriving (Eq, Typeable) new ∷ IO RLock -new = RLock <$> newMVar Nothing +new = do lock ← Lock.new + RLock <$> newMVar (Nothing, lock) newAcquired ∷ IO RLock newAcquired = do myTID ← myThreadId lock ← Lock.newAcquired - RLock <$> newMVar (Just (myTID, 1, lock)) + RLock <$> newMVar (Just (myTID, 1), lock) acquire ∷ RLock → IO () acquire (RLock mv) = do myTID ← myThreadId - block $ do - mb ← takeMVar mv - case mb of - Nothing → do lock ← Lock.newAcquired - putMVar mv $ Just (myTID, 1, lock) - Just (tid, n, lock) - | myTID ≡ tid → do let sn = succ n - sn `seq` putMVar mv $ Just (tid, sn, lock) - - | otherwise → do putMVar mv mb - Lock.acquire lock + block $ let go = do t@(mb, lock) ← takeMVar mv + case mb of + Nothing → do Lock.acquire lock + putMVar mv (Just (myTID, 1), lock) + Just (tid, n) + | myTID ≡ tid → let !sn = succ n + in putMVar mv (Just (tid, sn), lock) + | otherwise → do putMVar mv t + Lock.acquire lock + Lock.release lock + go + in go tryAcquire ∷ RLock → IO Bool tryAcquire (RLock mv) = do myTID ← myThreadId block $ do - mb ← takeMVar mv + t@(mb, lock) ← takeMVar mv case mb of - Nothing → do lock ← Lock.newAcquired - putMVar mv $ Just (myTID, 1, lock) + Nothing → do Lock.acquire lock + putMVar mv (Just (myTID, 1), lock) return True - Just (tid, n, lock) - | myTID ≡ tid → do let sn = succ n - sn `seq` putMVar mv $ Just (tid, sn, lock) + Just (tid, n) + | myTID ≡ tid → do let !sn = succ n + putMVar mv (Just (tid, sn), lock) return True - | otherwise → do putMVar mv mb + | otherwise → do putMVar mv t return False release ∷ RLock → IO () release (RLock mv) = do myTID ← myThreadId block $ do - mb ← takeMVar mv - let myError str = do putMVar mv mb - error $ "Control.Concurrent.RLock.release: " ++ str + t@(mb, lock) ← takeMVar mv + let err msg = do putMVar mv t + error $ "Control.Concurrent.RLock.release: " ⊕ msg case mb of - Nothing → myError "Can't release an unacquired RLock!" - Just (tid, n, lock) + Nothing → err "Can't release an unacquired RLock!" + Just (tid, n) | myTID ≡ tid → if n ≡ 1 then do Lock.release lock - putMVar mv Nothing - else do let pn = pred n - pn `seq` putMVar mv $ Just (tid, pn, lock) - | otherwise → myError "Calling thread does not own the RLock!" + putMVar mv (Nothing, lock) + else let !pn = pred n + in putMVar mv (Just (tid, pn), lock) + | otherwise → err "Calling thread does not own the RLock!" with ∷ RLock → IO α → IO α with = liftA2 bracket_ acquire release @@ -156,7 +159,7 @@ else return Nothing recursionLevel ∷ RLock → IO Integer -recursionLevel = fmap (maybe 0 (\(_, n, _) → n)) ∘ readMVar ∘ un +recursionLevel = fmap (maybe 0 snd ∘ fst) ∘ readMVar ∘ un -- The End --------------------------------------------------------------------- diff --git a/Control/Concurrent/ReadWriteVar.hs b/Control/Concurrent/ReadWriteVar.hs --- a/Control/Concurrent/ReadWriteVar.hs +++ b/Control/Concurrent/ReadWriteVar.hs @@ -165,5 +165,3 @@ -- The End -------------------------------------------------------------------- - - diff --git a/concurrent-extra.cabal b/concurrent-extra.cabal --- a/concurrent-extra.cabal +++ b/concurrent-extra.cabal @@ -1,5 +1,5 @@ name: concurrent-extra -version: 0.1 +version: 0.1.0.1 cabal-version: >= 1.6 build-type: Custom stability: experimental diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -29,6 +29,7 @@ -- from concurrent-extra import qualified Control.Concurrent.Lock as Lock +import qualified Control.Concurrent.RLock as RLock import qualified Control.Concurrent.Event as Event -- from HUnit @@ -41,7 +42,6 @@ import Test.Framework.Providers.HUnit ( testCase ) - ------------------------------------------------------------------------------- -- Tests ------------------------------------------------------------------------------- @@ -59,7 +59,7 @@ , testCase "multi wake" $ test_event_3 10 , testCase "exception" $ test_event_4 , testCase "wait timeout" $ test_event_5 - , testCase "foo!" $ test_event_6 + , testCase "wait blocks" $ test_event_6 ] , testGroup "Lock" [ testCase "acquire release" test_lock_1 @@ -71,7 +71,8 @@ , testCase "conc release" test_lock_7 ] , testGroup "RLock" - [ + [ testCase "recursive acquire" $ test_rlock_1 5 + , testCase "conc acquire" $ test_rlock_2 ] ] @@ -183,7 +184,38 @@ -- RLocks -------------------------------------------------------------------------------- --- TODO +test_rlock_1 ∷ Int → Assertion +test_rlock_1 n = assert ∘ within (10 ⋅ a_moment) $ do + l ← RLock.new + replicateM_ n $ RLock.acquire l + replicateM_ n $ RLock.release l + +-- Tests for bug found by Felipe Lessa. +test_rlock_2 ∷ Assertion +test_rlock_2 = assert ∘ within (20 ⋅ a_moment) $ do + rl ← RLock.new + t1_has_rlock ← Event.new + t1_done ← Event.new + t2_done ← Event.new + + -- Thread 1 + _ ← forkIO $ do + RLock.acquire rl + Event.set t1_has_rlock + threadDelay $ 10 ⋅ a_moment + RLock.release rl + Event.set t1_done + + -- Thread 2 + _ ← forkIO $ do + Event.wait t1_has_rlock + RLock.acquire rl + RLock.release rl + Event.set t2_done + + Event.wait t1_done + Event.wait t2_done + ------------------------------------------------------------------------------- -- Misc