diff --git a/DEVLOG.md b/DEVLOG.md --- a/DEVLOG.md +++ b/DEVLOG.md @@ -1,6 +1,7 @@ [2013.04.07] {Figuring out install methods, linking, and segfaults} +------------------------------------------------------------------- Ok, here's the weird state of affairs at the moment. @@ -44,7 +45,7 @@ cabal install --disable-library-profiling --disable-documentation -But NOT with a vanially cabal install (profiling and documentation). +But NOT with a vanilla cabal install (profiling and documentation). As expected, it is the profiling that makes the difference. Note that I am NOT building the test with profiling. The profiling version should be IRRELEVANT. Why does this cause the segfault? diff --git a/Data/Atomics.hs b/Data/Atomics.hs --- a/Data/Atomics.hs +++ b/Data/Atomics.hs @@ -17,6 +17,7 @@ -- * Atomic operations on IORefs readForCAS, casIORef, casIORef2, + atomicModifyIORefCAS, atomicModifyIORefCAS_, -- * Atomic operations on mutable arrays casArrayElem, casArrayElem2, readArrayElem, @@ -33,13 +34,14 @@ ) where import Control.Monad.ST (stToIO) +import Control.Exception (evaluate) import Data.Primitive.Array (MutableArray(MutableArray)) import Data.Primitive.ByteArray (MutableByteArray(MutableByteArray)) import Data.Atomics.Internal import Data.Int -- TEMPORARY -import Data.IORef -import GHC.IORef +import Data.IORef +import GHC.IORef hiding (atomicModifyIORef) import GHC.STRef import GHC.ST #if MIN_VERSION_base(4,7,0) @@ -251,4 +253,55 @@ foreign import ccall unsafe "DUP_write_barrier" writeBarrier :: IO () #endif + + +-------------------------------------------------------------------------------- + + +-- | 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. +-- +-- The upside is that sometimes we see a performance benefit. +-- The downside is that this version is speculative -- when it +-- retries, it must reexecute the compution. +atomicModifyIORefCAS :: IORef a -- ^ Mutable location to modify + -> (a -> (a,b)) -- ^ Computation runs one or more times (speculation) + -> IO b +atomicModifyIORefCAS ref fn = do + -- TODO: Should handle contention in a better way... + tick <- readForCAS ref + loop tick effort + where + effort = 30 :: Int -- TODO: Tune this. + loop old 0 = atomicModifyIORef ref fn -- Fall back to the regular version. + loop old tries = do + (new,result) <- evaluate $ fn $ peekTicket old + (b,tick) <- casIORef ref old new + if b + then return result + else loop tick (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: +-- +atomicModifyIORefCAS_ ref fn = do + tick <- readForCAS ref + loop tick effort + where + effort = 30 :: Int -- TODO: Tune this. + loop old 0 = atomicModifyIORef_ ref fn + loop old tries = do + new <- evaluate $ fn $ peekTicket old + (b,val) <- casIORef ref old new + if b + then return () + else loop val (tries-1) + atomicModifyIORef_ ref fn = atomicModifyIORef ref (\ x -> (fn x, ())) +-- diff --git a/Data/Atomics/Counter/Foreign.hs b/Data/Atomics/Counter/Foreign.hs deleted file mode 100644 --- a/Data/Atomics/Counter/Foreign.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- | This implementation stores an unboxed counter and uses FFI operations to modify --- its contents. It has the advantage that it can use true fetch-and-add operations. --- It has the disadvantage of extra overhead due to FFI calls. - -module Data.Atomics.Counter.Foreign - (AtomicCounter, CTicket, - newCounter, readCounterForCAS, readCounter, peekCTicket, - writeCounter, casCounter, incrCounter, incrCounter_) - where -import Control.Monad (void) -import Data.Bits.Atomic -import Foreign.ForeignPtr -import Foreign.Storable - --- newtype AtomicCounter = AtomicCounter (ForeignPtr Int) -type AtomicCounter = ForeignPtr Int - -type CTicket = Int - -{-# INLINE newCounter #-} --- | Create a new counter initialized to the given value. -newCounter :: Int -> IO AtomicCounter -newCounter n = do x <- mallocForeignPtr - writeCounter x n - -- Do we need a write barrier here? - return x - -{-# INLINE incrCounter #-} --- | Increment the counter by a given amount. --- Returns the original value before the increment. --- --- Note that UNLIKE with boxed implementations of counters, where increment is --- based on CAS, this increment is /O(1)/. Fetch-and-add does not require a retry --- loop like CAS. -incrCounter :: Int -> AtomicCounter -> IO Int -incrCounter bump r = withForeignPtr r$ \r' -> fetchAndAdd r' bump - -{-# INLINE incrCounter_ #-} --- | An alternate version for when you don't care about the old value. -incrCounter_ :: Int -> AtomicCounter -> IO () -incrCounter_ bump r = withForeignPtr r$ \r' -> void (fetchAndAdd r' bump) - -{-# INLINE readCounterForCAS #-} --- | Just like the "Data.Atomics" CAS interface, this routine returns an opaque --- ticket that can be used in CAS operations. -readCounterForCAS :: AtomicCounter -> IO CTicket -readCounterForCAS = readCounter - -{-# INLINE peekCTicket #-} --- | Opaque tickets cannot be constructed, but they can be destructed into values. -peekCTicket :: CTicket -> Int -peekCTicket x = x - -{-# INLINE readCounter #-} --- | Equivalent to `readCounterForCAS` followed by `peekCTicket`. -readCounter :: AtomicCounter -> IO Int -readCounter r = withForeignPtr r peek - -{-# INLINE writeCounter #-} --- | Make a non-atomic write to the counter. No memory-barrier. -writeCounter :: AtomicCounter -> Int -> IO () -writeCounter r !new = withForeignPtr r $ \r' -> poke r' new - -{-# INLINE casCounter #-} --- | Compare and swap for the counter ADT. -casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket) -casCounter r !tick !new = withForeignPtr r $ \r' -> do - b <- compareAndSwap r' tick new - -- if b then return (True,new) - -- else do x <- peek r' - -- return (False,x) - return (b==tick, b) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -9,6 +9,8 @@ import Distribution.PackageDescription (PackageDescription) import Debug.Trace +-- I couldn't figure out a way to do this check from the cabal file, so we drop down +-- here to do it instead: checkGoodVersion :: IO () checkGoodVersion = if cabalVersion >= Version [1,17,0] [] 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.5.0.2 +Version: 0.6 License: BSD3 License-file: LICENSE Author: Ryan Newton @@ -9,9 +9,15 @@ Build-type: Custom -- TODO: This requirement needs to be bumped to 1.17 when the latest cabal is -- released. This package triggers issue #1284: -Cabal-version: >=1.8 -HomePage: https://github.com/rrnewton/haskell-lockfree-queue/wiki +-- Cabal-version: >=1.18 +Cabal-version: >=1.10 +-- Egad! Requiring cabal version 1.18 triggers a seemingly spurious failure on Mac OS: +-- http://tester-lin.soic.indiana.edu:8080/job/Haskell-LockFree_master/JENKINS_GHC=7.6.3,label=macos/346/console +-- So for now I'm backing off about the cabal requirement. Setup.hs will catch it later IF an early version +-- of cabal is used WITH profiling mode. +HomePage: https://github.com/rrnewton/haskell-lockfree/wiki + -- Version History: -- 0.1.0.0 -- initial release -- 0.1.0.2 -- disable profiling @@ -23,6 +29,7 @@ -- 0.4.1 -- Add advance support for GHC 7.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 Synopsis: A safe approach to CAS and other atomic ops in Haskell. @@ -37,6 +44,10 @@ add access to other variants that may be of interest, specifically, compare and swap inside an array. . + Note that as of GHC 7.8, the relevant primops have been included in GHC itself. + This library is engineered to work pre- and post-GHC-7.8, while exposing the + same interface. + . Changes in 0.3: . * Major internal change. Duplicate the barrier code from the GHC RTS and thus @@ -53,8 +64,14 @@ Changes in 0.5: . * Remove dependency on bits-atomic unless a flag is turned on. + . + Changes in 0.5.0.2: + . + * IMPORTANT BUGFIXES - don't use earlier versions. They have been marked deprecated. + + Extra-Source-Files: DEVLOG.md, testing/Test.hs, testing/test-atomic-primops.cabal, testing/ghci-test.hs testing/Makefile, testing/CommonTesting.hs, testing/CounterCommon.hs, testing/hello.hs @@ -64,13 +81,8 @@ Description: Enable extra internal checks. Default: False --- The bits-atomic based modules are causing problems [2014.01.23] -Flag foreign - Description: Enable a dependency on bits-atomic and in turn provide a - foreign implementation of Counter. - Default: False - Library + Default-Language: Haskell2010 exposed-modules: Data.Atomics Data.Atomics.Internal Data.Atomics.Counter @@ -79,16 +91,13 @@ Data.Atomics.Counter.Unboxed ghc-options: -O2 -funbox-strict-fields - if flag (foreign) { - exposed-modules: Data.Atomics.Counter.Foreign - build-depends: bits-atomic - } - -- 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 - -- TODO: Try to push support back to 7.0: + -- TODO: Try to push support back to 7.0, but make it default to an implementation + -- other than Unboxed. + -- Ah, but if we don't USE casMutVar# in this package we are ok: -- build-depends: base >= 4.3, ghc-prim, primitive @@ -99,8 +108,6 @@ C-Sources: cbits/RtsDup.c } CC-Options: -Wall - -- Let the code know that profiling is on: - ghc-prof-options: -DGHC_PROFILING_ON -- if( cabal-version < 1.17 ) { -- ghc-prof-options: ERROR_DO_NOT_BUILD_THIS_WITH_PROFILING_YET__SEE_CABAL_ISSUE_1284 @@ -115,10 +122,9 @@ -- -- Switching to a separate package in ./testing/ -- Test-Suite test-atomic-primops -- type: exitcode-stdio-1.0 - +-- ... Source-Repository head Type: git - Location: git://github.com/rrnewton/haskell-lockfree-queue.git - - + Location: git://github.com/rrnewton/haskell-lockfree.git + Subdir: atomic-primops/ diff --git a/testing/CounterCommon.hs b/testing/CounterCommon.hs --- a/testing/CounterCommon.hs +++ b/testing/CounterCommon.hs @@ -9,7 +9,6 @@ import Text.Printf import Data.IORef -import Data.Atomics import CommonTesting (numElems, forkJoin, timeit, nTimes) --------------------------------------------------------------------------------