primitive-atomic (empty) → 0.1.0.0

raw patch · 10 files changed

+428/−0 lines, 10 filesdep +basedep +primitivedep +primitive-atomicsetup-changed

Dependencies added: base, primitive, primitive-atomic

Files

• CHANGELOG.md +5/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• primitive-atomic.cabal +38/−0
• src/Data/Primitive/Array/Atomic.hs +32/−0
• src/Data/Primitive/ByteArray/Atomic.hs +112/−0
• src/Data/Primitive/Class/Atomic.hs +24/−0
• src/Data/Primitive/PrimArray/Atomic.hs +111/−0
• src/Data/Primitive/Unlifted/Atomic.hs +40/−0
• test/Unit.hs +34/−0

@@ -0,0 +1,5 @@+# Revision history for primitive-atomic++## 0.1.0.0 -- 2019-04-25++* First version.

@@ -0,0 +1,30 @@+Copyright (c) 2019, Andrew Martin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Martin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,38 @@+cabal-version: 2.2+name: primitive-atomic+version: 0.1.0.0+synopsis: Wrappers for primops around atomic operations+homepage: https://github.com/andrewthad/primitive-atomic+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2019 Andrew Martin+category: Data+build-type: Simple+extra-source-files: CHANGELOG.md++library+  exposed-modules:+    Data.Primitive.Array.Atomic+    Data.Primitive.Unlifted.Atomic+    Data.Primitive.ByteArray.Atomic+    Data.Primitive.Class.Atomic+    Data.Primitive.PrimArray.Atomic+  build-depends:+    , base >=4.11.1 && <5+    , primitive >= 0.6.4+  hs-source-dirs: src+  default-language: Haskell2010+  ghc-options: -Wall++test-suite unit+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Unit.hs+  build-depends:+    , base+    , primitive-atomic+    , primitive+  ghc-options: -Wall -O2+  default-language: Haskell2010

