bits-atomic (empty) → 0.1.0
raw patch · 7 files changed
+1367/−0 lines, 7 filesdep +HUnitdep +QuickCheckdep +basebuild-type:Customsetup-changed
Dependencies added: HUnit, QuickCheck, base, test-framework, test-framework-hunit, test-framework-quickcheck2
Files
- Data/Bits/Atomic.hs +730/−0
- License.txt +26/−0
- Setup.hs +12/−0
- bits-atomic.cabal +64/−0
- cbits/atomic-bitops-gcc.c +278/−0
- cbits/atomic-bitops-gcc.h +105/−0
- test/test.hs +152/−0
+ Data/Bits/Atomic.hs view
@@ -0,0 +1,730 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-- | Atomic bit operations, using GCC's built-in atomic operations in small C+-- wrapper functions called through the FFI. See+-- <http://gcc.gnu.org/onlinedocs/gcc-4.5.0/gcc/Atomic-Builtins.html> or the+-- version corresponding to your compiler for more detail.+module Data.Bits.Atomic (+ -- * Atomic bit operations on 'Word'-sized memory locations+ AtomicBits(..),+ -- * Utility+ memoryBarrier+) where+import Data.Bits+import Data.Word+import Data.Int+import Foreign.Ptr++-- | Atomic bit operations on a memory location. +--+-- Instances: 'Word', 'Word8', 'Word16', 'Word32', 'Word64', 'Int', 'Int8',+-- 'Int16', 'Int32', 'Int64'.+class Bits x => AtomicBits x where+ -- | Atomic @(+)@, returning the original value.+ fetchAndAdd :: Ptr x -> x -> IO x+ -- | Atomic @(-)@, returning the originial value.+ fetchAndSub :: Ptr x -> x -> IO x+ -- | Atomic @(.|.)@, returning the original value.+ fetchAndOr :: Ptr x -> x -> IO x+ -- | Atomic @(.&.)@, returning the original value.+ fetchAndAnd :: Ptr x -> x -> IO x+ -- | Atomic @xor@, returning the original value.+ fetchAndXor :: Ptr x -> x -> IO x+ -- | Atomic @nand@, returning the original value.+ fetchAndNand :: Ptr x -> x -> IO x+ -- | Atomic @(+)@, returning the updated value.+ addAndFetch :: Ptr x -> x -> IO x+ -- | Atomic @(-)@, returning the updated value.+ subAndFetch :: Ptr x -> x -> IO x+ -- | Atomic @(.|.)@, returning the updated value.+ orAndFetch :: Ptr x -> x -> IO x+ -- | Atomic @(.&.)@, returning the updated value.+ andAndFetch :: Ptr x -> x -> IO x+ -- | Atomic @xor@, returning the updated value.+ xorAndFetch :: Ptr x -> x -> IO x+ -- | Atomic @nand@, returning the updated value.+ nandAndFetch :: Ptr x -> x -> IO x+ -- | Atomic @CAS@ with boolean return.+ compareAndSwapBool :: Ptr x -- ^ The memory location to update+ -> x -- ^ Old value+ -> x -- ^ Intended new value+ -> IO Bool -- ^ 'True' if swapped, 'False' otherwise++ -- | Atomic @CAS@, returning the original value.+ compareAndSwap :: Ptr x -- ^ The memory location to update+ -> x -- ^ Old value+ -> x -- ^ Intended new value+ -> IO x -- ^ Original value++ -- | Atomically update the memory location with the value 1 and return the+ -- original value, 0 in case 'lockRelease' was previously called or @1@ if+ -- another call to 'lockTestAndSet' aquired the lock earlier. Implies an+ -- /aquire barrier/.+ lockTestAndSet :: Ptr x -> IO x+ -- | Release the lock by writing a @0@. Includes a /release barrier/.+ lockRelease :: Ptr x -> IO ()+++-- | A full memory barrier.+foreign import ccall unsafe "atomic-bitops-gcc.h mem_barrier"+ memoryBarrier :: IO ()++foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_add_8"+ fetch_and_add_8 :: Ptr Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_sub_8"+ fetch_and_sub_8 :: Ptr Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_or_8"+ fetch_and_or_8 :: Ptr Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_and_8"+ fetch_and_and_8 :: Ptr Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_xor_8"+ fetch_and_xor_8 :: Ptr Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_nand_8"+ fetch_and_nand_8 :: Ptr Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h add_and_fetch_8"+ add_and_fetch_8 :: Ptr Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h sub_and_fetch_8"+ sub_and_fetch_8 :: Ptr Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h or_and_fetch_8"+ or_and_fetch_8 :: Ptr Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h and_and_fetch_8"+ and_and_fetch_8 :: Ptr Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h xor_and_fetch_8"+ xor_and_fetch_8 :: Ptr Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h nand_and_fetch_8"+ nand_and_fetch_8 :: Ptr Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h bool_compare_and_swap_8"+ bool_compare_and_swap_8 :: Ptr Word8 -> Word8 -> Word8 -> IO Bool+foreign import ccall unsafe "atomic-bitops-gcc.h val_compare_and_swap_8"+ val_compare_and_swap_8 :: Ptr Word8 -> Word8 -> Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h lock_test_and_set_8"+ lock_test_and_set_8 :: Ptr Word8 -> IO Word8+foreign import ccall unsafe "atomic-bitops-gcc.h lock_release_8"+ lock_release_8 :: Ptr Word8 -> IO ()++instance AtomicBits Word8 where+ fetchAndAdd = fetch_and_add_8+ {-# INLINE fetchAndAdd #-}+ fetchAndSub = fetch_and_sub_8+ {-# INLINE fetchAndSub #-}+ fetchAndOr = fetch_and_or_8+ {-# INLINE fetchAndOr #-}+ fetchAndAnd = fetch_and_and_8+ {-# INLINE fetchAndAnd #-}+ fetchAndXor = fetch_and_xor_8+ {-# INLINE fetchAndXor #-}+ fetchAndNand = fetch_and_nand_8+ {-# INLINE fetchAndNand #-}+ addAndFetch = add_and_fetch_8+ {-# INLINE addAndFetch #-}+ subAndFetch = sub_and_fetch_8+ {-# INLINE subAndFetch #-}+ orAndFetch = or_and_fetch_8+ {-# INLINE orAndFetch #-}+ andAndFetch = and_and_fetch_8+ {-# INLINE andAndFetch #-}+ xorAndFetch = xor_and_fetch_8+ {-# INLINE xorAndFetch #-}+ nandAndFetch = nand_and_fetch_8+ {-# INLINE nandAndFetch #-}+ compareAndSwapBool = bool_compare_and_swap_8+ {-# INLINE compareAndSwapBool #-}+ compareAndSwap = val_compare_and_swap_8+ {-# INLINE compareAndSwap #-}+ lockTestAndSet = lock_test_and_set_8+ {-# INLINE lockTestAndSet #-}+ lockRelease = lock_release_8+ {-# INLINE lockRelease #-}+ +foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_add_16"+ fetch_and_add_16 :: Ptr Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_sub_16"+ fetch_and_sub_16 :: Ptr Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_or_16"+ fetch_and_or_16 :: Ptr Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_and_16"+ fetch_and_and_16 :: Ptr Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_xor_16"+ fetch_and_xor_16 :: Ptr Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_nand_16"+ fetch_and_nand_16 :: Ptr Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h add_and_fetch_16"+ add_and_fetch_16 :: Ptr Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h sub_and_fetch_16"+ sub_and_fetch_16 :: Ptr Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h or_and_fetch_16"+ or_and_fetch_16 :: Ptr Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h and_and_fetch_16"+ and_and_fetch_16 :: Ptr Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h xor_and_fetch_16"+ xor_and_fetch_16 :: Ptr Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h nand_and_fetch_16"+ nand_and_fetch_16 :: Ptr Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h bool_compare_and_swap_16"+ bool_compare_and_swap_16 :: Ptr Word16 -> Word16 -> Word16 -> IO Bool+foreign import ccall unsafe "atomic-bitops-gcc.h val_compare_and_swap_16"+ val_compare_and_swap_16 :: Ptr Word16 -> Word16 -> Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h lock_test_and_set_16"+ lock_test_and_set_16 :: Ptr Word16 -> IO Word16+foreign import ccall unsafe "atomic-bitops-gcc.h lock_release_16"+ lock_release_16 :: Ptr Word16 -> IO ()++instance AtomicBits Word16 where+ fetchAndAdd = fetch_and_add_16+ {-# INLINE fetchAndAdd #-}+ fetchAndSub = fetch_and_sub_16+ {-# INLINE fetchAndSub #-}+ fetchAndOr = fetch_and_or_16+ {-# INLINE fetchAndOr #-}+ fetchAndAnd = fetch_and_and_16+ {-# INLINE fetchAndAnd #-}+ fetchAndXor = fetch_and_xor_16+ {-# INLINE fetchAndXor #-}+ fetchAndNand = fetch_and_nand_16+ {-# INLINE fetchAndNand #-}+ addAndFetch = add_and_fetch_16+ {-# INLINE addAndFetch #-}+ subAndFetch = sub_and_fetch_16+ {-# INLINE subAndFetch #-}+ orAndFetch = or_and_fetch_16+ {-# INLINE orAndFetch #-}+ andAndFetch = and_and_fetch_16+ {-# INLINE andAndFetch #-}+ xorAndFetch = xor_and_fetch_16+ {-# INLINE xorAndFetch #-}+ nandAndFetch = nand_and_fetch_16+ {-# INLINE nandAndFetch #-}+ compareAndSwapBool = bool_compare_and_swap_16+ {-# INLINE compareAndSwapBool #-}+ compareAndSwap = val_compare_and_swap_16+ {-# INLINE compareAndSwap #-}+ lockTestAndSet = lock_test_and_set_16+ {-# INLINE lockTestAndSet #-}+ lockRelease = lock_release_16+ {-# INLINE lockRelease #-}+ +foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_add_32"+ fetch_and_add_32 :: Ptr Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_sub_32"+ fetch_and_sub_32 :: Ptr Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_or_32"+ fetch_and_or_32 :: Ptr Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_and_32"+ fetch_and_and_32 :: Ptr Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_xor_32"+ fetch_and_xor_32 :: Ptr Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_nand_32"+ fetch_and_nand_32 :: Ptr Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h add_and_fetch_32"+ add_and_fetch_32 :: Ptr Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h sub_and_fetch_32"+ sub_and_fetch_32 :: Ptr Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h or_and_fetch_32"+ or_and_fetch_32 :: Ptr Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h and_and_fetch_32"+ and_and_fetch_32 :: Ptr Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h xor_and_fetch_32"+ xor_and_fetch_32 :: Ptr Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h nand_and_fetch_32"+ nand_and_fetch_32 :: Ptr Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h bool_compare_and_swap_32"+ bool_compare_and_swap_32 :: Ptr Word32 -> Word32 -> Word32 -> IO Bool+foreign import ccall unsafe "atomic-bitops-gcc.h val_compare_and_swap_32"+ val_compare_and_swap_32 :: Ptr Word32 -> Word32 -> Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h lock_test_and_set_32"+ lock_test_and_set_32 :: Ptr Word32 -> IO Word32+foreign import ccall unsafe "atomic-bitops-gcc.h lock_release_32"+ lock_release_32 :: Ptr Word32 -> IO ()++instance AtomicBits Word32 where+ fetchAndAdd = fetch_and_add_32+ {-# INLINE fetchAndAdd #-}+ fetchAndSub = fetch_and_sub_32+ {-# INLINE fetchAndSub #-}+ fetchAndOr = fetch_and_or_32+ {-# INLINE fetchAndOr #-}+ fetchAndAnd = fetch_and_and_32+ {-# INLINE fetchAndAnd #-}+ fetchAndXor = fetch_and_xor_32+ {-# INLINE fetchAndXor #-}+ fetchAndNand = fetch_and_nand_32+ {-# INLINE fetchAndNand #-}+ addAndFetch = add_and_fetch_32+ {-# INLINE addAndFetch #-}+ subAndFetch = sub_and_fetch_32+ {-# INLINE subAndFetch #-}+ orAndFetch = or_and_fetch_32+ {-# INLINE orAndFetch #-}+ andAndFetch = and_and_fetch_32+ {-# INLINE andAndFetch #-}+ xorAndFetch = xor_and_fetch_32+ {-# INLINE xorAndFetch #-}+ nandAndFetch = nand_and_fetch_32+ {-# INLINE nandAndFetch #-}+ compareAndSwapBool = bool_compare_and_swap_32+ {-# INLINE compareAndSwapBool #-}+ compareAndSwap = val_compare_and_swap_32+ {-# INLINE compareAndSwap #-}+ lockTestAndSet = lock_test_and_set_32+ {-# INLINE lockTestAndSet #-}+ lockRelease = lock_release_32+ {-# INLINE lockRelease #-}+ +foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_add_64"+ fetch_and_add_64 :: Ptr Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_sub_64"+ fetch_and_sub_64 :: Ptr Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_or_64"+ fetch_and_or_64 :: Ptr Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_and_64"+ fetch_and_and_64 :: Ptr Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_xor_64"+ fetch_and_xor_64 :: Ptr Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_nand_64"+ fetch_and_nand_64 :: Ptr Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h add_and_fetch_64"+ add_and_fetch_64 :: Ptr Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h sub_and_fetch_64"+ sub_and_fetch_64 :: Ptr Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h or_and_fetch_64"+ or_and_fetch_64 :: Ptr Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h and_and_fetch_64"+ and_and_fetch_64 :: Ptr Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h xor_and_fetch_64"+ xor_and_fetch_64 :: Ptr Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h nand_and_fetch_64"+ nand_and_fetch_64 :: Ptr Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h bool_compare_and_swap_64"+ bool_compare_and_swap_64 :: Ptr Word64 -> Word64 -> Word64 -> IO Bool+foreign import ccall unsafe "atomic-bitops-gcc.h val_compare_and_swap_64"+ val_compare_and_swap_64 :: Ptr Word64 -> Word64 -> Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h lock_test_and_set_64"+ lock_test_and_set_64 :: Ptr Word64 -> IO Word64+foreign import ccall unsafe "atomic-bitops-gcc.h lock_release_64"+ lock_release_64 :: Ptr Word64 -> IO ()++instance AtomicBits Word64 where+ fetchAndAdd = fetch_and_add_64+ {-# INLINE fetchAndAdd #-}+ fetchAndSub = fetch_and_sub_64+ {-# INLINE fetchAndSub #-}+ fetchAndOr = fetch_and_or_64+ {-# INLINE fetchAndOr #-}+ fetchAndAnd = fetch_and_and_64+ {-# INLINE fetchAndAnd #-}+ fetchAndXor = fetch_and_xor_64+ {-# INLINE fetchAndXor #-}+ fetchAndNand = fetch_and_nand_64+ {-# INLINE fetchAndNand #-}+ addAndFetch = add_and_fetch_64+ {-# INLINE addAndFetch #-}+ subAndFetch = sub_and_fetch_64+ {-# INLINE subAndFetch #-}+ orAndFetch = or_and_fetch_64+ {-# INLINE orAndFetch #-}+ andAndFetch = and_and_fetch_64+ {-# INLINE andAndFetch #-}+ xorAndFetch = xor_and_fetch_64+ {-# INLINE xorAndFetch #-}+ nandAndFetch = nand_and_fetch_64+ {-# INLINE nandAndFetch #-}+ compareAndSwapBool = bool_compare_and_swap_64+ {-# INLINE compareAndSwapBool #-}+ compareAndSwap = val_compare_and_swap_64+ {-# INLINE compareAndSwap #-}+ lockTestAndSet = lock_test_and_set_64+ {-# INLINE lockTestAndSet #-}+ lockRelease = lock_release_64+ {-# INLINE lockRelease #-}+ +foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_add_word"+ fetch_and_add_word :: Ptr Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_sub_word"+ fetch_and_sub_word :: Ptr Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_or_word"+ fetch_and_or_word :: Ptr Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_and_word"+ fetch_and_and_word :: Ptr Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_xor_word"+ fetch_and_xor_word :: Ptr Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h fetch_and_nand_word"+ fetch_and_nand_word :: Ptr Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h add_and_fetch_word"+ add_and_fetch_word :: Ptr Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h sub_and_fetch_word"+ sub_and_fetch_word :: Ptr Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h or_and_fetch_word"+ or_and_fetch_word :: Ptr Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h and_and_fetch_word"+ and_and_fetch_word :: Ptr Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h xor_and_fetch_word"+ xor_and_fetch_word :: Ptr Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h nand_and_fetch_word"+ nand_and_fetch_word :: Ptr Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h bool_compare_and_swap_word"+ bool_compare_and_swap_word :: Ptr Word -> Word -> Word -> IO Bool+foreign import ccall unsafe "atomic-bitops-gcc.h val_compare_and_swap_word"+ val_compare_and_swap_word :: Ptr Word -> Word -> Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h lock_test_and_set_word"+ lock_test_and_set_word :: Ptr Word -> IO Word+foreign import ccall unsafe "atomic-bitops-gcc.h lock_release_word"+ lock_release_word :: Ptr Word -> IO ()++instance AtomicBits Word where+ fetchAndAdd = fetch_and_add_word+ {-# INLINE fetchAndAdd #-}+ fetchAndSub = fetch_and_sub_word+ {-# INLINE fetchAndSub #-}+ fetchAndOr = fetch_and_or_word+ {-# INLINE fetchAndOr #-}+ fetchAndAnd = fetch_and_and_word+ {-# INLINE fetchAndAnd #-}+ fetchAndXor = fetch_and_xor_word+ {-# INLINE fetchAndXor #-}+ fetchAndNand = fetch_and_nand_word+ {-# INLINE fetchAndNand #-}+ addAndFetch = add_and_fetch_word+ {-# INLINE addAndFetch #-}+ subAndFetch = sub_and_fetch_word+ {-# INLINE subAndFetch #-}+ orAndFetch = or_and_fetch_word+ {-# INLINE orAndFetch #-}+ andAndFetch = and_and_fetch_word+ {-# INLINE andAndFetch #-}+ xorAndFetch = xor_and_fetch_word+ {-# INLINE xorAndFetch #-}+ nandAndFetch = nand_and_fetch_word+ {-# INLINE nandAndFetch #-}+ compareAndSwapBool = bool_compare_and_swap_word+ {-# INLINE compareAndSwapBool #-}+ compareAndSwap = val_compare_and_swap_word+ {-# INLINE compareAndSwap #-}+ lockTestAndSet = lock_test_and_set_word+ {-# INLINE lockTestAndSet #-}+ lockRelease = lock_release_word+ {-# INLINE lockRelease #-}+++instance AtomicBits Int where+ fetchAndAdd p v = fmap fromIntegral $ fetch_and_add_word + (castPtr p :: Ptr Word)+ (fromIntegral v)+ {-# INLINE fetchAndAdd #-}+ fetchAndSub p v = fmap fromIntegral $ fetch_and_sub_word+ (castPtr p :: Ptr Word)+ (fromIntegral v)+ {-# INLINE fetchAndSub #-}+ fetchAndOr p v = fmap fromIntegral $ fetch_and_or_word+ (castPtr p :: Ptr Word)+ (fromIntegral v)+ {-# INLINE fetchAndOr #-}+ fetchAndAnd p v = fmap fromIntegral $ fetch_and_and_word+ (castPtr p :: Ptr Word)+ (fromIntegral v)+ {-# INLINE fetchAndAnd #-}+ fetchAndXor p v = fmap fromIntegral $ fetch_and_xor_word+ (castPtr p :: Ptr Word)+ (fromIntegral v)+ {-# INLINE fetchAndXor #-}+ fetchAndNand p v = fmap fromIntegral $ fetch_and_nand_word+ (castPtr p :: Ptr Word)+ (fromIntegral v)+ {-# INLINE fetchAndNand #-}+ addAndFetch p v = fmap fromIntegral $ add_and_fetch_word+ (castPtr p :: Ptr Word)+ (fromIntegral v)+ {-# INLINE addAndFetch #-}+ subAndFetch p v = fmap fromIntegral $ sub_and_fetch_word+ (castPtr p :: Ptr Word)+ (fromIntegral v)+ {-# INLINE subAndFetch #-}+ orAndFetch p v = fmap fromIntegral $ or_and_fetch_word+ (castPtr p :: Ptr Word)+ (fromIntegral v)+ {-# INLINE orAndFetch #-}+ andAndFetch p v = fmap fromIntegral $ and_and_fetch_word+ (castPtr p :: Ptr Word)+ (fromIntegral v)+ {-# INLINE andAndFetch #-}+ xorAndFetch p v = fmap fromIntegral $ xor_and_fetch_word+ (castPtr p :: Ptr Word)+ (fromIntegral v)+ {-# INLINE xorAndFetch #-}+ nandAndFetch p v = fmap fromIntegral $ nand_and_fetch_word+ (castPtr p :: Ptr Word)+ (fromIntegral v)+ {-# INLINE nandAndFetch #-}+ compareAndSwapBool p o n = bool_compare_and_swap_word+ (castPtr p :: Ptr Word)+ (fromIntegral o)+ (fromIntegral n)+ {-# INLINE compareAndSwapBool #-}+ compareAndSwap p o n = fmap fromIntegral $ val_compare_and_swap_word+ (castPtr p :: Ptr Word)+ (fromIntegral o)+ (fromIntegral n)+ {-# INLINE compareAndSwap #-}+ lockTestAndSet p = fmap fromIntegral $ lock_test_and_set_word + (castPtr p :: Ptr Word)+ {-# INLINE lockTestAndSet #-}+ lockRelease p = lock_release_word (castPtr p :: Ptr Word)+ {-# INLINE lockRelease #-}++instance AtomicBits Int8 where+ fetchAndAdd p v = fmap fromIntegral $ fetch_and_add_8 + (castPtr p :: Ptr Word8)+ (fromIntegral v)+ {-# INLINE fetchAndAdd #-}+ fetchAndSub p v = fmap fromIntegral $ fetch_and_sub_8+ (castPtr p :: Ptr Word8)+ (fromIntegral v)+ {-# INLINE fetchAndSub #-}+ fetchAndOr p v = fmap fromIntegral $ fetch_and_or_8+ (castPtr p :: Ptr Word8)+ (fromIntegral v)+ {-# INLINE fetchAndOr #-}+ fetchAndAnd p v = fmap fromIntegral $ fetch_and_and_8+ (castPtr p :: Ptr Word8)+ (fromIntegral v)+ {-# INLINE fetchAndAnd #-}+ fetchAndXor p v = fmap fromIntegral $ fetch_and_xor_8+ (castPtr p :: Ptr Word8)+ (fromIntegral v)+ {-# INLINE fetchAndXor #-}+ fetchAndNand p v = fmap fromIntegral $ fetch_and_nand_8+ (castPtr p :: Ptr Word8)+ (fromIntegral v)+ {-# INLINE fetchAndNand #-}+ addAndFetch p v = fmap fromIntegral $ add_and_fetch_8+ (castPtr p :: Ptr Word8)+ (fromIntegral v)+ {-# INLINE addAndFetch #-}+ subAndFetch p v = fmap fromIntegral $ sub_and_fetch_8+ (castPtr p :: Ptr Word8)+ (fromIntegral v)+ {-# INLINE subAndFetch #-}+ orAndFetch p v = fmap fromIntegral $ or_and_fetch_8+ (castPtr p :: Ptr Word8)+ (fromIntegral v)+ {-# INLINE orAndFetch #-}+ andAndFetch p v = fmap fromIntegral $ and_and_fetch_8+ (castPtr p :: Ptr Word8)+ (fromIntegral v)+ {-# INLINE andAndFetch #-}+ xorAndFetch p v = fmap fromIntegral $ xor_and_fetch_8+ (castPtr p :: Ptr Word8)+ (fromIntegral v)+ {-# INLINE xorAndFetch #-}+ nandAndFetch p v = fmap fromIntegral $ nand_and_fetch_8+ (castPtr p :: Ptr Word8)+ (fromIntegral v)+ {-# INLINE nandAndFetch #-}+ compareAndSwapBool p o n = bool_compare_and_swap_8+ (castPtr p :: Ptr Word8)+ (fromIntegral o)+ (fromIntegral n)+ {-# INLINE compareAndSwapBool #-}+ compareAndSwap p o n = fmap fromIntegral $ val_compare_and_swap_8+ (castPtr p :: Ptr Word8)+ (fromIntegral o)+ (fromIntegral n)+ {-# INLINE compareAndSwap #-}+ lockTestAndSet p = fmap fromIntegral $ lock_test_and_set_8 + (castPtr p :: Ptr Word8)+ {-# INLINE lockTestAndSet #-}+ lockRelease p = lock_release_8 (castPtr p :: Ptr Word8)+ {-# INLINE lockRelease #-}++instance AtomicBits Int16 where+ fetchAndAdd p v = fmap fromIntegral $ fetch_and_add_16 + (castPtr p :: Ptr Word16)+ (fromIntegral v)+ {-# INLINE fetchAndAdd #-}+ fetchAndSub p v = fmap fromIntegral $ fetch_and_sub_16+ (castPtr p :: Ptr Word16)+ (fromIntegral v)+ {-# INLINE fetchAndSub #-}+ fetchAndOr p v = fmap fromIntegral $ fetch_and_or_16+ (castPtr p :: Ptr Word16)+ (fromIntegral v)+ {-# INLINE fetchAndOr #-}+ fetchAndAnd p v = fmap fromIntegral $ fetch_and_and_16+ (castPtr p :: Ptr Word16)+ (fromIntegral v)+ {-# INLINE fetchAndAnd #-}+ fetchAndXor p v = fmap fromIntegral $ fetch_and_xor_16+ (castPtr p :: Ptr Word16)+ (fromIntegral v)+ {-# INLINE fetchAndXor #-}+ fetchAndNand p v = fmap fromIntegral $ fetch_and_nand_16+ (castPtr p :: Ptr Word16)+ (fromIntegral v)+ {-# INLINE fetchAndNand #-}+ addAndFetch p v = fmap fromIntegral $ add_and_fetch_16+ (castPtr p :: Ptr Word16)+ (fromIntegral v)+ {-# INLINE addAndFetch #-}+ subAndFetch p v = fmap fromIntegral $ sub_and_fetch_16+ (castPtr p :: Ptr Word16)+ (fromIntegral v)+ {-# INLINE subAndFetch #-}+ orAndFetch p v = fmap fromIntegral $ or_and_fetch_16+ (castPtr p :: Ptr Word16)+ (fromIntegral v)+ {-# INLINE orAndFetch #-}+ andAndFetch p v = fmap fromIntegral $ and_and_fetch_16+ (castPtr p :: Ptr Word16)+ (fromIntegral v)+ {-# INLINE andAndFetch #-}+ xorAndFetch p v = fmap fromIntegral $ xor_and_fetch_16+ (castPtr p :: Ptr Word16)+ (fromIntegral v)+ {-# INLINE xorAndFetch #-}+ nandAndFetch p v = fmap fromIntegral $ nand_and_fetch_16+ (castPtr p :: Ptr Word16)+ (fromIntegral v)+ {-# INLINE nandAndFetch #-}+ compareAndSwapBool p o n = bool_compare_and_swap_16+ (castPtr p :: Ptr Word16)+ (fromIntegral o)+ (fromIntegral n)+ {-# INLINE compareAndSwapBool #-}+ compareAndSwap p o n = fmap fromIntegral $ val_compare_and_swap_16+ (castPtr p :: Ptr Word16)+ (fromIntegral o)+ (fromIntegral n)+ {-# INLINE compareAndSwap #-}+ lockTestAndSet p = fmap fromIntegral $ lock_test_and_set_16 + (castPtr p :: Ptr Word16)+ {-# INLINE lockTestAndSet #-}+ lockRelease p = lock_release_16 (castPtr p :: Ptr Word16)+ {-# INLINE lockRelease #-}++instance AtomicBits Int32 where+ fetchAndAdd p v = fmap fromIntegral $ fetch_and_add_32 + (castPtr p :: Ptr Word32)+ (fromIntegral v)+ {-# INLINE fetchAndAdd #-}+ fetchAndSub p v = fmap fromIntegral $ fetch_and_sub_32+ (castPtr p :: Ptr Word32)+ (fromIntegral v)+ {-# INLINE fetchAndSub #-}+ fetchAndOr p v = fmap fromIntegral $ fetch_and_or_32+ (castPtr p :: Ptr Word32)+ (fromIntegral v)+ {-# INLINE fetchAndOr #-}+ fetchAndAnd p v = fmap fromIntegral $ fetch_and_and_32+ (castPtr p :: Ptr Word32)+ (fromIntegral v)+ {-# INLINE fetchAndAnd #-}+ fetchAndXor p v = fmap fromIntegral $ fetch_and_xor_32+ (castPtr p :: Ptr Word32)+ (fromIntegral v)+ {-# INLINE fetchAndXor #-}+ fetchAndNand p v = fmap fromIntegral $ fetch_and_nand_32+ (castPtr p :: Ptr Word32)+ (fromIntegral v)+ {-# INLINE fetchAndNand #-}+ addAndFetch p v = fmap fromIntegral $ add_and_fetch_32+ (castPtr p :: Ptr Word32)+ (fromIntegral v)+ {-# INLINE addAndFetch #-}+ subAndFetch p v = fmap fromIntegral $ sub_and_fetch_32+ (castPtr p :: Ptr Word32)+ (fromIntegral v)+ {-# INLINE subAndFetch #-}+ orAndFetch p v = fmap fromIntegral $ or_and_fetch_32+ (castPtr p :: Ptr Word32)+ (fromIntegral v)+ {-# INLINE orAndFetch #-}+ andAndFetch p v = fmap fromIntegral $ and_and_fetch_32+ (castPtr p :: Ptr Word32)+ (fromIntegral v)+ {-# INLINE andAndFetch #-}+ xorAndFetch p v = fmap fromIntegral $ xor_and_fetch_32+ (castPtr p :: Ptr Word32)+ (fromIntegral v)+ {-# INLINE xorAndFetch #-}+ nandAndFetch p v = fmap fromIntegral $ nand_and_fetch_32+ (castPtr p :: Ptr Word32)+ (fromIntegral v)+ {-# INLINE nandAndFetch #-}+ compareAndSwapBool p o n = bool_compare_and_swap_32+ (castPtr p :: Ptr Word32)+ (fromIntegral o)+ (fromIntegral n)+ {-# INLINE compareAndSwapBool #-}+ compareAndSwap p o n = fmap fromIntegral $ val_compare_and_swap_32+ (castPtr p :: Ptr Word32)+ (fromIntegral o)+ (fromIntegral n)+ {-# INLINE compareAndSwap #-}+ lockTestAndSet p = fmap fromIntegral $ lock_test_and_set_32 + (castPtr p :: Ptr Word32)+ {-# INLINE lockTestAndSet #-}+ lockRelease p = lock_release_32 (castPtr p :: Ptr Word32)+ {-# INLINE lockRelease #-}++instance AtomicBits Int64 where+ fetchAndAdd p v = fmap fromIntegral $ fetch_and_add_64 + (castPtr p :: Ptr Word64)+ (fromIntegral v)+ {-# INLINE fetchAndAdd #-}+ fetchAndSub p v = fmap fromIntegral $ fetch_and_sub_64+ (castPtr p :: Ptr Word64)+ (fromIntegral v)+ {-# INLINE fetchAndSub #-}+ fetchAndOr p v = fmap fromIntegral $ fetch_and_or_64+ (castPtr p :: Ptr Word64)+ (fromIntegral v)+ {-# INLINE fetchAndOr #-}+ fetchAndAnd p v = fmap fromIntegral $ fetch_and_and_64+ (castPtr p :: Ptr Word64)+ (fromIntegral v)+ {-# INLINE fetchAndAnd #-}+ fetchAndXor p v = fmap fromIntegral $ fetch_and_xor_64+ (castPtr p :: Ptr Word64)+ (fromIntegral v)+ {-# INLINE fetchAndXor #-}+ fetchAndNand p v = fmap fromIntegral $ fetch_and_nand_64+ (castPtr p :: Ptr Word64)+ (fromIntegral v)+ {-# INLINE fetchAndNand #-}+ addAndFetch p v = fmap fromIntegral $ add_and_fetch_64+ (castPtr p :: Ptr Word64)+ (fromIntegral v)+ {-# INLINE addAndFetch #-}+ subAndFetch p v = fmap fromIntegral $ sub_and_fetch_64+ (castPtr p :: Ptr Word64)+ (fromIntegral v)+ {-# INLINE subAndFetch #-}+ orAndFetch p v = fmap fromIntegral $ or_and_fetch_64+ (castPtr p :: Ptr Word64)+ (fromIntegral v)+ {-# INLINE orAndFetch #-}+ andAndFetch p v = fmap fromIntegral $ and_and_fetch_64+ (castPtr p :: Ptr Word64)+ (fromIntegral v)+ {-# INLINE andAndFetch #-}+ xorAndFetch p v = fmap fromIntegral $ xor_and_fetch_64+ (castPtr p :: Ptr Word64)+ (fromIntegral v)+ {-# INLINE xorAndFetch #-}+ nandAndFetch p v = fmap fromIntegral $ nand_and_fetch_64+ (castPtr p :: Ptr Word64)+ (fromIntegral v)+ {-# INLINE nandAndFetch #-}+ compareAndSwapBool p o n = bool_compare_and_swap_64+ (castPtr p :: Ptr Word64)+ (fromIntegral o)+ (fromIntegral n)+ {-# INLINE compareAndSwapBool #-}+ compareAndSwap p o n = fmap fromIntegral $ val_compare_and_swap_64+ (castPtr p :: Ptr Word64)+ (fromIntegral o)+ (fromIntegral n)+ {-# INLINE compareAndSwap #-}+ lockTestAndSet p = fmap fromIntegral $ lock_test_and_set_64 + (castPtr p :: Ptr Word64)+ {-# INLINE lockTestAndSet #-}+ lockRelease p = lock_release_64 (castPtr p :: Ptr Word64)+ {-# INLINE lockRelease #-}
+ License.txt view
@@ -0,0 +1,26 @@+Copyright (c) The Regents of the University of California.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the University nor the names of its contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 REGENTS 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.
+ Setup.hs view
@@ -0,0 +1,12 @@+import Distribution.Simple+import Distribution.PackageDescription+import Distribution.Simple.LocalBuildInfo(LocalBuildInfo, buildDir)+import System.Cmd(system)+import System.FilePath++main = defaultMainWithHooks hooks+ where hooks = simpleUserHooks { runTests = runTests' }++runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()+runTests' _ _ _ lbi = system testprog >> return ()+ where testprog = (buildDir lbi) </> "test" </> "test"
+ bits-atomic.cabal view
@@ -0,0 +1,64 @@+Name: bits-atomic+Version: 0.1.0+License: BSD3+License-File: License.txt+Maintainer: Gabriel Wicke <wicke@wikidev.net>+Author: Gabriel Wicke <wicke@wikidev.net>+Synopsis: Atomic bit operations on memory locations + for low-level synchronization+Description: + Atomic operations including CAS (compare-and-swap), lock and fetch & add+ suitable for low-level shared-memory synchronization.+ .+ The implementation is using GCC's builtin atomic operations in C wrappers+ called through the FFI.+ .+ /Testing:/ The following commands can be used to compile and run the test suite:+ .+ > cabal unpack bits-atomic && cd bits-atomic-* # if not yet locally available+ > cabal configure -ftest+ > cabal build+ > cabal test+Category: Data, Concurrency, Foreign+Stability: experimental+Build-Type: Custom+Cabal-Version: >= 1.6+Extra-Source-Files: cbits/atomic-bitops-gcc.c cbits/atomic-bitops-gcc.h+Source-Repository head+ type: mercurial+ location: http://dev.wikidev.net/hg/bits-atomic/++library+ Exposed-Modules: Data.Bits.Atomic+ Build-Depends: base >= 4 && < 6+ GHC-Options: -Wall -O2 -funbox-strict-fields+ GHC-Prof-Options: -auto-all+ C-Sources: cbits/atomic-bitops-gcc.c+ CC-Options: -Wall+ if os (linux)+ CC-Options: -fomit-frame-pointer -march=native+ Include-Dirs: cbits+ Install-Includes: atomic-bitops-gcc.h+ -- Try link-time optimization (inlining) with gcc 4.5:+ -- CC-Options: -fomit-frame-pointer -march=native -Wall -flto+ --LD-Options: -flto++flag test+ description: Build test program.+ default: False++Executable test+ if !flag(test)+ buildable: False+ hs-source-dirs: ., test+ other-modules: Data.Bits.Atomic+ main-is: test.hs+ GHC-Options: -O2 -funbox-strict-fields -threaded+ GHC-Prof-Options: -auto-all++ Include-Dirs: cbits+ C-Sources: cbits/atomic-bitops-gcc.c+ build-depends: base >= 4 && < 6, QuickCheck, HUnit,+ test-framework-quickcheck2,+ test-framework-hunit,+ test-framework
+ cbits/atomic-bitops-gcc.c view
@@ -0,0 +1,278 @@+#include "atomic-bitops-gcc.h"++void mem_barrier (void) {return __sync_synchronize ();}++/* 8-bit */+inline unsigned char fetch_and_add_8 (unsigned char *p, unsigned char v) {+ return __sync_fetch_and_add (p, v);+}+inline unsigned char fetch_and_sub_8 (unsigned char *p, unsigned char v) {+ return __sync_fetch_and_sub (p, v);+}+inline unsigned char fetch_and_or_8 (unsigned char *p, unsigned char v) {+ return __sync_fetch_and_or (p, v);+}+inline unsigned char fetch_and_and_8 (unsigned char *p, unsigned char v) {+ return __sync_fetch_and_and (p, v);+}+inline unsigned char fetch_and_xor_8 (unsigned char *p, unsigned char v) {+ return __sync_fetch_and_xor (p, v);+}+inline unsigned char fetch_and_nand_8 (unsigned char *p, unsigned char v) {+ return __sync_fetch_and_nand (p, v);+}+inline unsigned char add_and_fetch_8 (unsigned char *p, unsigned char v) {+ return __sync_add_and_fetch (p, v);+}+inline unsigned char sub_and_fetch_8 (unsigned char *p, unsigned char v) {+ return __sync_sub_and_fetch (p, v);+}+inline unsigned char or_and_fetch_8 (unsigned char *p, unsigned char v) {+ return __sync_or_and_fetch (p, v);+}+inline unsigned char and_and_fetch_8 (unsigned char *p, unsigned char v) {+ return __sync_and_and_fetch (p, v);+}+inline unsigned char xor_and_fetch_8 (unsigned char *p, unsigned char v) {+ return __sync_xor_and_fetch (p, v);+}+inline unsigned char nand_and_fetch_8 (unsigned char *p, unsigned char v) {+ return __sync_nand_and_fetch (p, v);+}+inline unsigned int+bool_compare_and_swap_8 (unsigned char *p, unsigned char old, unsigned char new) {+ return __sync_bool_compare_and_swap (p, old, new);+}+inline unsigned char+val_compare_and_swap_8 (unsigned char *p, unsigned char old, unsigned char new) {+ return __sync_val_compare_and_swap (p, old, new);+}+inline unsigned char lock_test_and_set_8 (unsigned char *p) {+ // Only immediate 0/1 appear to be widely supported, so hardcode it+ // here+ return __sync_lock_test_and_set (p, 1);+}+void lock_release_8 (unsigned char *p) {+ // Writes a 0 to *p+ return __sync_lock_release (p);+}++/* 16-bit */+inline unsigned short fetch_and_add_16 (unsigned short *p, unsigned short v) {+ return __sync_fetch_and_add (p, v);+}+inline unsigned short fetch_and_sub_16 (unsigned short *p, unsigned short v) {+ return __sync_fetch_and_sub (p, v);+}+inline unsigned short fetch_and_or_16 (unsigned short *p, unsigned short v) {+ return __sync_fetch_and_or (p, v);+}+inline unsigned short fetch_and_and_16 (unsigned short *p, unsigned short v) {+ return __sync_fetch_and_and (p, v);+}+inline unsigned short fetch_and_xor_16 (unsigned short *p, unsigned short v) {+ return __sync_fetch_and_xor (p, v);+}+inline unsigned short fetch_and_nand_16 (unsigned short *p, unsigned short v) {+ return __sync_fetch_and_nand (p, v);+}+inline unsigned short add_and_fetch_16 (unsigned short *p, unsigned short v) {+ return __sync_add_and_fetch (p, v);+}+inline unsigned short sub_and_fetch_16 (unsigned short *p, unsigned short v) {+ return __sync_sub_and_fetch (p, v);+}+inline unsigned short or_and_fetch_16 (unsigned short *p, unsigned short v) {+ return __sync_or_and_fetch (p, v);+}+inline unsigned short and_and_fetch_16 (unsigned short *p, unsigned short v) {+ return __sync_and_and_fetch (p, v);+}+inline unsigned short xor_and_fetch_16 (unsigned short *p, unsigned short v) {+ return __sync_xor_and_fetch (p, v);+}+inline unsigned short nand_and_fetch_16 (unsigned short *p, unsigned short v) {+ return __sync_nand_and_fetch (p, v);+}+inline unsigned int+bool_compare_and_swap_16 (unsigned short *p, unsigned short old, unsigned short new) {+ return __sync_bool_compare_and_swap (p, old, new);+}+inline unsigned short+val_compare_and_swap_16 (unsigned short *p, unsigned short old, unsigned short new) {+ return __sync_val_compare_and_swap (p, old, new);+}+inline unsigned short lock_test_and_set_16 (unsigned short *p) {+ // Only immediate 0/1 appear to be widely supported, so hardcode it+ // here+ return __sync_lock_test_and_set (p, 1);+}+void lock_release_16 (unsigned short *p) {+ // Writes a 0 to *p+ return __sync_lock_release (p);+}++/* 32-bit */+inline unsigned int fetch_and_add_32 (unsigned int *p, unsigned int v) {+ return __sync_fetch_and_add (p, v);+}+inline unsigned int fetch_and_sub_32 (unsigned int *p, unsigned int v) {+ return __sync_fetch_and_sub (p, v);+}+inline unsigned int fetch_and_or_32 (unsigned int *p, unsigned int v) {+ return __sync_fetch_and_or (p, v);+}+inline unsigned int fetch_and_and_32 (unsigned int *p, unsigned int v) {+ return __sync_fetch_and_and (p, v);+}+inline unsigned int fetch_and_xor_32 (unsigned int *p, unsigned int v) {+ return __sync_fetch_and_xor (p, v);+}+inline unsigned int fetch_and_nand_32 (unsigned int *p, unsigned int v) {+ return __sync_fetch_and_nand (p, v);+}+inline unsigned int add_and_fetch_32 (unsigned int *p, unsigned int v) {+ return __sync_add_and_fetch (p, v);+}+inline unsigned int sub_and_fetch_32 (unsigned int *p, unsigned int v) {+ return __sync_sub_and_fetch (p, v);+}+inline unsigned int or_and_fetch_32 (unsigned int *p, unsigned int v) {+ return __sync_or_and_fetch (p, v);+}+inline unsigned int and_and_fetch_32 (unsigned int *p, unsigned int v) {+ return __sync_and_and_fetch (p, v);+}+inline unsigned int xor_and_fetch_32 (unsigned int *p, unsigned int v) {+ return __sync_xor_and_fetch (p, v);+}+inline unsigned int nand_and_fetch_32 (unsigned int *p, unsigned int v) {+ return __sync_nand_and_fetch (p, v);+}+inline unsigned int+bool_compare_and_swap_32 (unsigned int *p, unsigned int old, unsigned int new) {+ return __sync_bool_compare_and_swap (p, old, new);+}+inline unsigned int+val_compare_and_swap_32 (unsigned int *p, unsigned int old, unsigned int new) {+ return __sync_val_compare_and_swap (p, old, new);+}+inline unsigned int lock_test_and_set_32 (unsigned int *p) {+ // Only immediate 0/1 appear to be widely supported, so hardcode it+ // here+ return __sync_lock_test_and_set (p, 1);+}+void lock_release_32 (unsigned int *p) {+ // Writes a 0 to *p+ return __sync_lock_release (p);+}++/* 64-bit */+inline unsigned long long fetch_and_add_64 (unsigned long long *p, unsigned long long v) {+ return __sync_fetch_and_add (p, v);+}+inline unsigned long long fetch_and_sub_64 (unsigned long long *p, unsigned long long v) {+ return __sync_fetch_and_sub (p, v);+}+inline unsigned long long fetch_and_or_64 (unsigned long long *p, unsigned long long v) {+ return __sync_fetch_and_or (p, v);+}+inline unsigned long long fetch_and_and_64 (unsigned long long *p, unsigned long long v) {+ return __sync_fetch_and_and (p, v);+}+inline unsigned long long fetch_and_xor_64 (unsigned long long *p, unsigned long long v) {+ return __sync_fetch_and_xor (p, v);+}+inline unsigned long long fetch_and_nand_64 (unsigned long long *p, unsigned long long v) {+ return __sync_fetch_and_nand (p, v);+}+inline unsigned long long add_and_fetch_64 (unsigned long long *p, unsigned long long v) {+ return __sync_add_and_fetch (p, v);+}+inline unsigned long long sub_and_fetch_64 (unsigned long long *p, unsigned long long v) {+ return __sync_sub_and_fetch (p, v);+}+inline unsigned long long or_and_fetch_64 (unsigned long long *p, unsigned long long v) {+ return __sync_or_and_fetch (p, v);+}+inline unsigned long long and_and_fetch_64 (unsigned long long *p, unsigned long long v) {+ return __sync_and_and_fetch (p, v);+}+inline unsigned long long xor_and_fetch_64 (unsigned long long *p, unsigned long long v) {+ return __sync_xor_and_fetch (p, v);+}+inline unsigned long long nand_and_fetch_64 (unsigned long long *p, unsigned long long v) {+ return __sync_nand_and_fetch (p, v);+}+inline unsigned int+bool_compare_and_swap_64 (unsigned long long *p, unsigned long long old, unsigned long long new) {+ return __sync_bool_compare_and_swap (p, old, new);+}+inline unsigned long long+val_compare_and_swap_64 (unsigned long long *p, unsigned long long old, unsigned long long new) {+ return __sync_val_compare_and_swap (p, old, new);+}+inline unsigned long long lock_test_and_set_64 (unsigned long long *p) {+ // Only immediate 0/1 appear to be widely supported, so hardcode it+ // here+ return __sync_lock_test_and_set (p, 1);+}+void lock_release_64 (unsigned long long *p) {+ // Writes a 0 to *p+ return __sync_lock_release (p);+}++/* Word-sized */+inline unsigned long fetch_and_add_word (unsigned long *p, unsigned long v) {+ return __sync_fetch_and_add (p, v);+}+inline unsigned long fetch_and_sub_word (unsigned long *p, unsigned long v) {+ return __sync_fetch_and_sub (p, v);+}+inline unsigned long fetch_and_or_word (unsigned long *p, unsigned long v) {+ return __sync_fetch_and_or (p, v);+}+inline unsigned long fetch_and_and_word (unsigned long *p, unsigned long v) {+ return __sync_fetch_and_and (p, v);+}+inline unsigned long fetch_and_xor_word (unsigned long *p, unsigned long v) {+ return __sync_fetch_and_xor (p, v);+}+inline unsigned long fetch_and_nand_word (unsigned long *p, unsigned long v) {+ return __sync_fetch_and_nand (p, v);+}+inline unsigned long add_and_fetch_word (unsigned long *p, unsigned long v) {+ return __sync_add_and_fetch (p, v);+}+inline unsigned long sub_and_fetch_word (unsigned long *p, unsigned long v) {+ return __sync_sub_and_fetch (p, v);+}+inline unsigned long or_and_fetch_word (unsigned long *p, unsigned long v) {+ return __sync_or_and_fetch (p, v);+}+inline unsigned long and_and_fetch_word (unsigned long *p, unsigned long v) {+ return __sync_and_and_fetch (p, v);+}+inline unsigned long xor_and_fetch_word (unsigned long *p, unsigned long v) {+ return __sync_xor_and_fetch (p, v);+}+inline unsigned long nand_and_fetch_word (unsigned long *p, unsigned long v) {+ return __sync_nand_and_fetch (p, v);+}+inline unsigned int+bool_compare_and_swap_word (unsigned long *p, unsigned long old, unsigned long new) {+ return __sync_bool_compare_and_swap (p, old, new);+}+inline unsigned long+val_compare_and_swap_word (unsigned long *p, unsigned long old, unsigned long new) {+ return __sync_val_compare_and_swap (p, old, new);+}+inline unsigned long lock_test_and_set_word (unsigned long *p) {+ // Only immediate 0/1 appear to be widely supported, so hardcode it+ // here+ return __sync_lock_test_and_set (p, 1);+}+void lock_release_word (unsigned long *p) {+ // Writes a 0 to *p+ return __sync_lock_release (p);+}
+ cbits/atomic-bitops-gcc.h view
@@ -0,0 +1,105 @@+// GCC atomic builtins, see http://gcc.gnu.org/onlinedocs/gcc-4.5.0/gcc/Atomic-Builtins.html++/* No size */+void mem_barrier (void);++/* 8-bit */+inline unsigned char fetch_and_add_8 (unsigned char *, unsigned char );+inline unsigned char fetch_and_sub_8 (unsigned char *, unsigned char );+inline unsigned char fetch_and_or_8 (unsigned char *, unsigned char );+inline unsigned char fetch_and_and_8 (unsigned char *, unsigned char );+inline unsigned char fetch_and_xor_8 (unsigned char *, unsigned char );+inline unsigned char fetch_and_nand_8 (unsigned char *, unsigned char );+inline unsigned char add_and_fetch_8 (unsigned char *, unsigned char );+inline unsigned char sub_and_fetch_8 (unsigned char *, unsigned char );+inline unsigned char or_and_fetch_8 (unsigned char *, unsigned char );+inline unsigned char and_and_fetch_8 (unsigned char *, unsigned char );+inline unsigned char xor_and_fetch_8 (unsigned char *, unsigned char );+inline unsigned char nand_and_fetch_8 (unsigned char *, unsigned char );+inline unsigned int+bool_compare_and_swap_8 (unsigned char *, unsigned char, unsigned char);+inline unsigned char+val_compare_and_swap_8 (unsigned char *, unsigned char , unsigned char);+inline unsigned char lock_test_and_set_8 (unsigned char *);+void lock_release_8 (unsigned char *);++/* 16-bit */+inline unsigned short fetch_and_add_16 (unsigned short *, unsigned short );+inline unsigned short fetch_and_sub_16 (unsigned short *, unsigned short );+inline unsigned short fetch_and_or_16 (unsigned short *, unsigned short );+inline unsigned short fetch_and_and_16 (unsigned short *, unsigned short );+inline unsigned short fetch_and_xor_16 (unsigned short *, unsigned short );+inline unsigned short fetch_and_nand_16 (unsigned short *, unsigned short );+inline unsigned short add_and_fetch_16 (unsigned short *, unsigned short );+inline unsigned short sub_and_fetch_16 (unsigned short *, unsigned short );+inline unsigned short or_and_fetch_16 (unsigned short *, unsigned short );+inline unsigned short and_and_fetch_16 (unsigned short *, unsigned short );+inline unsigned short xor_and_fetch_16 (unsigned short *, unsigned short );+inline unsigned short nand_and_fetch_16 (unsigned short *, unsigned short );+inline unsigned int+bool_compare_and_swap_16 (unsigned short *, unsigned short , unsigned short );+inline unsigned short+val_compare_and_swap_16 (unsigned short *, unsigned short , unsigned short );+inline unsigned short lock_test_and_set_16 (unsigned short *);+void lock_release_16 (unsigned short *);+++/* 32-bit */+inline unsigned int fetch_and_add_32 (unsigned int *, unsigned int );+inline unsigned int fetch_and_sub_32 (unsigned int *, unsigned int );+inline unsigned int fetch_and_or_32 (unsigned int *, unsigned int );+inline unsigned int fetch_and_and_32 (unsigned int *, unsigned int );+inline unsigned int fetch_and_xor_32 (unsigned int *, unsigned int );+inline unsigned int fetch_and_nand_32 (unsigned int *, unsigned int );+inline unsigned int add_and_fetch_32 (unsigned int *, unsigned int );+inline unsigned int sub_and_fetch_32 (unsigned int *, unsigned int );+inline unsigned int or_and_fetch_32 (unsigned int *, unsigned int );+inline unsigned int and_and_fetch_32 (unsigned int *, unsigned int );+inline unsigned int xor_and_fetch_32 (unsigned int *, unsigned int );+inline unsigned int nand_and_fetch_32 (unsigned int *, unsigned int );+inline unsigned int+bool_compare_and_swap_32 (unsigned int *, unsigned int , unsigned int );+inline unsigned int+val_compare_and_swap_32 (unsigned int *, unsigned int , unsigned int );+inline unsigned int lock_test_and_set_32 (unsigned int *);+void lock_release_32 (unsigned int *);++/* 64-bit */+inline unsigned long long fetch_and_add_64 (unsigned long long *, unsigned long long );+inline unsigned long long fetch_and_sub_64 (unsigned long long *, unsigned long long );+inline unsigned long long fetch_and_or_64 (unsigned long long *, unsigned long long );+inline unsigned long long fetch_and_and_64 (unsigned long long *, unsigned long long );+inline unsigned long long fetch_and_xor_64 (unsigned long long *, unsigned long long );+inline unsigned long long fetch_and_nand_64 (unsigned long long *, unsigned long long );+inline unsigned long long add_and_fetch_64 (unsigned long long *, unsigned long long );+inline unsigned long long sub_and_fetch_64 (unsigned long long *, unsigned long long );+inline unsigned long long or_and_fetch_64 (unsigned long long *, unsigned long long );+inline unsigned long long and_and_fetch_64 (unsigned long long *, unsigned long long );+inline unsigned long long xor_and_fetch_64 (unsigned long long *, unsigned long long );+inline unsigned long long nand_and_fetch_64 (unsigned long long *, unsigned long long );+inline unsigned int+bool_compare_and_swap_64 (unsigned long long *, unsigned long long , unsigned long long );+inline unsigned long long+val_compare_and_swap_64 (unsigned long long *, unsigned long long , unsigned long long );+inline unsigned long long lock_test_and_set_64 (unsigned long long *);+void lock_release_64 (unsigned long long *);++/* Word */+inline unsigned long fetch_and_add_word (unsigned long *, unsigned long );+inline unsigned long fetch_and_sub_word (unsigned long *, unsigned long );+inline unsigned long fetch_and_or_word (unsigned long *, unsigned long );+inline unsigned long fetch_and_and_word (unsigned long *, unsigned long );+inline unsigned long fetch_and_xor_word (unsigned long *, unsigned long );+inline unsigned long fetch_and_nand_word (unsigned long *, unsigned long );+inline unsigned long add_and_fetch_word (unsigned long *, unsigned long );+inline unsigned long sub_and_fetch_word (unsigned long *, unsigned long );+inline unsigned long or_and_fetch_word (unsigned long *, unsigned long );+inline unsigned long and_and_fetch_word (unsigned long *, unsigned long );+inline unsigned long xor_and_fetch_word (unsigned long *, unsigned long );+inline unsigned long nand_and_fetch_word (unsigned long *, unsigned long );+inline unsigned int+bool_compare_and_swap_word (unsigned long *, unsigned long , unsigned long );+inline unsigned long+val_compare_and_swap_word (unsigned long *, unsigned long , unsigned long );+inline unsigned long lock_test_and_set_word (unsigned long *);+void lock_release_word (unsigned long *);
+ test/test.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE ForeignFunctionInterface, RankNTypes, FlexibleContexts #-}+-- Test framework imports+import Test.Framework (defaultMain, testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test, Testable)+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++-- Code to test+import Data.Bits.Atomic+import Foreign.Marshal.Alloc+import Foreign.Storable+import Data.Word+import Data.Int+import Data.Bits++tests :: [Test]+tests = [ testGroup "Test Cases" + [ testCase "compareAndSwap" test_compareAndSwap_all+ , testCase "compareAndSwapBool" test_compareAndSwapBool_all+ , testCase "lockTestAndSet and lockRelease" test_lockTestRelease_all+ , testCase "fetchAndAdd" test_fetchAndAdd_all+ , testCase "fetchAndSub" test_fetchAndSub_all+ , testCase "fetchAndXor" test_fetchAndXor_all+ , testCase "subAndFetch" test_subAndFetch_all+ ]+ ]++main :: IO ()+main = defaultMain tests++testPattern :: Integral a => a+testPattern = 0xdeadbeef++type PolyTest = (AtomicBits a, Storable a, Integral a, Bounded a) => a -> Assertion++testTypes :: PolyTest -> Assertion+testTypes _test = do+ _test (1 :: Int)+ _test (1 :: Word)+ _test (1 :: Int8)+ _test (1 :: Int16)+ _test (1 :: Int32)+ _test (1 :: Int64)+ _test (1 :: Word8)+ _test (1 :: Word16)+ _test (1 :: Word32)+ _test (1 :: Word64)++test_compareAndSwap :: (AtomicBits a, Storable a, Integral a, Bounded a) => + a -> Assertion+test_compareAndSwap i = alloca $ \p -> do+ poke p i+ old1 <- compareAndSwap p i 2+ old1 @?= i+ old2 <- compareAndSwap p 3 3+ old2 @?= 2+ new <- peek p+ new @?= 2+ old3 <- compareAndSwap p 2 3+ old3 @?= 2+test_compareAndSwap_all :: Assertion+test_compareAndSwap_all = testTypes test_compareAndSwap++test_compareAndSwapBool :: (AtomicBits a, Storable a, Integral a, Bounded a) => + a -> Assertion+test_compareAndSwapBool i = alloca $ \p -> do+ poke p i+ swap0 <- compareAndSwapBool p i 2+ swap0 @?= True+ swap1 <- compareAndSwapBool p 3 3+ swap1 @?= False+ new <- peek p+ new @?= 2+ swap2 <- compareAndSwapBool p 2 3+ swap2 @?= True+test_compareAndSwapBool_all :: Assertion+test_compareAndSwapBool_all = testTypes test_compareAndSwapBool++test_fetchAndAdd :: (AtomicBits a, Storable a, Integral a, Bounded a) => + a -> Assertion+test_fetchAndAdd i = alloca $ \p -> do+ poke p i+ old0 <- fetchAndAdd p 1+ old0 @?= i+ new <- peek p+ new @?= i + 1+ poke p (maxBound `asTypeOf` i)+ old1 <- fetchAndAdd p 1+ old1 @?= (maxBound `asTypeOf` i)+ new1 <- peek p+ new1 @?= (minBound `asTypeOf` i)++test_fetchAndAdd_all :: Assertion+test_fetchAndAdd_all = testTypes test_fetchAndAdd+++test_fetchAndSub :: (AtomicBits a, Storable a, Integral a, Bounded a) => + a -> Assertion+test_fetchAndSub i = alloca $ \p -> do+ poke p i+ old0 <- fetchAndSub p 1+ old0 @?= i+ new <- peek p+ new @?= i - 1+ poke p (minBound `asTypeOf` i)+ old1 <- fetchAndSub p 1+ old1 @?= (minBound `asTypeOf` i)+ new1 <- peek p+ new1 @?= (maxBound `asTypeOf` i)+test_fetchAndSub_all :: Assertion+test_fetchAndSub_all = testTypes test_fetchAndSub+++test_fetchAndXor :: (AtomicBits a, Storable a, Integral a, Bounded a) => + a -> Assertion+test_fetchAndXor i = alloca $ \p -> do+ poke p i+ old0 <- fetchAndXor p 1+ old0 @?= i+ new <- peek p+ new @?= i `xor` 1+test_fetchAndXor_all :: Assertion+test_fetchAndXor_all = testTypes test_fetchAndXor+++test_subAndFetch :: (AtomicBits a, Storable a, Integral a, Bounded a) => + a -> Assertion+test_subAndFetch i = alloca $ \p -> do+ poke p i+ new0 <- subAndFetch p 1+ new0 @?= i - 1+ poke p (minBound `asTypeOf` i)+ new1 <- subAndFetch p 1+ new1 @?= (maxBound `asTypeOf` i)++test_subAndFetch_all :: Assertion+test_subAndFetch_all = testTypes test_subAndFetch++test_lockTestRelease :: (AtomicBits a, Storable a, Integral a, Bounded a) => + a -> Assertion+test_lockTestRelease i = alloca $ \p -> do+ poke p i+ new0 <- lockTestAndSet p+ new0 @?= i+ new1 <- peek p+ new1 @?= 1+ lockRelease p+ new2 <- peek p+ new2 @?= 0+test_lockTestRelease_all :: Assertion+test_lockTestRelease_all = testTypes test_lockTestRelease