{-# LANGUAGE CPP, TypeSynonymInstances, BangPatterns #-}
{-# LANGUAGE ForeignFunctionInterface, GHCForeignImportPrim, MagicHash, UnboxedTuples, UnliftedFFITypes #-}
#define CASTFUN
module Data.Atomics.Internal
(
casIntArray#, fetchAddIntArray#,
readForCAS#, casMutVarTicketed#, casArrayTicketed#,
Ticket,
ptrEq
)
where
import GHC.Base (Int(I#), Any)
import GHC.Prim (RealWorld, Int#, State#, MutableArray#, MutVar#,
unsafeCoerce#, reallyUnsafePtrEquality#)
#if MIN_VERSION_base(4,7,0)
import GHC.Prim (casArray#, casIntArray#, fetchAddIntArray#, readMutVar#, casMutVar#)
#elif MIN_VERSION_base(4,6,0)
import GHC.Prim (readMutVar#, MutableByteArray#)
import GHC.Base (Any)
#else
#error "Need to figure out how to emulate Any () in GHC <= 7.4 !"
#endif
#ifdef DEBUG_ATOMICS
{-# NOINLINE readForCAS# #-}
{-# NOINLINE casMutVarTicketed# #-}
{-# NOINLINE casArrayTicketed# #-}
#else
{-# INLINE casArrayTicketed# #-}
#endif
casArrayTicketed# :: MutableArray# RealWorld a -> Int# -> Ticket a -> Ticket a
-> State# RealWorld -> (# State# RealWorld, Int#, Ticket a #)
casArrayTicketed# = unsafeCoerce#
#if MIN_VERSION_base(4,7,0)
casArray#
#else
casArrayTypeErased#
#endif
newtype Ticket a = Ticket Any
instance Show (Ticket a) where
show _ = "<CAS_ticket>"
{-# NOINLINE ptrEq #-}
ptrEq :: a -> a -> Bool
ptrEq !x !y = I# (reallyUnsafePtrEquality# x y) == 1
instance Eq (Ticket a) where
(==) = ptrEq
readForCAS# :: MutVar# RealWorld a ->
State# RealWorld -> (# State# RealWorld, Ticket a #)
#ifdef CASTFUN
readForCAS# = unsafeCoerce# readMutVar#
#else
readForCAS# mv rw =
case readMutVar# mv rw of
(# rw', a #) -> (# rw', unsafeCoerce# a #)
#endif
casMutVarTicketed# :: MutVar# RealWorld a -> Ticket a -> Ticket a ->
State# RealWorld -> (# State# RealWorld, Int#, Ticket a #)
casMutVarTicketed# =
#if MIN_VERSION_base(4,7,0)
unsafeCoerce# casMutVar#
#else
unsafeCoerce# casMutVar_TypeErased#
#endif
#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 () #)
foreign import prim "stg_casMutVar2zh" casMutVar_TypeErased#
:: MutVar# RealWorld () -> Any () -> Any () ->
State# RealWorld -> (# State# RealWorld, Int#, Any () #)
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