atomic-primops 0.6 → 0.6.0.5
raw patch · 6 files changed
+146/−37 lines, 6 filesdep −Cabal
Dependencies removed: Cabal
Files
- DEVLOG.md +69/−0
- Data/Atomics.hs +16/−6
- Data/Atomics/Internal.hs +13/−22
- atomic-primops.cabal +7/−4
- testing/Test.hs +14/−0
- testing/test-atomic-primops.cabal +27/−5
DEVLOG.md view
@@ -340,3 +340,72 @@ representing 14? +[2014.04.13] {On debug branch, working on Issue 28}+---------------------------------------------------++Ok, right now Issue28.hs does fail whether it is run as a standalone+executable or as part of the bigger test suite:++ cd atomic-primops/testing/+ cabal install --reinstall --with-ghc=ghc-7.8.2 .. . --enable-tests + ./dist/build/test-atomic-primops/test-atomic-primops -j1 -t stand++And taht is in the same batch of tests where SIMILAR tests such as+case_casTicket1 pass. Next, I also copied the same Issue28.hs code+into Test.hs with the other tests.++ ./dist/build/test-atomic-primops/test-atomic-primops -j1 -t issue28_copied++This version fails in the same way -- the ticket gets corrupted.+++++[2014.04.13] {GHC panic}+------------------------++Just cherry-picked a patch from the debug to master branch.+Got this:++ $ ghc-7.8.2 -main-is Issue28.main -threaded -O2 Issue28.hs -fforce-recomp -rtsopts -with-rts+ opts=-N4 $GHCDUMP+ [1 of 1] Compiling Issue28 ( Issue28.hs, Issue28.o )+ ghc: panic! (the 'impossible' happened)+ (GHC version 7.8.2 for x86_64-apple-darwin):+ Iface Lint failure+ In interface for atomic-primops-0.6.0.4:Data.Atomics+ Unfolding of casIORef{v r5s}+ <no location info>: Warning:+ In the expression: casMutVar#{(w) v 94F} [gid[PrimOp]]+ @ Any{(w) tc 31N}+ @ Any{(w) tc 31N}+ (var{v a12G} [lid]+ `cast` ((MutVar#{(w) tc 32F}+ (UnivCo nominal RealWorld{(w) tc 31E} Any{(w) tc 31N})+ (UnivCo representational+ a11{tv a12y} [tv] Any{(w) tc 31N}))_R+ :: MutVar#{(w) tc 32F}+ RealWorld{(w) tc 31E} a11{tv a12y} [tv]+ ~#+ MutVar#{(w) tc 32F} Any{(w) tc 31N} Any{(w) tc 31N}))+ (old{v a12A} [lid]+ `cast` (Any{(w) tc 31N}_R :: Any{(w) tc 31N} ~# Any{(w) tc 31N}))+ (new{v a12B} [lid]+ `cast` (UnivCo representational+ a11{tv a12y} [tv] (Ticket{tc r5g} a11{tv a12y} [tv])+ ; Any{(w) tc 31N}_R+ :: a11{tv a12y} [tv] ~# Any{(w) tc 31N}))+ (st{v a12I} [lid]+ `cast` ((State#{(w) tc 32q}+ (UnivCo nominal RealWorld{(w) tc 31E} Any{(w) tc 31N}))_R+ :: State#{(w) tc 32q} RealWorld{(w) tc 31E}+ ~#+ State#{(w) tc 32q} Any{(w) tc 31N}))+ From-type of Cast differs from type of enclosed expression+ From-type: Any{(w) tc 31N}+ Type of enclosed expr: Ticket{tc r5g} a11{tv a12y} [tv]+ Actual enclosed expr: old{v a12A} [lid]+ Coercion used in cast: Any{(w) tc 31N}_R+++
Data/Atomics.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, ScopedTypeVariables, CPP #-}+{-# LANGUAGE MagicHash, UnboxedTuples, ScopedTypeVariables, BangPatterns, CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- | Provides atomic memory operations on IORefs and Mutable Arrays.@@ -39,6 +39,7 @@ import Data.Primitive.ByteArray (MutableByteArray(MutableByteArray)) import Data.Atomics.Internal import Data.Int -- TEMPORARY+import Debug.Trace import Data.IORef import GHC.IORef hiding (atomicModifyIORef)@@ -91,11 +92,13 @@ -- | Compare-and-swap. Follows the same rules as `casIORef`, returning the ticket for -- then next operation.+-- +-- By convention this is WHNF strict in the "new" value provided. casArrayElem :: MutableArray RealWorld a -> Int -> Ticket a -> a -> IO (Bool, Ticket a) -- casArrayElem (MutableArray arr#) (I# i#) old new = IO$ \s1# -> -- case casArray# arr# i# old new s1# of -- (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #)-casArrayElem arr i old new = casArrayElem2 arr i old (seal new)+casArrayElem arr i old !new = casArrayElem2 arr i old (seal new) -- | This variant takes two tickets: the 'new' value is a ticket rather than an -- arbitrary, lifted, Haskell value.@@ -168,11 +171,15 @@ -- the user of this module from needing to worry about the pointer equality of their -- values, which in general requires reasoning about the details of the Haskell -- implementation (GHC).+--+-- By convention this function is strict in the "new" value argument. This isn't+-- absolutely necesary, but we think it's a bad habit to use unevaluated thunks in+-- this context. casIORef :: IORef a -- ^ The 'IORef' containing a value 'current' -> Ticket a -- ^ A ticket for the 'old' value -> a -- ^ The 'new' value to replace 'current' if @old == current@ -> IO (Bool, Ticket a) -- ^ Success flag, plus ticket for the NEXT operation.-casIORef (IORef (STRef var)) old new = casMutVar var old new +casIORef (IORef (STRef var)) old !new = casMutVar var old new -- | This variant takes two tickets, i.e. the 'new' value is a ticket rather than an -- arbitrary, lifted, Haskell value.@@ -200,17 +207,20 @@ -- | Like `readForCAS`, but for `MutVar#`. readMutVarForCAS :: MutVar# RealWorld a -> IO ( Ticket a )-readMutVarForCAS !mv = IO$ \ st -> readForCAS# mv st+readMutVarForCAS mv = IO$ \ st -> readForCAS# mv st -- | MutVar counterpart of `casIORef`. --+-- By convention this is WHNF strict in the "new" value provided. casMutVar :: MutVar# RealWorld a -> Ticket a -> a -> IO (Bool, Ticket a)-casMutVar !mv !tick !new = casMutVar2 mv tick (seal new)+casMutVar mv tick !new = + -- trace ("TEMPDBG: Inside casMutVar.. ") $ + casMutVar2 mv tick (seal new) -- | This variant takes two tickets, i.e. the 'new' value is a ticket rather than an -- arbitrary, lifted, Haskell value. casMutVar2 :: MutVar# RealWorld a -> Ticket a -> Ticket a -> IO (Bool, Ticket a)-casMutVar2 !mv !tick !new = IO$ \st -> +casMutVar2 mv tick new = IO$ \st -> case casMutVarTicketed# mv tick new st of (# st, flag, tick' #) -> (# st, (flag ==# 0#, tick') #)
Data/Atomics/Internal.hs view
@@ -7,13 +7,11 @@ -- operations. module Data.Atomics.Internal (--- From GHC 7.8 onward these are built into the compiler:-#if MIN_VERSION_base(4,7,0) -#else casIntArray#, fetchAddIntArray#, -#endif readForCAS#, casMutVarTicketed#, casArrayTicketed#, - Ticket+ Ticket,+ -- * Very unsafe, not to be used+ ptrEq ) where @@ -24,37 +22,28 @@ unsafeCoerce#, reallyUnsafePtrEquality#) #if MIN_VERSION_base(4,7,0)-import GHC.Prim (casArray#, casIntArray#, fetchAddIntArray#) -#endif- -#if MIN_VERSION_base(4,5,0)--- Any is only in GHC 7.6!!! We want 7.4 support.+import GHC.Prim (casArray#, casIntArray#, fetchAddIntArray#, Any, readMutVar#, casMutVar#)+#elif MIN_VERSION_base(4,6,0)+-- Any is only supported in the FFI in the way we need in GHC 7.6+ import GHC.Prim (readMutVar#, casMutVar#, Any) #else-#error "Need to figure out how to emulate Any () in GHC < 7.4 !"+#error "Need to figure out how to emulate Any () in GHC <= 7.4 !" -- type Any a = Word# #endif --#if MIN_VERSION_base(4,7,0) -#else------------------------------------------------------------------------------------- CAS and friendsa---------------------------------------------------------------------------------- #ifdef DEBUG_ATOMICS {-# NOINLINE readForCAS# #-}-{-# NOINLINE casArrayTicketed# #-} {-# NOINLINE casMutVarTicketed# #-}+{-# NOINLINE casArrayTicketed# #-} #else {-# INLINE casMutVarTicketed# #-} {-# INLINE casArrayTicketed# #-} -- I *think* inlining may be ok here as long as casting happens on the arrow types: #endif -#endif--- End GHC >7.6+--------------------------------------------------------------------------------+-- CAS and friends+-------------------------------------------------------------------------------- -- | Unsafe, machine-level atomic compare and swap on an element within an Array. casArrayTicketed# :: MutableArray# RealWorld a -> Int# -> Ticket a -> Ticket a @@ -143,6 +132,8 @@ -- foreign import prim "stg_readMutVar2zh" readMutVar_TypeErased# -- :: MutVar# RealWorld () -> -- State# RealWorld -> (# State# RealWorld, Any () #)+ -- with has_side_effects = True+ -- commutable = False foreign import prim "stg_casByteArrayIntzh" casIntArray# :: MutableByteArray# s -> Int# -> Int# -> Int# ->
atomic-primops.cabal view
@@ -1,5 +1,5 @@ Name: atomic-primops-Version: 0.6+Version: 0.6.0.5 License: BSD3 License-file: LICENSE Author: Ryan Newton@@ -17,6 +17,7 @@ -- of cabal is used WITH profiling mode. HomePage: https://github.com/rrnewton/haskell-lockfree/wiki+Bug-Reports: https://github.com/rrnewton/haskell-lockfree/issues -- Version History: -- 0.1.0.0 -- initial release@@ -30,6 +31,8 @@ -- 0.5 -- Nix Data.Atomics.Counter.Foreign and the bits-atomic dependency. -- 0.5.0.2 -- IMPORTANT Bugfix release. -- 0.6 -- add atomicModifyIORefCAS, and bump due to prev bugfixes+-- 0.6.0.1 -- minor ghc 7.8 fix+-- 0.6.0.5 -- fix for GHC 7.8 Synopsis: A safe approach to CAS and other atomic ops in Haskell. @@ -93,7 +96,7 @@ -- casMutVar# had a bug in GHC 7.2, thus we require GHC 7.4 or greater -- (base 4.5 or greater). We also need the "Any" kind.- build-depends: base >= 4.5.0.0 && <= 4.7.0.0, ghc-prim, primitive, Cabal+ build-depends: base >= 4.6.0.0 && <= 4.7.0.0, ghc-prim, primitive -- TODO: Try to push support back to 7.0, but make it default to an implementation -- other than Unboxed.@@ -126,5 +129,5 @@ Source-Repository head Type: git- Location: git://github.com/rrnewton/haskell-lockfree.git- Subdir: atomic-primops/+ Location: https://github.com/rrnewton/haskell-lockfree/+ Subdir: atomic-primops
testing/Test.hs view
@@ -34,6 +34,8 @@ import Data.Atomics as A import Data.Atomics (casArrayElem, readArrayElem) +import qualified Issue28+ import CommonTesting import qualified CounterReference import qualified CounterUnboxed@@ -60,6 +62,8 @@ defaultMain $ [ testCase "casTicket1" case_casTicket1+ , testCase "issue28_standalone" case_issue28_standalone+ , testCase "issue28_copied " case_issue28_copied , testCase "create_and_read" case_create_and_read , testCase "create_and_mutate" case_create_and_mutate , testCase "create_and_mutate_twice" case_create_and_mutate_twice@@ -216,6 +220,16 @@ res3 <- A.readMutVarForCAS mutvar dbgPrint 1$"To check contents, did a SECOND read: "++show res3 + return ()++case_issue28_standalone :: Assertion+case_issue28_standalone = Issue28.main++case_issue28_copied :: Assertion+case_issue28_copied = do + r <- newIORef "hi"+ t0 <- readForCAS r+ (True,t1) <- casIORef r t0 "bye" return () ---- toddaaro's tests -----
testing/test-atomic-primops.cabal view
@@ -2,13 +2,14 @@ -- Trying a completely separate .cabal for testing. Name: test-atomic-primops-Version: 0.5.0.2+Version: 0.6.0.5 Build-type: Simple Cabal-version: >=1.8 +-- This is generally controled by the continuous integration script at a more granular level: Flag opt Description: Enable GHC optimization.- Default: True+ Default: False Flag threaded Description: Enable GHC threaded RTS.@@ -27,11 +28,11 @@ ghc-options: -O2 -funbox-strict-fields if flag(threaded) ghc-options: -threaded + ghc-options: -rtsopts -with-rtsopts=-N4 -- Set it to always run with some parallelism.- ghc-options: -rtsopts -with-rtsopts=-N4 - build-depends: base, ghc-prim, primitive, containers, random, atomic-primops >= 0.5,+ build-depends: base, ghc-prim, primitive, containers, random, atomic-primops >= 0.6.0.5, -- For Testing: time, HUnit, test-framework, test-framework-hunit @@ -51,9 +52,30 @@ main-is: ghci-test.hs if flag(withTH) { Buildable: True- build-depends: base >= 4.5, atomic-primops >= 0.5, template-haskell,+ build-depends: base >= 4.5, atomic-primops >= 0.6.0.5, template-haskell, -- For Testing: test-framework, test-framework-hunit } else { Buildable: False }++-- A very simple test of one primop included in GHC 7.8:+Test-suite raw_CAS+ type: exitcode-stdio-1.0+ build-depends: base, ghc-prim, atomic-primops >= 0.6.0.5+-- ghc-prim, primitive, containers, random, atomic-primops >= 0.5.0.2,+ main-is: Raw781_test.hs+ if impl(ghc < 7.7) {+ Buildable: False + }+++Test-suite Issue28+ type: exitcode-stdio-1.0+ build-depends: base, ghc-prim, atomic-primops >= 0.6.0.5+ main-is: Issue28.hs+ ghc-options: -main-is Issue28.main+ -- if impl(ghc < 7.7) {+ -- Buildable: False + -- }+