atomic-primops 0.4 → 0.5
raw patch · 9 files changed
+132/−43 lines, 9 filesdep ~base
Dependency ranges changed: base
Files
- DEVLOG.md +10/−0
- Data/Atomics.hs +10/−3
- Data/Atomics/Counter/Unboxed.hs +10/−7
- Data/Atomics/Internal.hs +46/−23
- atomic-primops.cabal +27/−8
- cbits/RtsDup.c +7/−0
- cbits/primops.cmm +6/−2
- testing/Test.hs +2/−0
- testing/test-atomic-primops.cabal +14/−0
DEVLOG.md view
@@ -294,3 +294,13 @@ The laptop has hyperthreading, but in the benchmark we only use four unpinned threads, not eight.... ++[2013.08.02] {Just observed a failure}++On machine basalt, ghc 7.6.3. But is it reproducible?++ create_and_mutate_twice: [OK]+ n_threads_mutate: [Failed]+ Did the sum end up equal to 120?+ run_barriers: [OK]+
Data/Atomics.hs view
@@ -71,6 +71,13 @@ {-# INLINE casMutVar2 #-} #endif ++-- GHC 7.8 changed some primops+#if MIN_VERSION_base(4,7,0)+(==#) :: Int# -> Int# -> Bool+(==#) x y = case x ==$# y of { 0# -> False; _ -> True }+#endif+ -------------------------------------------------------------------------------- -- | Compare-and-swap @@ -84,7 +91,7 @@ -- arbitrary, lifted, Haskell value. casArrayElem2 :: MutableArray RealWorld a -> Int -> Ticket a -> Ticket a -> IO (Bool, Ticket a) casArrayElem2 (MutableArray arr#) (I# i#) old new = IO$ \s1# ->- case casArray# arr# i# old new s1# of + case casArrayTicketed# arr# i# old new s1# of (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #) readArrayElem :: forall a . MutableArray RealWorld a -> Int -> IO (Ticket a)@@ -104,13 +111,13 @@ -- case casByteArrayInt# mba# ix# old# new# s1# of -- (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, I# res) #) - let (# s2#, res #) = casByteArrayInt# mba# ix# old# new# s1# in+ let (# s2#, res #) = casIntArray# mba# ix# old# new# s1# in (# s2#, (I# res) #) -- I don't know if a let will mak any difference here... hopefully not. fetchAddByteArrayInt :: MutableByteArray RealWorld -> Int -> Int -> IO Int fetchAddByteArrayInt (MutableByteArray mba#) (I# offset#) (I# incr#) = IO $ \ s1# -> - let (# s2#, res #) = fetchAddByteArrayInt# mba# offset# incr# s1# in+ let (# s2#, res #) = fetchAddIntArray# mba# offset# incr# s1# in (# s2#, (I# res) #) --------------------------------------------------------------------------------
Data/Atomics/Counter/Unboxed.hs view
@@ -8,8 +8,10 @@ import GHC.Base import GHC.Ptr-import Data.Atomics (casByteArrayInt)-import Data.Atomics.Internal (casByteArrayInt#, fetchAddByteArrayInt#)+import Data.Atomics (casByteArrayInt)+-- import Data.Atomics.Internal (casIntArray#, fetchAddIntArray#)+import Data.Atomics.Internal+import GHC.Prim #ifndef __GLASGOW_HASKELL__ #error "Unboxed Counter: this library is not portable to other Haskell's"@@ -69,7 +71,7 @@ casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket) -- casCounter (AtomicCounter barr) !old !new = casCounter (AtomicCounter mba#) (I# old#) (I# new#) = IO$ \s1# ->- let (# s2#, res# #) = casByteArrayInt# mba# 0# old# new# s1# in+ let (# s2#, res# #) = casIntArray# mba# 0# old# new# s1# in (# s2#, (res# ==# old#, I# res#) #) {-# INLINE sameCTicket #-}@@ -77,20 +79,21 @@ sameCTicket = (==) {-# INLINE incrCounter #-}--- | Increment the counter by a given amount.--- Returns the original value before the increment.+-- | Increment the counter by a given amount. Returns the value AFTER the increment+-- (in contrast with the behavior of the underlying instruction on architectures+-- like x86.) -- -- 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 (I# incr#) (AtomicCounter mba#) = IO $ \ s1# -> - let (# s2#, res #) = fetchAddByteArrayInt# mba# 0# incr# s1# in+ let (# s2#, res #) = fetchAddIntArray# mba# 0# incr# s1# in (# s2#, (I# res) #) {-# INLINE incrCounter_ #-} -- | An alternate version for when you don't care about the old value. incrCounter_ :: Int -> AtomicCounter -> IO () incrCounter_ (I# incr#) (AtomicCounter mba#) = IO $ \ s1# -> - let (# s2#, res #) = fetchAddByteArrayInt# mba# 0# incr# s1# in+ let (# s2#, res #) = fetchAddIntArray# mba# 0# incr# s1# in (# s2#, () #)
Data/Atomics/Internal.hs view
@@ -1,11 +1,18 @@ {-# LANGUAGE CPP, TypeSynonymInstances, BangPatterns #-} {-# LANGUAGE ForeignFunctionInterface, GHCForeignImportPrim, MagicHash, UnboxedTuples, UnliftedFFITypes #-} +#define CASTFUN+ -- | This module provides only the raw primops (and necessary types) for atomic -- operations. module Data.Atomics.Internal - (casArray#, casByteArrayInt#, fetchAddByteArrayInt#, - readForCAS#, casMutVarTicketed#, + (+-- 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, stg_storeLoadBarrier#, stg_loadLoadBarrier#, stg_writeBarrier# ) where @@ -15,6 +22,11 @@ import GHC.Prim (RealWorld, Int#, Word#, State#, MutableArray#, MutVar#, MutableByteArray#, 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 (readMutVar#, casMutVar#, Any)@@ -23,30 +35,39 @@ -- type Any a = Word# #endif ++#if MIN_VERSION_base(4,7,0) +#else++--------------------------------------------------------------------------------+-- CAS and friendsa+--------------------------------------------------------------------------------+ #ifdef DEBUG_ATOMICS {-# NOINLINE readForCAS# #-}-{-# NOINLINE casArray# #-}+{-# NOINLINE casArrayTicketed# #-} {-# NOINLINE casMutVarTicketed# #-}-#define CASTFUN #else {-# INLINE casMutVarTicketed# #-}-{-# INLINE casArray# #-}+{-# INLINE casArrayTicketed# #-} -- I *think* inlining may be ok here as long as casting happens on the arrow types:-#define CASTFUN #endif ------------------------------------------------------------------------------------ CAS and friendsa---------------------------------------------------------------------------------+#endif+-- End GHC >7.6 -- | Unsafe, machine-level atomic compare and swap on an element within an Array. -casArray# :: MutableArray# RealWorld a -> Int# -> Ticket a -> Ticket a +casArrayTicketed# :: MutableArray# RealWorld a -> Int# -> Ticket a -> Ticket a -> State# RealWorld -> (# State# RealWorld, Int#, Ticket a #)-#ifdef CASTFUN -- WARNING: cast of a function -- need to verify these are safe or eta expand.-casArray# = unsafeCoerce# casArrayTypeErased#+casArrayTicketed# = unsafeCoerce#+#if MIN_VERSION_base(4,7,0)+ -- In GHC 7.8 onward we just want to expose the existing primop with a different type:+ casArray#+#else+ casArrayTypeErased# #endif-+ -- | When performing compare-and-swaps, the /ticket/ encapsulates proof -- that a thread observed a specific previous value of a mutable -- variable. It is provided in lieu of the "old" value to@@ -55,12 +76,6 @@ -- If we allow tickets to be a pointer type, then the garbage collector will update -- the pointer when the object moves. -#if 0--- This technique is UNSAFE. False negatives are tolerable, but it may also--- introduce the possibility of false positives.-type Ticket = Word-type Ticket# = Word# -#endif instance Show (Ticket a) where show _ = "<CAS_ticket>"@@ -90,8 +105,11 @@ casMutVarTicketed# :: MutVar# RealWorld a -> Ticket a -> Ticket a -> State# RealWorld -> (# State# RealWorld, Int#, Ticket a #) -- WARNING: cast of a function -- need to verify these are safe or eta expand:-#ifdef CASTFUN-casMutVarTicketed# = unsafeCoerce# casMutVar_TypeErased#+casMutVarTicketed# =+#if MIN_VERSION_base(4,7,0) + unsafeCoerce# casMutVar#+#else+ unsafeCoerce# casMutVar_TypeErased# #endif --------------------------------------------------------------------------------@@ -114,6 +132,9 @@ -- polymorphic signature for the below functions. So we lie to the type system -- instead. +#if MIN_VERSION_base(4,7,0) +#else+ foreign import prim "stg_casArrayzh" casArrayTypeErased# :: MutableArray# RealWorld () -> Int# -> Any () -> Any () -> State# RealWorld -> (# State# RealWorld, Int#, Any () #) @@ -130,9 +151,11 @@ -- :: MutVar# RealWorld () -> -- State# RealWorld -> (# State# RealWorld, Any () #) -foreign import prim "stg_casByteArrayIntzh" casByteArrayInt#+foreign import prim "stg_casByteArrayIntzh" casIntArray# :: MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) -foreign import prim "stg_fetchAddByteArrayIntzh" fetchAddByteArrayInt#+foreign import prim "stg_fetchAddByteArrayIntzh" fetchAddIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) ++#endif
atomic-primops.cabal view
@@ -1,5 +1,5 @@ Name: atomic-primops-Version: 0.4+Version: 0.5 License: BSD3 License-file: LICENSE Author: Ryan Newton@@ -20,6 +20,8 @@ -- 0.2.2.1 -- Minor, add warning. -- 0.3 -- Major internal change. Duplicate GHC RTS barriers and support non -threaded. -- 0.4 -- Duplicate 'cas' as well as barriers. Add fetchAdd on ByteArray, Counter.Unboxed.+-- 0.4.1 -- Add advance support for GHC 7.8+-- 0.5 -- Nix Data.Atomics.Counter.Foreign and the bits-atomic dependency. Synopsis: A safe approach to CAS and other atomic ops in Haskell. @@ -46,6 +48,10 @@ * Add `fetchAddByteArrayInt` . * Add an `Unboxed` counter variant that uses movable "ByteArray"s on the GHC heap.+ .+ Changes in 0.5:+ . + * Remove dependency on bits-atomic unless a flag is turned on. Extra-Source-Files: DEVLOG.md,@@ -57,31 +63,44 @@ 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 exposed-modules: Data.Atomics Data.Atomics.Internal Data.Atomics.Counter Data.Atomics.Counter.IORef Data.Atomics.Counter.Reference- Data.Atomics.Counter.Foreign 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, ghc-prim, primitive, Cabal,- bits-atomic+ build-depends: base >= 4.5.0.0 && <= 4.7.0.0, ghc-prim, primitive, Cabal -- TODO: Try to push support back to 7.0: -- Ah, but if we don't USE casMutVar# in this package we are ok: -- build-depends: base >= 4.3, ghc-prim, primitive - Include-Dirs: cbits- C-Sources: cbits/primops.cmm- -- Duplicate RTS functionality: - C-Sources: cbits/RtsDup.c+ if impl(ghc < 7.7) {+ Include-Dirs: cbits+ C-Sources: cbits/primops.cmm+ -- Duplicate RTS functionality: + 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 -- }
cbits/RtsDup.c view
@@ -1,3 +1,10 @@++// ============================================================+// NOTE: We only use this file for GHC < 7.8.+// ============================================================++// This file duplicates certain functionality from the GHC runtime system (SMP.h).+ #define THREADED_RTS #undef KEEP_INLINES
cbits/primops.cmm view
@@ -1,4 +1,8 @@ +// ============================================================+// NOTE: We only use this file for GHC < 7.8.+// ============================================================+ #include "Cmm.h" #warning "Duplicating functionality from the GHC RTS..."@@ -44,7 +48,7 @@ len = StgMutArrPtrs_ptrs(arr); // The write barrier. We must write a byte into the mark table: I8[arr + SIZEOF_StgMutArrPtrs + WDS(len) + (ind >> MUT_ARR_PTRS_CARD_BITS )] = 1;- RET_NP(0,h);+ RET_NP(0,new); } } @@ -78,7 +82,6 @@ RET_N(h); } - // One difference from casMutVar# is that this version returns the NEW // pointer in the case of success, NOT the old one. stg_casMutVar2zh@@ -140,3 +143,4 @@ foreign "C" WHICH_WBARRIER(); RET_N(0); }+
testing/Test.hs view
@@ -245,6 +245,8 @@ assertBool "Does the value after the first mutate equal 5?" (peekTicket tick2 == 5) assertBool "Does the value after the second mutate equal 120?" (valf == 120) ++-- [2013.07.19] I just saw an isolated failure of this one: case_n_threads_mutate :: Assertion case_n_threads_mutate = do dbgPrint 1$ " Creating 120 threads and having each increment a counter value."
testing/test-atomic-primops.cabal view
@@ -14,6 +14,10 @@ Description: Enable GHC threaded RTS. Default: True +Flag withTH+ Description: Build the test suite, including the template-haskell-atomic-primops executable.+ Default: False+ Test-Suite test-atomic-primops type: exitcode-stdio-1.0 main-is: Test.hs@@ -35,3 +39,13 @@ Executable hello-world-atomic-primops main-is: hello.hs build-depends: base >= 4.5, atomic-primops++Executable template-haskell-atomic-primops+ main-is: ghci-test.hs+ if flag(withTH)+ Buildable: True+ else+ Buildable: False+ build-depends: base >= 4.5, atomic-primops >= 0.4, template-haskell,+ -- For Testing:+ test-framework, test-framework-hunit