atomic-primops 0.8.2 → 0.8.8
raw patch · 10 files changed
Files
- CHANGELOG.md +23/−0
- Data/Atomics.hs +37/−111
- Data/Atomics/Counter.hs +0/−14
- Data/Atomics/Internal.hs +13/−73
- atomic-primops.cabal +16/−37
- cbits/atomics.cmm +20/−0
- cbits/primops.cmm +0/−128
- testing/Fetch.hs +0/−1
- testing/Test.hs +2/−2
- testing/test-atomic-primops.cabal +45/−28
CHANGELOG.md view
@@ -1,3 +1,26 @@+## 0.8.8 [2024.06.20]+* Fix infinite loops in the implementations of `storeLoadBarrier`,+ `loadLoadBarrier`, and `writeBarrier` when building with GHC 9.10 or later.++## 0.8.7 [2024.04.20]+* Fix typos in the `foreign import`s introduced in `atomic-primops-0.8.5` and+ `atomic-primops-0.8.6`, which would lead to linker errors when building+ executables with GHC 9.10.++## 0.8.6 [2024.04.16]+* Use `prim`, not `ccall`, for the `foreign import`s used when building the+ library with GHC 9.10 or later. This fixes a GHC 9.10-specific build issue.++## 0.8.5 [2024.02.17]+* Allow building with GHC 9.10.++## 0.8.4 [2020.10.03]+* Allow building with `base-4.15` (GHC 9.0).++## 0.8.3 [2019.05.02]+* Allow the tests to build with `base-4.13` (GHC 8.8).+* Require GHC 7.10 or later.+ ## 0.8.2 [2018.03.08] * Allow building with `base-4.11`.
Data/Atomics.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE MagicHash, UnboxedTuples, ScopedTypeVariables, BangPatterns, CPP #-}+{-# LANGUAGE MagicHash, UnboxedTuples, ScopedTypeVariables, BangPatterns, CPP #-} {-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 909+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE UnliftedFFITypes #-}+#endif -- | Provides atomic memory operations on IORefs and Mutable Arrays. --@@ -53,23 +57,11 @@ import Data.IORef import GHC.IORef hiding (atomicModifyIORef) import GHC.STRef-#if MIN_VERSION_base(4,7,0)-import GHC.Prim hiding ((==#))+import GHC.Exts hiding ((==#)) import qualified GHC.PrimopWrappers as GPW-#else-import GHC.Prim-#endif-import GHC.Base (Int(I#)) import GHC.IO (IO(IO)) -- import GHC.Word (Word(W#)) --#if MIN_VERSION_base(4,8,0)-#else-import Data.Bits-import Data.Primitive.ByteArray (readByteArray)-#endif- #ifdef DEBUG_ATOMICS #warning "Activating DEBUG_ATOMICS... NOINLINE's and more" {-# NOINLINE seal #-}@@ -110,10 +102,8 @@ -- GHC 7.8 changed some primops-#if MIN_VERSION_base(4,7,0) (==#) :: Int# -> Int# -> Bool (==#) x y = case x GPW.==# y of { 0# -> False; _ -> True }-#endif -------------------------------------------------------------------------------- @@ -177,13 +167,7 @@ -> IO Int -- ^ The value *before* the addition fetchAddIntArray (MutableByteArray mba#) (I# offset#) (I# incr#) = IO $ \ s1# -> let (# s2#, res #) = fetchAddIntArray# mba# offset# incr# s1# in--- fetchAddIntArray# changed behavior in 7.10 to return the OLD value, so we--- need this to maintain backwards compatibility:-#if MIN_VERSION_base(4,8,0) (# s2#, (I# res) #)-#else- (# s2#, (I# (res -# incr#)) #)-#endif -- | Atomically subtract to a word of memory within a `MutableByteArray`,@@ -192,12 +176,7 @@ -> Int -- ^ The offset into the array -> Int -- ^ The value to be subtracted -> IO Int -- ^ The value *before* the addition-fetchSubIntArray = doAtomicRMW-#if MIN_VERSION_base(4,8,0)- fetchSubIntArray#-#else- (-)-#endif+fetchSubIntArray = doAtomicRMW fetchSubIntArray# -- | Atomically bitwise AND to a word of memory within a `MutableByteArray`, -- returning the value *before* the operation. Implies a full memory barrier.@@ -205,12 +184,7 @@ -> Int -- ^ The offset into the array -> Int -- ^ The value to be AND-ed -> IO Int -- ^ The value *before* the addition-fetchAndIntArray = doAtomicRMW-#if MIN_VERSION_base(4,8,0)- fetchAndIntArray#-#else- (.&.)-#endif+fetchAndIntArray = doAtomicRMW fetchAndIntArray# -- | Atomically bitwise NAND to a word of memory within a `MutableByteArray`, -- returning the value *before* the operation. Implies a full memory barrier.@@ -218,13 +192,7 @@ -> Int -- ^ The offset into the array -> Int -- ^ The value to be NAND-ed -> IO Int -- ^ The value *before* the addition-fetchNandIntArray = doAtomicRMW-#if MIN_VERSION_base(4,8,0)- fetchNandIntArray#-#else- nand- where nand x y = complement (x .&. y)-#endif+fetchNandIntArray = doAtomicRMW fetchNandIntArray# -- | Atomically bitwise OR to a word of memory within a `MutableByteArray`, -- returning the value *before* the operation. Implies a full memory barrier.@@ -232,12 +200,7 @@ -> Int -- ^ The offset into the array -> Int -- ^ The value to be OR-ed -> IO Int -- ^ The value *before* the addition-fetchOrIntArray = doAtomicRMW-#if MIN_VERSION_base(4,8,0)- fetchOrIntArray#-#else- (.|.)-#endif+fetchOrIntArray = doAtomicRMW fetchOrIntArray# -- | Atomically bitwise XOR to a word of memory within a `MutableByteArray`, -- returning the value *before* the operation. Implies a full memory barrier.@@ -245,18 +208,12 @@ -> Int -- ^ The offset into the array -> Int -- ^ The value to be XOR-ed -> IO Int -- ^ The value *before* the addition-fetchXorIntArray = doAtomicRMW-#if MIN_VERSION_base(4,8,0)- fetchXorIntArray#-#else- xor-#endif+fetchXorIntArray = doAtomicRMW fetchXorIntArray# -- Internals for our fetch* family of functions, with CAS loop fallbacks for -- GHC < 7.10: {-# INLINE doAtomicRMW #-}-#if MIN_VERSION_base(4,8,0) doAtomicRMW :: (MutableByteArray# RealWorld -> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)) -- primop -> MutableByteArray RealWorld -> Int -> Int -> IO Int -- exported function doAtomicRMW atomicOp# =@@ -264,25 +221,6 @@ IO $ \ s1# -> let (# s2#, res #) = atomicOp# mba# offset# val# s1# in (# s2#, (I# res) #)-#else-doAtomicRMW :: (Int -> Int -> Int) -- fallback op for CAS loop- -> MutableByteArray RealWorld -> Int -> Int -> IO Int -- exported function-doAtomicRMW op =- \mba offset val ->- let loop = do- old <- readByteArray mba offset- let !new = old `op` val- actualOld <- casByteArrayInt mba offset old new- if old == actualOld- then return actualOld- else loop- in loop-{-# WARNING fetchSubIntArray "fetchSubIntArray is implemented with a CAS loop on GHC <7.10" #-}-{-# WARNING fetchAndIntArray "fetchAndIntArray is implemented with a CAS loop on GHC <7.10" #-}-{-# WARNING fetchNandIntArray "fetchNandIntArray is implemented with a CAS loop on GHC <7.10" #-}-{-# WARNING fetchOrIntArray "fetchOrIntArray is implemented with a CAS loop on GHC <7.10" #-}-{-# WARNING fetchXorIntArray "fetchXorIntArray is implemented with a CAS loop on GHC <7.10" #-}-#endif {-# DEPRECATED fetchAddByteArrayInt "Replaced by fetchAddIntArray which returns the OLD value" #-}@@ -294,13 +232,7 @@ fetchAddByteArrayInt :: MutableByteArray RealWorld -> Int -> Int -> IO Int fetchAddByteArrayInt (MutableByteArray mba#) (I# offset#) (I# incr#) = IO $ \ s1# -> let (# s2#, res #) = fetchAddIntArray# mba# offset# incr# s1# in--- fetchAddIntArray# changed behavior in 7.10 to return the OLD value, so we--- need this to maintain forwards compatibility until removed:-#if MIN_VERSION_base(4,8,0) (# s2#, (I# (res +# incr#)) #)-#else- (# s2#, (I# res) #)-#endif --------------------------------------------------------------------------------@@ -309,46 +241,21 @@ - - Also remember to add these to the INLINE / NOINLINE section when exported --- imports for GHC < 7.10 conditionals below.-#if MIN_VERSION_base(4,8,0)-#else-import Control.Monad (void)-import Data.Primitive.ByteArray (writeByteArray)-#endif -- | Given an array and an offset in Int units, read an element. The index is -- assumed to be in bounds. Implies a full memory barrier. atomicReadIntArray :: MutableByteArray RealWorld -> Int -> IO Int-#if MIN_VERSION_base(4,8,0) atomicReadIntArray (MutableByteArray mba#) (I# ix#) = IO $ \ s# -> case atomicReadIntArray# mba# ix# s# of (# s2#, n# #) -> (# s2#, I# n# #)-#else-atomicReadIntArray mba ix = do- -- I don't think we can get a full barrier here with the three barriers we- -- have exposed, so we use a no-op CAS, which implies a full barrier- casByteArrayInt mba ix 0 0-{-# WARNING atomicReadIntArray "atomicReadIntArray is implemented with a CAS on GHC <7.10 and may be slower than a readByteArray + one of the barriers exposed here" #-}-#endif -- | Given an array and an offset in Int units, write an element. The index is -- assumed to be in bounds. Implies a full memory barrier. atomicWriteIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO ()-#if MIN_VERSION_base(4,8,0) atomicWriteIntArray (MutableByteArray mba#) (I# ix#) (I# n#) = IO $ \ s# -> case atomicWriteIntArray# mba# ix# n# s# of s2# -> (# s2#, () #)-#else-atomicWriteIntArray mba ix n = do- -- As above we use a no-op CAS to get a full barrier. This is particularly- -- gross TODO something better if possible- let fullBarrier = void $ casByteArrayInt mba ix 0 0- fullBarrier- writeByteArray mba ix n- fullBarrier-{-# WARNING atomicWriteIntArray "atomicWriteIntArray is likely to be very slow on GHC <7.10. Consider using writeByteArray along with one of the barriers exposed here instead" #-}-#endif -} @@ -446,11 +353,33 @@ -- | Memory barrier implemented by the GHC rts (see SMP.h). -- writeBarrier :: IO () --- GHC 7.8 consistently exposes these symbols while linking:+#if __GLASGOW_HASKELL__ >= 909 -#if MIN_VERSION_base(4,7,0) && !(defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 802)-#warning "Assuming that store_load_barrier and friends are defined in the GHC RTS."+foreign import prim "hs_atomic_primops_store_load_barrier" storeLoadBarrier#+ :: State# RealWorld -> State# RealWorld +-- | A memory barrier that prevents future loads occurring before preceding+-- stores.+storeLoadBarrier :: IO ()+storeLoadBarrier = IO $ \s -> case storeLoadBarrier# s of s' -> (# s', () #)++foreign import prim "hs_atomic_primops_load_load_barrier" loadLoadBarrier#+ :: State# RealWorld -> State# RealWorld++-- | A memory barrier that prevents future loads occurring before earlier loads.+loadLoadBarrier :: IO ()+loadLoadBarrier = IO $ \s -> case loadLoadBarrier# s of s' -> (# s', () #)++foreign import prim "hs_atomic_primops_write_barrier" writeBarrier#+ :: State# RealWorld -> State# RealWorld++-- | A memory barrier that prevents future stores occurring before preceding+-- stores.+writeBarrier :: IO ()+writeBarrier = IO $ \s -> case writeBarrier# s of s' -> (# s', () #)++#elif !(defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 802)+ -- | Memory barrier implemented by the GHC rts (see SMP.h). foreign import ccall unsafe "store_load_barrier" storeLoadBarrier :: IO ()@@ -462,12 +391,10 @@ -- | Memory barrier implemented by the GHC rts (see SMP.h). foreign import ccall unsafe "write_barrier" writeBarrier :: IO ()- #else #warning "importing store_load_barrier and friends from the package's C code." --- GHC 7.6 did not consistently expose them (e.g. in the non-threaded RTS),--- so rather we grab this functionality from RtsDup.c:+-- Workaround for Trac #12846, which affects old GHCs on Windows foreign import ccall unsafe "DUP_store_load_barrier" storeLoadBarrier :: IO () @@ -477,7 +404,6 @@ foreign import ccall unsafe "DUP_write_barrier" writeBarrier :: IO () #endif- --------------------------------------------------------------------------------
Data/Atomics/Counter.hs view
@@ -33,19 +33,13 @@ import Data.Atomics.Internal-#if MIN_VERSION_base(4,7,0) import GHC.Base hiding ((==#)) import qualified GHC.PrimopWrappers as GPW-#else-import GHC.Base-#endif -- GHC 7.8 changed some primops-#if MIN_VERSION_base(4,7,0) (==#) :: Int# -> Int# -> Bool (==#) x y = case x GPW.==# y of { 0# -> False; _ -> True }-#endif @@ -137,19 +131,11 @@ incrCounter :: Int -> AtomicCounter -> IO Int incrCounter (I# incr#) (AtomicCounter mba#) = IO $ \ s1# -> let (# s2#, res #) = fetchAddIntArray# mba# 0# incr# s1# in--- fetchAddIntArray# changed behavior in 7.10 to return the OLD value, so we--- need this to maintain forwards compatibility:-#if MIN_VERSION_base(4,8,0) (# s2#, (I# (res +# incr#)) #)-#else- (# s2#, (I# res) #)-#endif {-# 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# -> - -- NOTE: either old or new behavior of fetchAddIntArray# is fine here, since- -- we don't inspect the return value: let (# s2#, _ #) = fetchAddIntArray# mba# 0# incr# s1# in (# s2#, () #)
Data/Atomics/Internal.hs view
@@ -4,32 +4,20 @@ #define CASTFUN -- | This module provides only the raw primops (and necessary types) for atomic--- operations. -module Data.Atomics.Internal +-- operations.+module Data.Atomics.Internal (- casIntArray#, fetchAddIntArray#, - readForCAS#, casMutVarTicketed#, casArrayTicketed#, + casIntArray#, fetchAddIntArray#,+ readForCAS#, casMutVarTicketed#, casArrayTicketed#, Ticket, -- * Very unsafe, not to be used ptrEq )- where --import GHC.Base (Int(I#), Any)-import GHC.Prim (RealWorld, Int#, State#, MutableArray#, MutVar#,- unsafeCoerce#, reallyUnsafePtrEquality#) + where -#if MIN_VERSION_base(4,7,0)-import GHC.Prim (casArray#, casIntArray#, fetchAddIntArray#, 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#, MutableByteArray#)-import GHC.Base (Any)-#else-#error "Need to figure out how to emulate Any () in GHC <= 7.4 !"--- import GHC.Prim (Word#)--- type Any a = Word#-#endif +import GHC.Exts (Int(I#), Any, RealWorld, Int#, State#, MutableArray#, MutVar#,+ unsafeCoerce#, reallyUnsafePtrEquality#,+ casArray#, casIntArray#, fetchAddIntArray#, readMutVar#, casMutVar#) #ifdef DEBUG_ATOMICS {-# NOINLINE readForCAS# #-}@@ -45,18 +33,12 @@ -- 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 +-- | Unsafe, machine-level atomic compare and swap on an element within an Array.+casArrayTicketed# :: MutableArray# RealWorld a -> Int# -> 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.-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- +casArrayTicketed# = unsafeCoerce# casArray#+ -- | 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@@ -98,46 +80,4 @@ 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:-casMutVarTicketed# =-#if MIN_VERSION_base(4,7,0) - unsafeCoerce# casMutVar#-#else- unsafeCoerce# casMutVar_TypeErased#-#endif------------------------------------------------------------------------------------- Type-erased versions that call the raw foreign primops:------------------------------------------------------------------------------------ Due to limitations of the "foreign import prim" mechanism, we can't use the--- 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 () #) --- out_of_line = True--- has_side_effects = True---- | This alternate version of casMutVar returns an opaque "ticket" for--- future CAS operations.-foreign import prim "stg_casMutVar2zh" casMutVar_TypeErased#- :: MutVar# RealWorld () -> Any () -> Any () ->- State# RealWorld -> (# State# RealWorld, Int#, Any () #)---- 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# ->- State# s -> (# State# s, Int# #) --foreign import prim "stg_fetchAddByteArrayIntzh" fetchAddIntArray#- :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) --#endif+casMutVarTicketed# = unsafeCoerce# casMutVar#
atomic-primops.cabal view
@@ -1,20 +1,20 @@+Cabal-version: 3.0 Name: atomic-primops-Version: 0.8.2-License: BSD3+Version: 0.8.8+License: BSD-3-Clause License-file: LICENSE Author: Ryan Newton Maintainer: rrnewton@gmail.com Category: Data -- Portability: non-portabile (x86_64) Build-type: Simple-Cabal-version: >=1.18+tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 HomePage: https://github.com/rrnewton/haskell-lockfree/wiki Bug-Reports: https://github.com/rrnewton/haskell-lockfree/issues Synopsis: A safe approach to CAS and other atomic ops in Haskell. Description:- After GHC 7.4 a new `casMutVar#` primop became available, but it's difficult to use safely, because pointer equality is a highly unstable property in Haskell. This library provides a safer method@@ -28,12 +28,13 @@ This library is engineered to work pre- and post-GHC-7.8, while exposing the same interface. -Extra-Source-Files: CHANGELOG.md, DEVLOG.md,- testing/Test.hs, testing/test-atomic-primops.cabal, testing/ghci-test.hs- testing/Makefile, testing/CommonTesting.hs, testing/Counter.hs, testing/CounterCommon.hs, testing/hello.hs, testing/Fetch.hs+Extra-Source-Files: DEVLOG.md+ testing/Test.hs testing/test-atomic-primops.cabal testing/ghci-test.hs+ testing/Makefile testing/CommonTesting.hs testing/Counter.hs testing/CounterCommon.hs testing/hello.hs testing/Fetch.hs testing/Issue28.hs testing/TemplateHaskellSplices.hs testing/Raw781_test.hs+extra-doc-files: CHANGELOG.md Flag debug Description: Enable extra internal checks.@@ -47,43 +48,21 @@ ghc-options: -O2 -funbox-strict-fields ghc-options: -Wall - -- 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.6.0.0 && < 4.12, ghc-prim, primitive-- -- TODO: Try to push support back to 7.0, but make it default to an implementation- -- other than Unboxed.+ build-depends: base >= 4.8 && < 5+ , ghc-prim+ , primitive - -- Ah, but if we don't USE casMutVar# in this package we are ok:- -- build-depends: base >= 4.3, ghc-prim, primitive+ if impl(ghc >= 9.9)+ cmm-sources: cbits/atomics.cmm - if impl(ghc < 7.7) {- Include-Dirs: cbits- C-Sources: cbits/primops.cmm- -- Duplicate RTS functionality for GHC 7.6:- C-Sources: cbits/RtsDup.c- } else {- if os(windows) {- Include-Dirs: cbits- C-Sources: cbits/RtsDup.c- }+ if os(windows) {+ Include-Dirs: cbits+ C-Sources: cbits/RtsDup.c } CC-Options: -Wall - -- if( cabal-version < 1.17 ) {- -- ghc-prof-options: ERROR_DO_NOT_BUILD_THIS_WITH_PROFILING_YET__SEE_CABAL_ISSUE_1284- -- }- if flag(debug) cpp-options: -DDEBUG_ATOMICS----- -- [2013.04.08] This isn't working presently:--- -- I'm having problems with building it along with the library; see DEVLOG.--- -- Switching to a separate package in ./testing/--- Test-Suite test-atomic-primops--- type: exitcode-stdio-1.0--- ... Source-Repository head Type: git
+ cbits/atomics.cmm view
@@ -0,0 +1,20 @@+#include "Cmm.h"++// These approximate GHC's old barrier operations in terms of the new C11-style+// ordered atomic fences.++hs_atomic_primops_store_load_barrier() {+ prim %fence_seq_cst();+ return ();+}++hs_atomic_primops_load_load_barrier() {+ prim %fence_acquire();+ return ();+}++hs_atomic_primops_write_barrier() {+ prim %fence_release();+ return ();+}+
− cbits/primops.cmm
@@ -1,128 +0,0 @@--// ============================================================-// NOTE: We only use this file for GHC < 7.8.-// ============================================================--#include "Cmm.h"--#warning "Duplicating functionality from the GHC RTS..."-#define WHICH_CAS DUP_cas-#define WHICH_SLBARRIER DUP_store_load_barrier-#define WHICH_LLBARRIER DUP_load_load_barrier-#define WHICH_WBARRIER DUP_write_barrier--// These versions are linked directly from the RTS:-/* #define WHICH_CAS cas */-/* #define WHICH_SLBARRIER store_load_barrier */-/* #define WHICH_LLBARRIER load_load_barrier */-/* #define WHICH_WBARRIER write_barrier */--// ================================================================================--add1Op-/* Int# -> Int# */-{- W_ num;- num = R1 + 1;- RET_P(num);-}---stg_casArrayzh-/* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) */-{- W_ arr, p, ind, old, new, h, len;- arr = R1; // anything else?- ind = R2;- old = R3;- new = R4;-- p = arr + SIZEOF_StgMutArrPtrs + WDS(ind);- (h) = foreign "C" WHICH_CAS(p, old, new) [];- if (h != old) {- // Failure, return what was there instead of 'old':- RET_NP(1,h);- } else {- // Compare and Swap Succeeded:- SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);- 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,new);- }-}---stg_casByteArrayIntzh-/* MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) */-{- W_ arr, p, ind, old, new, h, len;- arr = R1; - ind = R2;- old = R3;- new = R4;-- p = arr + SIZEOF_StgArrWords + WDS(ind);- (h) = foreign "C" WHICH_CAS(p, old, new) [];-- RET_N(h);-}--stg_fetchAddByteArrayIntzh-/* MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) */-{- W_ arr, p, ind, incr, h, len;- arr = R1; - ind = R2;- incr = R3;-- p = arr + SIZEOF_StgArrWords + WDS(ind);- (h) = foreign "C" atomic_inc_with(incr, p) [];-- 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- /* MutVar# s a -> Word# -> a -> State# s -> (# State#, Int#, a #) */-{- W_ mv, old, new, h, addr;- // Calling convention: Up to 8 registers contain arguments.- mv = R1;- old = R2;- new = R3;- addr = mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var;-- // The "cas" function from the C runtime abstracts over- // platform/architecture differences. It returns the old value.- (h) = foreign "C" WHICH_CAS(addr, old, new) [];- if (h != old) {- // Failure:- RET_NP(1, h);- }- else - {- // Success means a mutation and thus GC write barrier:- if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {- foreign "C" dirty_MUT_VAR(BaseReg "ptr", mv "ptr") [];- }- // Return the NEW value as the ticket for next time.- RET_NP(0,new);- }-}---// Takes a single input argument in R1:-stg_readMutVar2zh-/* MutVar# RealWorld a -> State# RealWorld -> (# State# RealWorld, Word#, a #) */-{- W_ mv, res;- mv = R1;- // Do the actual read:- res = W_[mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var];- RET_NP(res, res);-}-/* emitPrimOp [res] ReadMutVarOp [mutv] _ */-/* = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) */-
testing/Fetch.hs view
@@ -2,7 +2,6 @@ -- tests for our fetch-and-* family of functions. import Control.Monad-import Control.Applicative import System.Random import Test.Framework.Providers.HUnit (testCase) import Test.Framework (Test)
testing/Test.hs view
@@ -9,7 +9,7 @@ import Control.Monad -- import Control.Monad.ST (stToIO) import Control.Exception (evaluate)-import Data.IORef (modifyIORef')+import Data.IORef import Data.Int import Data.Primitive.Array import Data.Word@@ -18,7 +18,7 @@ import Text.Printf import GHC.Conc import GHC.STRef-import GHC.IORef+import GHC.IORef (IORef(..)) #if MIN_VERSION_base(4,10,0) import GHC.Stats (getRTSStats, RTSStats(..)) #else
testing/test-atomic-primops.cabal view
@@ -4,9 +4,10 @@ Name: test-atomic-primops Version: 0.6.0.5 Build-type: Simple-Cabal-version: >=1.8-+Cabal-version: >=1.18 -- This is generally controled by the continuous integration script at a more granular level:+tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3+ Flag opt Description: Enable GHC optimization. Default: False@@ -33,58 +34,74 @@ ghc-options: -rtsopts -with-rtsopts=-N4 -- Set it to always run with some parallelism.- build-depends: base, ghc-prim, primitive, containers, random, atomic-primops >= 0.6.0.5,+ build-depends: base >= 4.8 && < 5+ , ghc-prim+ , primitive+ , containers+ , random+ , atomic-primops >= 0.6.0.5 -- For Testing:- time, HUnit, test-framework, test-framework-hunit+ , time+ , HUnit+ , test-framework+ , test-framework-hunit -- Optional: Debugging generated code: -- ghc-options: -keep-tmp-files -dsuppress-module-prefixes -ddump-to-file -ddump-core-stats -ddump-simpl-stats -dcore-lint -dcmm-lint -- ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-asm -ddump-bcos -ddump-cmm -ddump-opt-cmm -ddump-inlinings+ default-language: Haskell2010 -- Cabal can get confused if there is no executable or library... so here's a dummy executable. -- Also it provides a good test of compile/link issues, apart from everything else. Executable hello-world-atomic-primops main-is: hello.hs- build-depends: base >= 4.5, atomic-primops+ build-depends: base >= 4.8 && < 5+ , atomic-primops+ default-language: Haskell2010 -- This is separated out, because a bug in GHC 7.6 make this fail on Linux. Test-suite template-haskell-atomic-primops type: exitcode-stdio-1.0 main-is: ghci-test.hs other-modules: TemplateHaskellSplices- if impl(ghc >= 7.8) {- Buildable: True- build-depends: base >= 4.5, atomic-primops >= 0.6.0.5, template-haskell,- -- For Testing:- test-framework, test-framework-hunit- } else {- Buildable: False- }-+ Buildable: True+ build-depends: base >= 4.8 && < 5+ , atomic-primops >= 0.6.0.5+ , template-haskell+ , test-framework+ , test-framework-hunit+ default-language: Haskell2010 -- 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+ build-depends: base >= 4.8 && < 5+ , 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- }-+ default-language: Haskell2010 Test-suite Issue28 type: exitcode-stdio-1.0- build-depends: base, ghc-prim, atomic-primops >= 0.6.0.5+ build-depends: base >= 4.8 && < 5+ , 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- -- }+ default-language: Haskell2010 Benchmark atomic-primops-MicroBench type: exitcode-stdio-1.0- build-depends: base, ghc-prim, primitive, containers, random,- atomic-primops >= 0.6.0.5,- deepseq >= 1.3,- time, HUnit, test-framework, test-framework-hunit- build-depends: criterion >= 1.2.1+ build-depends: base >= 4.8 && < 5+ , ghc-prim+ , primitive+ , containers+ , random+ , atomic-primops >= 0.6.0.5+ , deepseq >= 1.3+ , time+ , HUnit+ , test-framework+ , test-framework-hunit+ , criterion >= 1.2.1 main-is: MicroBench.hs+ default-language: Haskell2010