concurrent-extra 0.1 → 0.1.0.1

raw patch · 4 files changed

+75/−42 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

Control/Concurrent/RLock.hs +38/−35
Control/Concurrent/ReadWriteVar.hs +0/−2
concurrent-extra.cabal +1/−1
test.hs +36/−4

Control/Concurrent/RLock.hs view

@@ -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 ---------------------------------------------------------------------

Control/Concurrent/ReadWriteVar.hs view

@@ -165,5 +165,3 @@   -- The End ----------------------------------------------------------------------

concurrent-extra.cabal view

@@ -1,5 +1,5 @@ name:          concurrent-extra-version:       0.1+version:       0.1.0.1 cabal-version: >= 1.6 build-type:    Custom stability:     experimental

test.hs view

@@ -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