diff --git a/DEVLOG.md b/DEVLOG.md --- a/DEVLOG.md +++ b/DEVLOG.md @@ -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} + : 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 + + + diff --git a/Data/Atomics.hs b/Data/Atomics.hs --- a/Data/Atomics.hs +++ b/Data/Atomics.hs @@ -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') #) diff --git a/Data/Atomics/Internal.hs b/Data/Atomics/Internal.hs --- a/Data/Atomics/Internal.hs +++ b/Data/Atomics/Internal.hs @@ -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# -> diff --git a/atomic-primops.cabal b/atomic-primops.cabal --- a/atomic-primops.cabal +++ b/atomic-primops.cabal @@ -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 diff --git a/testing/Test.hs b/testing/Test.hs --- a/testing/Test.hs +++ b/testing/Test.hs @@ -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 ----- diff --git a/testing/test-atomic-primops.cabal b/testing/test-atomic-primops.cabal --- a/testing/test-atomic-primops.cabal +++ b/testing/test-atomic-primops.cabal @@ -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 + -- } +