IORefCAS 0.2 → 0.2.0.1

raw patch · 5 files changed

+159/−109 lines, 5 filesdep +timePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: time

API changes (from Hackage documentation)

Files

• Data/CAS.hs +3/−94
• Data/CAS/Internal/Foreign.hs +5/−5
• Data/CAS/Internal/Native.hs +96/−0
• IORefCAS.cabal +16/−5
• Test.hs +39/−5

@@ -1,5 +1,5 @@-{-# LANGUAGE CPP, MagicHash, UnboxedTuples, BangPatterns, MagicHash,-    TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE CPP+  #-}  -- | Atomic compare and swap for IORefs and STRefs. module Data.CAS @@ -14,99 +14,8 @@ where  #if __GLASGOW_HASKELL__ <= 702  /* Fix to casMutVar introduced 2011.12.09 */- #warning "casMutVar is not included or is bugged in your GHC, falling back to Fake version."- import Data.CAS.Internal.Fake- #else--import Data.CAS.Internal.Class-import GHC.IO-import GHC.IORef-import GHC.Prim-import GHC.ST-import GHC.STRef------------------------------------------------------------------------------------newtype CASRef a = CR { unCR :: IORef a }--instance CASable CASRef a where -  newCASable x = newIORef x >>= (return . CR)-  readCASable  = readIORef  . unCR-  writeCASable = writeIORef . unCR-  cas          = casIORef   . unCR-------------------------------------------------------------------------------------- | Performs a machine-level compare and swap operation on an--- 'STRef'. Returns a tuple containing a 'Bool' which is 'True' when a--- swap is performed, along with the 'current' value from the 'STRef'.--- --- Note \"compare\" here means pointer equality in the sense of--- 'GHC.Prim.reallyUnsafePtrEquality#'.-casSTRef :: STRef s a -- ^ The 'STRef' containing a value 'current'-         -> a -- ^ The 'old' value to compare-         -> a -- ^ The 'new' value to replace 'current' if @old == current@-         -> ST s (Bool, a) -casSTRef (STRef var#) old new = ST $ \s1# ->-   -- The primop treats the boolean as a sort of error code.-   -- Zero means the CAS worked, one that it didn't.-   -- We flip that here:-    case casMutVar# var# old new s1# of-      (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #)---- | Performs a machine-level compare and swap operation on an--- 'IORef'. Returns a tuple containing a 'Bool' which is 'True' when a--- swap is performed, along with the 'current' value from the 'IORef'.--- --- Note \"compare\" here means pointer equality in the sense of--- 'GHC.Prim.reallyUnsafePtrEquality#'.-casIORef :: IORef a -- ^ The 'IORef' containing a value 'current'-         -> a -- ^ The 'old' value to compare-         -> a -- ^ The 'new' value to replace 'current' if @old == current@-         -> IO (Bool, a) -casIORef (IORef var) old new = stToIO (casSTRef var old new)---- | A drop-in replacement for `atomicModifyIORefCAS` that---   optimistically attempts to compute the new value and CAS it into---   place without introducing new thunks or locking anything.  Note---   that this is more STRICT than its standard counterpart and will only---   place evaluated (WHNF) values in the IORef.-atomicModifyIORefCAS :: IORef a -> (a -> (a,b)) -> IO b-atomicModifyIORefCAS ref fn = do--- TODO: Should handle contention in a better way.-   init <- readIORef ref-   loop init effort-  where -   effort = 30 :: Int -- TODO: Tune this.-   loop old 0     = atomicModifyIORef ref fn-   loop old tries = do -     (new,result) <- evaluate (fn old)-     (b,val) <- casIORef ref old new-     if b -      then return result-      else loop val (tries-1)---- | A simpler version that modifies the state but does not return anything.-atomicModifyIORefCAS_ :: IORef t -> (t -> t) -> IO ()--- atomicModifyIORefCAS_ ref fn = atomicModifyIORefCAS ref (\ x -> (fn x, ()))--- Can't inline a function with a loop so we duplicate this:--- <duplicated code>-atomicModifyIORefCAS_ ref fn = do-   init <- readIORef ref-   loop init effort-  where -   effort = 30 :: Int -- TODO: Tune this.-   loop old 0     = atomicModifyIORef_ ref fn-   loop old tries = do -     new <- evaluate (fn old)-     (b,val) <- casIORef ref old new-     if b -      then return ()-      else loop val (tries-1)-   atomicModifyIORef_ ref fn = atomicModifyIORef ref (\ x -> (fn x, ()))--- </duplicated code>-+import Data.CAS.Internal.Native #endif

@@ -85,11 +85,11 @@  -------------------------------------------------------------------------------- #if 0--- | INEFFICENT but safe implementation for arbitrary Haskell values.+-- | INEFFICIENT but safe implementation for arbitrary Haskell values. --   This version uses StablePtr's to store Haskell values in foreign storage. --  -- This should NOT be useful for implementing efficient data--- strcuctures because it itself dependends on concurrent access to+-- structures because it itself depends on concurrent access to -- the GHC runtimes table of pinned StablePtr values. instance CASable CASRef a where  --  newtype CASRef a = Hskl (StablePtr a)@@ -105,15 +105,15 @@     -- Here we assume that when we let go of the reference that we     -- free whatever StablePtr is contained in it at the time.     -- fp <- FC.newForeignPtr mem $ -          -- There should be no races for this finalizer becuase all+          -- There should be no races for this finalizer because all           -- Haskell threads have let go of the foreign pointer: --          do curp <- withForeignPtr fp peek  --	     freeStablePtr curp     fp <- mallocForeignPtr     withForeignPtr fp (`poke` p)     FC.addForeignPtrFinalizer fp $-         do putStrLn$ "EXPECTATION INVALVIDATED: CURRENTLY THIS SHOULD NEVER HAPPEN BECAUSE THE FINALIZER KEEPS IT ALIVE!"-	    -- Todo... week pointer here.+         do putStrLn$ "EXPECTATION INVALIDATED: CURRENTLY THIS SHOULD NEVER HAPPEN BECAUSE THE FINALIZER KEEPS IT ALIVE!"+	    -- Todo... weak pointer here.             curp <- withForeignPtr fp peek  	    freeStablePtr curp 

@@ -0,0 +1,96 @@+{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns,+    TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}++module Data.CAS.Internal.Native+ ( CASRef, casIORef, ptrEq, +   atomicModifyIORefCAS, atomicModifyIORefCAS_ + )+ where ++import Data.CAS.Internal.Class+import GHC.IO+import GHC.IORef+import GHC.Prim+import GHC.ST+import GHC.STRef++--------------------------------------------------------------------------------++newtype CASRef a = CR { unCR :: IORef a }++instance CASable CASRef a where +  newCASable x = newIORef x >>= (return . CR)+  readCASable  = readIORef  . unCR+  writeCASable = writeIORef . unCR+  cas          = casIORef   . unCR++--------------------------------------------------------------------------------++-- | Performs a machine-level compare and swap operation on an+-- 'STRef'. Returns a tuple containing a 'Bool' which is 'True' when a+-- swap is performed, along with the 'current' value from the 'STRef'.+-- +-- Note \"compare\" here means pointer equality in the sense of+-- 'GHC.Prim.reallyUnsafePtrEquality#'.+casSTRef :: STRef s a -- ^ The 'STRef' containing a value 'current'+         -> a -- ^ The 'old' value to compare+         -> a -- ^ The 'new' value to replace 'current' if @old == current@+         -> ST s (Bool, a) +casSTRef (STRef var#) old new = ST $ \s1# ->+   -- The primop treats the boolean as a sort of error code.+   -- Zero means the CAS worked, one that it didn't.+   -- We flip that here:+    case casMutVar# var# old new s1# of+      (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #)++-- | Performs a machine-level compare and swap operation on an+-- 'IORef'. Returns a tuple containing a 'Bool' which is 'True' when a+-- swap is performed, along with the 'current' value from the 'IORef'.+-- +-- Note \"compare\" here means pointer equality in the sense of+-- 'GHC.Prim.reallyUnsafePtrEquality#'.+casIORef :: IORef a -- ^ The 'IORef' containing a value 'current'+         -> a -- ^ The 'old' value to compare+         -> a -- ^ The 'new' value to replace 'current' if @old == current@+         -> IO (Bool, a) +casIORef (IORef var) old new = stToIO (casSTRef var old new)++-- | A drop-in replacement for `atomicModifyIORefCAS` that+--   optimistically attempts to compute the new value and CAS it into+--   place without introducing new thunks or locking anything.  Note+--   that this is more STRICT than its standard counterpart and will only+--   place evaluated (WHNF) values in the IORef.+atomicModifyIORefCAS :: IORef a -> (a -> (a,b)) -> IO b+atomicModifyIORefCAS ref fn = do+-- TODO: Should handle contention in a better way.+   init <- readIORef ref+   loop init effort+  where +   effort = 30 :: Int -- TODO: Tune this.+   loop old 0     = atomicModifyIORef ref fn+   loop old tries = do +     (new,result) <- evaluate (fn old)+     (b,val) <- casIORef ref old new+     if b +      then return result+      else loop val (tries-1)++-- | A simpler version that modifies the state but does not return anything.+atomicModifyIORefCAS_ :: IORef t -> (t -> t) -> IO ()+-- atomicModifyIORefCAS_ ref fn = atomicModifyIORefCAS ref (\ x -> (fn x, ()))+-- Can't inline a function with a loop so we duplicate this:+-- <duplicated code>+atomicModifyIORefCAS_ ref fn = do+   init <- readIORef ref+   loop init effort+  where +   effort = 30 :: Int -- TODO: Tune this.+   loop old 0     = atomicModifyIORef_ ref fn+   loop old tries = do +     new <- evaluate (fn old)+     (b,val) <- casIORef ref old new+     if b +      then return ()+      else loop val (tries-1)+   atomicModifyIORef_ ref fn = atomicModifyIORef ref (\ x -> (fn x, ()))+-- </duplicated code>

@@ -1,5 +1,5 @@ Name:                IORefCAS-Version:             0.2+Version:             0.2.0.1 License:             BSD3 License-file:        LICENSE Author:              Adam C. Foltzer, Ryan Newton@@ -7,6 +7,7 @@ Category:            Data Build-type:          Simple Cabal-version:       >=1.8+HomePage: https://github.com/rrnewton/haskell-lockfree-queue/wiki  -- Version History: -- 0.0.1   -- initial release@@ -14,6 +15,7 @@ -- 0.0.1.2 -- Egad, super minor update. -- 0.1.0.1 -- Include ptrEq in Data.CAS -- 0.2     -- Bumped for #if policy to test for GHC >7.2.  Removed casSTRef from the API for now.+-- 0.2.0.1 -- fix for test suite  Synopsis: Atomic compare and swap for IORefs and STRefs. @@ -40,7 +42,9 @@   exposed-modules:   Data.CAS,                      Data.CAS.Internal.Class,                      Data.CAS.Internal.Fake,-                     Data.CAS.Internal.Foreign+                     Data.CAS.Internal.Native+  if (!os(mingw32))+    exposed-modules: Data.CAS.Internal.Foreign   -- I have observed problems on both Mac and Linux with 7.0.x.  [2011.12.23]   -- Thus for now we require GHC 7.2 or greater (base 4.4 or greater).   -- Namely Test.hs observes CAS failing half the time even with only ONE thread.@@ -53,9 +57,16 @@ Test-Suite test-IORefCAS     type:       exitcode-stdio-1.0     main-is:    Test.hs-    ghc-options: -O2 -threaded -rtsopts -    cpp-options: -DT1 -DT2 -DT3-    build-depends: QuickCheck, HUnit, bits-atomic+    ghc-options: -O2 -threaded -rtsopts+    cpp-options: -DT1 -DT2+    if !os(mingw32)+      cpp-options: -DT3+    build-depends: base >= 4.4 && < 5, time, ghc-prim,+                   QuickCheck, HUnit, bits-atomic -- TODO: Refactor to use test-framework: --                 , test-framework, test-framework-hunit -- test-framework-quickcheck2++Source-Repository head+    Type:         git+    Location:     git://github.com/rrnewton/haskell-lockfree-queue.git

@@ -2,8 +2,8 @@     , FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances   #-} ---- | This test has three different modes which can be toggled via +-- | This test has three different modes which can be toggled via the+-- C preprocessor.  Any subset of the three may be activated.  import Control.Monad import Control.Exception@@ -18,7 +18,7 @@ import GHC.IO (unsafePerformIO)  #ifdef T1-import qualified Data.CAS         as A+import qualified Data.CAS.Internal.Native  as A #endif #ifdef T2 import qualified Data.CAS.Internal.Fake    as B@@ -85,6 +85,7 @@ type ElemTy = Word32 -- This will trigger CAS.Foreign's specialization.  {-# INLINE testCAS1 #-}+-- First test: Run a simple CAS a small number of times. testCAS1 :: CASable ref ElemTy => ref ElemTy -> IO [Bool] testCAS1 r =    do @@ -114,9 +115,9 @@      ls <- readIORef bitls      return (reverse ls) + ---------------------------------------------------------------------------------------------------- --- UNFINISHED, TODO: -- This version hammers on CASref from all threads, then checks to see -- if enough threads succeeded enough of the time. @@ -152,6 +153,7 @@  -------------------------------------------------------------------------------- +-- UNFINISHED -- This tests repeated atomicModifyIORefCAS operations.  testCAS3 :: Int -> IORef ElemTy -> IO [()]@@ -173,7 +175,39 @@ #endif 	loop (n-1) -       +----------------------------------------------------------------------------------------------------       +-- This version uses a non-scalar type for CAS.  It instead+-- manipulates the tail pointers of a simple linked-list.++#if 0+data List k = Null | Cons Int (k (List k))++type ListA = List A.CASRef+type ListB = List B.CASRef+type ListC = List C.CASRef++-- testCAS4 :: CASable ref Int => List ref -> IO [Bool]+testCAS4 :: CASable ref Int => Int -> ref (List ref) -> IO ()+testCAS4 iters ref = do +  forkJoin numCapabilities $ do+     -- From each thread, attempt to extend the list 'iters' times:+     ref' <- readCASable ref+     nl   <- newIORef Null+     loop iters (Cons (-1) nl) ref'+     return ()++  return ()+ where +  loop 0 _ _ = return ()+  loop n new (Cons _ tl) = do+    tl' <- readCASable tl+    case tl' of +      Null -> do (b,v) <- cas tl tl' new+		 if b then loop (n-1) v+		      else loop v+      cons -> loop cons tl'+  loop n _ Null = error "too short"+#endif   ----------------------------------------------------------------------------------------------------