@@ -0,0 +1,32 @@+{-# language MagicHash #-}+{-# language UnboxedTuples #-}++module Data.Primitive.Array.Atomic+  ( casArray+  ) where++import Control.Monad.Primitive (PrimMonad,PrimState,primitive)+import Data.Primitive (MutableArray(..))+import GHC.Exts (Int(I#),casArray#,isTrue#,(==#))++-- | Given an array, an offset in Int units, the expected old value,+-- and the new value, perform an atomic compare and swap i.e. write+-- the new value if the current value matches the provided old value.+-- Returns the value of the element before the operation. Implies a+-- full memory barrier.+--+-- Note that lifted values in GHC have limited guarantees concerning+-- pointer equality. In particular, data constructor applications of+-- single-constructor data types may be mangled by GHC Core optimizations.+-- Users of this function are expected to understand how to make+-- pointer equality survive GHC's optimization passes.+casArray :: PrimMonad m+  => MutableArray (PrimState m) a -- ^ prim array+  -> Int -- ^ index+  -> a -- ^ expected old value+  -> a -- ^ new value+  -> m (Bool,a)+{-# INLINE casArray #-}+casArray (MutableArray arr#) (I# i#) old new =+  primitive $ \s0 -> case casArray# arr# i# old new s0 of+    (# s1, n, r #) -> (# s1, (isTrue# (n ==# 0# ),r) #)

@@ -0,0 +1,112 @@+{-# language MagicHash #-}+{-# language UnboxedTuples #-}++module Data.Primitive.ByteArray.Atomic+  ( casByteArray+  , fetchAddByteArray+  , fetchSubByteArray+  , fetchAndByteArray+  , fetchNandByteArray+  , fetchOrByteArray+  , fetchXorByteArray+  ) where++import Control.Monad.Primitive (PrimMonad,PrimState,primitive)+import Data.Primitive (MutableByteArray(..))+import Data.Primitive.Class.Atomic (PrimMach,primMachToInt#,primMachFromInt#)+import GHC.Exts++-- | Given an array, an offset in Int units, the expected old value, and the new value,+-- perform an atomic compare and swap i.e. write the new value if the current value matches+-- the provided old value. Returns the value of the element before the operation. Implies+-- a full memory barrier.+casByteArray :: (PrimMonad m, PrimMach a)+  => MutableByteArray (PrimState m) -- ^ array+  -> Int -- ^ index+  -> a -- ^ expected old value+  -> a -- ^ new value+  -> m a+{-# INLINE casByteArray #-}+casByteArray (MutableByteArray arr#) (I# i#) old new =+  primitive $ \s0 -> case casIntArray# arr# i# (primMachToInt# old) (primMachToInt# new) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++-- | Given an array, and offset in Int units, and a value to add, atomically+-- add the value to the element. Returns the value of the element before the+-- operation. Implies a full memory barrier.+fetchAddByteArray :: (PrimMonad m, PrimMach a)+  => MutableByteArray (PrimState m)+  -> Int -- ^ index+  -> a -- ^ value to add to the element+  -> m a+{-# INLINE fetchAddByteArray #-}+fetchAddByteArray (MutableByteArray arr#) (I# i#) val =+  primitive $ \s0 -> case fetchAddIntArray# arr# i# (primMachToInt# val) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++-- | Given an array, and offset in Int units, and a value to subtract, atomically+-- subtract the value to the element. Returns the value of the element before the+-- operation. Implies a full memory barrier.+fetchSubByteArray :: (PrimMonad m, PrimMach a)+  => MutableByteArray (PrimState m)+  -> Int -- ^ index+  -> a -- ^ value to subtract from the element+  -> m a+{-# INLINE fetchSubByteArray #-}+fetchSubByteArray (MutableByteArray arr#) (I# i#) val =+  primitive $ \s0 -> case fetchSubIntArray# arr# i# (primMachToInt# val) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++-- | Given an array, and offset in Int units, and a value to @AND@, atomically+-- @AND@ the value to the element. Returns the value of the element before the+-- operation. Implies a full memory barrier.+fetchAndByteArray :: (PrimMonad m, PrimMach a)+  => MutableByteArray (PrimState m)+  -> Int -- ^ index+  -> a -- ^ value to @AND@ with the element+  -> m a+{-# INLINE fetchAndByteArray #-}+fetchAndByteArray (MutableByteArray arr#) (I# i#) val =+  primitive $ \s0 -> case fetchAndIntArray# arr# i# (primMachToInt# val) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++-- | Given an array, and offset in Int units, and a value to @NAND@, atomically+-- @NAND@ the value to the element. Returns the value of the element before the+-- operation. Implies a full memory barrier.+fetchNandByteArray :: (PrimMonad m, PrimMach a)+  => MutableByteArray (PrimState m)+  -> Int -- ^ index+  -> a -- ^ value to @NAND@ with the element+  -> m a+{-# INLINE fetchNandByteArray #-}+fetchNandByteArray (MutableByteArray arr#) (I# i#) val =+  primitive $ \s0 -> case fetchNandIntArray# arr# i# (primMachToInt# val) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++-- | Given an array, and offset in Int units, and a value to @OR@, atomically+-- @OR@ the value to the element. Returns the value of the element before the+-- operation. Implies a full memory barrier.+fetchOrByteArray :: (PrimMonad m, PrimMach a)+  => MutableByteArray (PrimState m)+  -> Int -- ^ index+  -> a -- ^ value to @OR@ with the element+  -> m a+{-# INLINE fetchOrByteArray #-}+fetchOrByteArray (MutableByteArray arr#) (I# i#) val =+  primitive $ \s0 -> case fetchOrIntArray# arr# i# (primMachToInt# val) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++-- | Given an array, and offset in Int units, and a value to @XOR@, atomically+-- @XOR@ the value to the element. Returns the value of the element before the+-- operation. Implies a full memory barrier.+fetchXorByteArray :: (PrimMonad m, PrimMach a)+  => MutableByteArray (PrimState m)+  -> Int -- ^ index+  -> a -- ^ value to @XOR@ with the element+  -> m a+{-# INLINE fetchXorByteArray #-}+fetchXorByteArray (MutableByteArray arr#) (I# i#) val =+  primitive $ \s0 -> case fetchXorIntArray# arr# i# (primMachToInt# val) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++

@@ -0,0 +1,24 @@+{-# language MagicHash #-}+{-# language UnboxedTuples #-}++module Data.Primitive.Class.Atomic+  ( PrimMach(..)+  ) where++import Data.Primitive (Prim)+import GHC.Exts++-- | Class of types supporting primitive operations that are isomorphic to+-- a machine integer. Such types support compare-and-swap and other atomic+-- operations.+class Prim a => PrimMach a where+  primMachToInt# :: a -> Int#+  primMachFromInt# :: Int# -> a++instance PrimMach Int where+  primMachToInt# (I# i) = i+  primMachFromInt# = I#++instance PrimMach Word where+  primMachToInt# (W# i) = word2Int# i+  primMachFromInt# i = W# (int2Word# i)

@@ -0,0 +1,111 @@+{-# language MagicHash #-}+{-# language UnboxedTuples #-}++module Data.Primitive.PrimArray.Atomic+  ( casPrimArray+  , fetchAddPrimArray+  , fetchSubPrimArray+  , fetchAndPrimArray+  , fetchNandPrimArray+  , fetchOrPrimArray+  , fetchXorPrimArray+  ) where++import Control.Monad.Primitive (PrimMonad,PrimState,primitive)+import Data.Primitive (MutablePrimArray(..))+import Data.Primitive.Class.Atomic (PrimMach,primMachToInt#,primMachFromInt#)+import GHC.Exts++-- | Given an array, an offset in Int units, the expected old value, and the new value,+-- perform an atomic compare and swap i.e. write the new value if the current value matches+-- the provided old value. Returns the value of the element before the operation. Implies+-- a full memory barrier.+casPrimArray :: (PrimMonad m, PrimMach a)+  => MutablePrimArray (PrimState m) a -- ^ prim array+  -> Int -- ^ index+  -> a -- ^ expected old value+  -> a -- ^ new value+  -> m a+{-# INLINE casPrimArray #-}+casPrimArray (MutablePrimArray arr#) (I# i#) old new =+  primitive $ \s0 -> case casIntArray# arr# i# (primMachToInt# old) (primMachToInt# new) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++-- | Given an array, and offset in Int units, and a value to add, atomically+-- add the value to the element. Returns the value of the element before the+-- operation. Implies a full memory barrier.+fetchAddPrimArray :: (PrimMonad m, PrimMach a)+  => MutablePrimArray (PrimState m) a+  -> Int -- ^ index+  -> a -- ^ value to add to the element+  -> m a+{-# INLINE fetchAddPrimArray #-}+fetchAddPrimArray (MutablePrimArray arr#) (I# i#) val =+  primitive $ \s0 -> case fetchAddIntArray# arr# i# (primMachToInt# val) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++-- | Given an array, and offset in Int units, and a value to subtract, atomically+-- subtract the value to the element. Returns the value of the element before the+-- operation. Implies a full memory barrier.+fetchSubPrimArray :: (PrimMonad m, PrimMach a)+  => MutablePrimArray (PrimState m) a+  -> Int -- ^ index+  -> a -- ^ value to subtract from the element+  -> m a+{-# INLINE fetchSubPrimArray #-}+fetchSubPrimArray (MutablePrimArray arr#) (I# i#) val =+  primitive $ \s0 -> case fetchSubIntArray# arr# i# (primMachToInt# val) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++-- | Given an array, and offset in Int units, and a value to @AND@, atomically+-- @AND@ the value to the element. Returns the value of the element before the+-- operation. Implies a full memory barrier.+fetchAndPrimArray :: (PrimMonad m, PrimMach a)+  => MutablePrimArray (PrimState m) a+  -> Int -- ^ index+  -> a -- ^ value to @AND@ with the element+  -> m a+{-# INLINE fetchAndPrimArray #-}+fetchAndPrimArray (MutablePrimArray arr#) (I# i#) val =+  primitive $ \s0 -> case fetchAndIntArray# arr# i# (primMachToInt# val) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++-- | Given an array, and offset in Int units, and a value to @NAND@, atomically+-- @NAND@ the value to the element. Returns the value of the element before the+-- operation. Implies a full memory barrier.+fetchNandPrimArray :: (PrimMonad m, PrimMach a)+  => MutablePrimArray (PrimState m) a+  -> Int -- ^ index+  -> a -- ^ value to @NAND@ with the element+  -> m a+{-# INLINE fetchNandPrimArray #-}+fetchNandPrimArray (MutablePrimArray arr#) (I# i#) val =+  primitive $ \s0 -> case fetchNandIntArray# arr# i# (primMachToInt# val) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++-- | Given an array, and offset in Int units, and a value to @OR@, atomically+-- @OR@ the value to the element. Returns the value of the element before the+-- operation. Implies a full memory barrier.+fetchOrPrimArray :: (PrimMonad m, PrimMach a)+  => MutablePrimArray (PrimState m) a+  -> Int -- ^ index+  -> a -- ^ value to @OR@ with the element+  -> m a+{-# INLINE fetchOrPrimArray #-}+fetchOrPrimArray (MutablePrimArray arr#) (I# i#) val =+  primitive $ \s0 -> case fetchOrIntArray# arr# i# (primMachToInt# val) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)++-- | Given an array, and offset in Int units, and a value to @XOR@, atomically+-- @XOR@ the value to the element. Returns the value of the element before the+-- operation. Implies a full memory barrier.+fetchXorPrimArray :: (PrimMonad m, PrimMach a)+  => MutablePrimArray (PrimState m) a+  -> Int -- ^ index+  -> a -- ^ value to @XOR@ with the element+  -> m a+{-# INLINE fetchXorPrimArray #-}+fetchXorPrimArray (MutablePrimArray arr#) (I# i#) val =+  primitive $ \s0 -> case fetchXorIntArray# arr# i# (primMachToInt# val) s0 of+    (# s1, r #) -> (# s1, primMachFromInt# r #)+

@@ -0,0 +1,40 @@+{-# language BangPatterns #-}+{-# language MagicHash #-}+{-# language UnboxedTuples #-}+{-# language ScopedTypeVariables #-}++module Data.Primitive.Unlifted.Atomic+  ( casUnliftedArray+  ) where++import Control.Monad.Primitive (PrimMonad,PrimState,primitive)+import Data.Primitive (MutableUnliftedArray(..),PrimUnlifted)+import Data.Primitive (toArrayArray#,fromArrayArray#)+import GHC.Exts (Any,MutableArrayArray#,MutableArray#,ArrayArray#,Int(I#))+import GHC.Exts (casArray#,isTrue#,(==#),unsafeCoerce#)++-- | Given an array, an offset, the expected old value,+-- and the new value, perform an atomic compare and swap i.e. write+-- the new value if the current value matches the provided old value.+-- Returns the value of the element before the operation. Implies a+-- full memory barrier.+--+-- Some unlifted types, in particular the ones that correspond to mutable+-- resources, have good guarantees about pointer equality. With these+-- types, this function is much easier to reason about than @casArray@.+casUnliftedArray :: forall m a. (PrimMonad m, PrimUnlifted a)+  => MutableUnliftedArray (PrimState m) a -- ^ prim array+  -> Int -- ^ index+  -> a -- ^ expected old value+  -> a -- ^ new value+  -> m (Bool,a)+{-# INLINE casUnliftedArray #-}+casUnliftedArray (MutableUnliftedArray arr#) (I# i#) old new =+  -- All of this unsafeCoercing is really nasty business. This will go away+  -- once https://github.com/ghc-proposals/ghc-proposals/pull/203 happens.+  primitive $ \s0 ->+    let !uold = (unsafeCoerce# :: ArrayArray# -> Any) (toArrayArray# old)+        !unew = (unsafeCoerce# :: ArrayArray# -> Any) (toArrayArray# new)+     in case casArray# ((unsafeCoerce# :: MutableArrayArray# (PrimState m) -> MutableArray# (PrimState m) Any) arr#) i# uold unew s0 of+          (# s1, n, ur #) -> (# s1, (isTrue# (n ==# 0# ),fromArrayArray# ((unsafeCoerce# :: Any -> ArrayArray#) ur)) #)+

@@ -0,0 +1,34 @@+{-# language MultiWayIf #-}++import Data.Primitive.Unlifted.Atomic+import Data.Primitive+import Control.Monad (when)++main :: IO ()+main = do+  putStrLn "Start"+  putStrLn "A"+  testA+  putStrLn "Finished"++testA :: IO ()+testA = do+  arr <- newUnliftedArray 20 =<< newByteArray 16+  x <- newByteArray 24+  y <- newByteArray 32+  z <- newByteArray 40+  writeUnliftedArray arr 0 x+  writeUnliftedArray arr 1 y+  writeUnliftedArray arr 2 z+  (success0,old0) <- casUnliftedArray arr 1 z x+  when (not (sameMutableByteArray old0 y)) $ do+    fail "old0 /= y"+  when (success0 == True) $ do+    fail "success0 == True"+  (success1,old1) <- casUnliftedArray arr 0 x z+  if | sameMutableByteArray old1 z -> pure ()+     | sameMutableByteArray old1 y -> fail "old1 == y"+     | sameMutableByteArray old1 x -> fail "old1 == x"+     | otherwise -> fail "old1 /= z"+  when (success1 == False) $ do+    fail "success1 == False"