atomic-primops 0.8.3 → 0.8.4
raw patch · 5 files changed
+23/−191 lines, 5 filesdep ~ghc-primPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc-prim
API changes (from Hackage documentation)
Files
- CHANGELOG.md +3/−0
- Data/Atomics.hs +6/−103
- Data/Atomics/Counter.hs +0/−14
- Data/Atomics/Internal.hs +13/−73
- atomic-primops.cabal +1/−1
CHANGELOG.md view
@@ -1,3 +1,6 @@+## 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.
Data/Atomics.hs view
@@ -53,23 +53,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 +98,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 +163,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 +172,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 +180,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 +188,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 +196,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 +204,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 +217,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 +228,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 +237,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 -}
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,5 +1,5 @@ Name: atomic-primops-Version: 0.8.3+Version: 0.8.4 License: BSD3 License-file: LICENSE Author: Ryan Newton