{-# 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.
--
--   Pointer equality need not be maintained by a Haskell compiler.  For example, Int
--   values will frequently be boxed and unboxed, changing the pointer identity of
--   the thunk.  To deal with this, the compare-and-swap (CAS) approach used in this
--   module is uses a /sealed/ representation of pointers into the Haskell heap
--   (`Tickets`).  Currently, the user cannot coin new tickets, rather a `Ticket`
--   provides evidence of a past observation, and grants permission to make a future
--   change.
module Data.Atomics
 (
   -- * Types for atomic operations
   Ticket, peekTicket, -- CASResult(..),

   -- * Atomic operations on IORefs
   readForCAS, casIORef, casIORef2,
   atomicModifyIORefCAS, atomicModifyIORefCAS_,

   -- * Atomic operations on mutable arrays
   casArrayElem, casArrayElem2, readArrayElem,

   -- * Atomic operations on byte arrays
   casByteArrayInt,
   fetchAddIntArray,
   fetchSubIntArray,
   fetchAndIntArray,
   fetchNandIntArray,
   fetchOrIntArray,
   fetchXorIntArray,
   -- -- ** Reading and writing with barriers
   -- atomicReadIntArray,
   -- atomicWriteIntArray,

   -- * Atomic operations on raw MutVars
   -- | A lower-level version of the IORef interface.
   readMutVarForCAS, casMutVar, casMutVar2,

   -- * Memory barriers
   storeLoadBarrier, loadLoadBarrier, writeBarrier,

   -- * Deprecated Functions
   fetchAddByteArrayInt
 ) where

import Control.Exception (evaluate)
import Data.Primitive.Array (MutableArray(MutableArray))
import Data.Primitive.ByteArray (MutableByteArray(MutableByteArray))
import Data.Atomics.Internal

import Data.IORef
import GHC.IORef hiding (atomicModifyIORef)
import GHC.STRef
import GHC.Exts hiding ((==#))
import qualified GHC.PrimopWrappers as GPW
import GHC.IO (IO(IO))
-- import GHC.Word (Word(W#))

#ifdef DEBUG_ATOMICS
#warning "Activating DEBUG_ATOMICS... NOINLINE's and more"
{-# NOINLINE seal #-}

{-# NOINLINE casIORef #-}
{-# NOINLINE casArrayElem2 #-}
{-# NOINLINE readArrayElem #-}
{-# NOINLINE readForCAS #-}
{-# NOINLINE casArrayElem #-}
{-# NOINLINE casIORef2 #-}
{-# NOINLINE readMutVarForCAS #-}
{-# NOINLINE casMutVar #-}
{-# NOINLINE casMutVar2 #-}
{-# NOINLINE casByteArrayInt #-}
{-# NOINLINE fetchAddIntArray #-}
{-# NOINLINE fetchSubIntArray #-}
{-# NOINLINE fetchAndIntArray #-}
{-# NOINLINE fetchNandIntArray #-}
{-# NOINLINE fetchOrIntArray #-}
{-# NOINLINE fetchXorIntArray #-}
#else
{-# INLINE casIORef #-}
{-# INLINE casArrayElem2 #-}
{-# INLINE readArrayElem #-}
{-# INLINE readForCAS #-}
{-# INLINE casArrayElem #-}
{-# INLINE casIORef2 #-}
{-# INLINE readMutVarForCAS #-}
{-# INLINE casMutVar #-}
{-# INLINE casMutVar2 #-}
{-# INLINE fetchAddIntArray #-}
{-# INLINE fetchSubIntArray #-}
{-# INLINE fetchAndIntArray #-}
{-# INLINE fetchNandIntArray #-}
{-# INLINE fetchOrIntArray #-}
{-# INLINE fetchXorIntArray #-}
#endif


-- GHC 7.8 changed some primops
(==#) :: Int# -> Int# -> Bool
==# :: Int# -> Int# -> Bool
(==#) Int#
x Int#
y = case Int#
x Int# -> Int# -> Int#
GPW.==# Int#
y of { Int#
0# -> Bool
False; Int#
_ -> Bool
True }

--------------------------------------------------------------------------------

-- | Compare-and-swap.  Follows the same rules as `casIORef`, returning the ticket for
--   then next operation.
--
--   By convention this is WHNF strict in the "new" value provided.
casArrayElem :: MutableArray RealWorld a -> Int -> Ticket a -> a -> IO (Bool, Ticket a)
-- casArrayElem (MutableArray arr#) (I# i#) old new = IO$ \s1# ->
--  case casArray# arr# i# old new s1# of
--    (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #)
casArrayElem :: forall a.
MutableArray RealWorld a
-> Int -> Ticket a -> a -> IO (Bool, Ticket a)
casArrayElem MutableArray RealWorld a
arr Int
i Ticket a
old !a
new = MutableArray RealWorld a
-> Int -> Ticket a -> Ticket a -> IO (Bool, Ticket a)
forall a.
MutableArray RealWorld a
-> Int -> Ticket a -> Ticket a -> IO (Bool, Ticket a)
casArrayElem2 MutableArray RealWorld a
arr Int
i Ticket a
old (a -> Ticket a
forall a. a -> Ticket a
seal a
new)

-- | This variant takes two tickets: the 'new' value is a ticket rather than an
-- arbitrary, lifted, Haskell value.
casArrayElem2 :: MutableArray RealWorld a -> Int -> Ticket a -> Ticket a -> IO (Bool, Ticket a)
casArrayElem2 :: forall a.
MutableArray RealWorld a
-> Int -> Ticket a -> Ticket a -> IO (Bool, Ticket a)
casArrayElem2 (MutableArray MutableArray# RealWorld a
arr#) (I# Int#
i#) Ticket a
old Ticket a
new = (State# RealWorld -> (# State# RealWorld, (Bool, Ticket a) #))
-> IO (Bool, Ticket a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO((State# RealWorld -> (# State# RealWorld, (Bool, Ticket a) #))
 -> IO (Bool, Ticket a))
-> (State# RealWorld -> (# State# RealWorld, (Bool, Ticket a) #))
-> IO (Bool, Ticket a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
 case MutableArray# RealWorld a
-> Int#
-> Ticket a
-> Ticket a
-> State# RealWorld
-> (# State# RealWorld, Int#, Ticket a #)
forall a.
MutableArray# RealWorld a
-> Int#
-> Ticket a
-> Ticket a
-> State# RealWorld
-> (# State# RealWorld, Int#, Ticket a #)
casArrayTicketed# MutableArray# RealWorld a
arr# Int#
i# Ticket a
old Ticket a
new State# RealWorld
s1# of
   (# State# RealWorld
s2#, Int#
x#, Ticket a
res #) -> (# State# RealWorld
s2#, (Int#
x# Int# -> Int# -> Bool
==# Int#
0#, Ticket a
res) #)

-- | Ordinary processor load instruction (non-atomic, not implying any memory barriers).
readArrayElem :: forall a . MutableArray RealWorld a -> Int -> IO (Ticket a)
-- readArrayElem = unsafeCoerce# readArray#
readArrayElem :: forall a. MutableArray RealWorld a -> Int -> IO (Ticket a)
readArrayElem (MutableArray MutableArray# RealWorld a
arr#) (I# Int#
i#) = (State# RealWorld -> (# State# RealWorld, Ticket a #))
-> IO (Ticket a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Ticket a #))
 -> IO (Ticket a))
-> (State# RealWorld -> (# State# RealWorld, Ticket a #))
-> IO (Ticket a)
forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
st -> (# State# RealWorld, a #) -> (# State# RealWorld, Ticket a #)
forall a b. a -> b
unsafeCoerce# (State# RealWorld -> (# State# RealWorld, a #)
fn State# RealWorld
st)
  where
    fn :: State# RealWorld -> (# State# RealWorld, a #)
    fn :: State# RealWorld -> (# State# RealWorld, a #)
fn = MutableArray# RealWorld a
-> Int# -> State# RealWorld -> (# State# RealWorld, a #)
forall d a.
MutableArray# d a -> Int# -> State# d -> (# State# d, a #)
readArray# MutableArray# RealWorld a
arr# Int#
i#

-- | Compare and swap on word-sized chunks of a byte-array.  For indexing purposes
-- the bytearray is treated as an array of words (`Int`s).  Note that UNLIKE
-- `casIORef` and `casArrayTicketed`, this does not need to operate on tickets.
--
-- Further, this version always returns the /old value/, that was read from the array during
-- the CAS operation.  That is, it follows the normal protocol for CAS operations
-- (and matches the underlying instruction on most architectures).
--
-- Implies a full memory barrier.
casByteArrayInt ::  MutableByteArray RealWorld -> Int -> Int -> Int -> IO Int
casByteArrayInt :: MutableByteArray RealWorld -> Int -> Int -> Int -> IO Int
casByteArrayInt (MutableByteArray MutableByteArray# RealWorld
mba#) (I# Int#
ix#) (I# Int#
old#) (I# Int#
new#) =
  (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO((State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int)
-> (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
  -- It would be nice to avoid allocating a tuple result here.
  -- Further, it will probably not be possible or the compiler to unbox the integer
  -- result either with the current arrangement:

  -- case casByteArrayInt# mba# ix# old# new# s1# of
  --   (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, I# res) #)

  let (# State# RealWorld
s2#, Int#
res #) = MutableByteArray# RealWorld
-> Int#
-> Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, Int# #)
forall d.
MutableByteArray# d
-> Int# -> Int# -> Int# -> State# d -> (# State# d, Int# #)
casIntArray# MutableByteArray# RealWorld
mba# Int#
ix# Int#
old# Int#
new# State# RealWorld
s1# in
  (# State# RealWorld
s2#, (Int# -> Int
I# Int#
res) #)
  -- I don't know if a let will mak any difference here... hopefully not.


--------------------------------------------------------------------------------
-- Fetch-and-* family of functions:

-- | Atomically add to a word of memory within a `MutableByteArray`, returning
-- the value *before* the operation. Implies a full memory barrier.
fetchAddIntArray :: MutableByteArray RealWorld
                     -> Int    -- ^ The offset into the array
                     -> Int    -- ^ The value to be added
                     -> IO Int -- ^ The value *before* the addition
fetchAddIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO Int
fetchAddIntArray (MutableByteArray MutableByteArray# RealWorld
mba#) (I# Int#
offset#) (I# Int#
incr#) = (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int)
-> (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s1# ->
  let (# State# RealWorld
s2#, Int#
res #) = MutableByteArray# RealWorld
-> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
forall d.
MutableByteArray# d
-> Int# -> Int# -> State# d -> (# State# d, Int# #)
fetchAddIntArray# MutableByteArray# RealWorld
mba# Int#
offset# Int#
incr# State# RealWorld
s1# in
  (# State# RealWorld
s2#, (Int# -> Int
I# Int#
res) #)


-- | Atomically subtract to a word of memory within a `MutableByteArray`,
-- returning the value *before* the operation. Implies a full memory barrier.
fetchSubIntArray :: MutableByteArray RealWorld
                     -> Int    -- ^ The offset into the array
                     -> Int    -- ^ The value to be subtracted
                     -> IO Int -- ^ The value *before* the addition
fetchSubIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO Int
fetchSubIntArray = (MutableByteArray# RealWorld
 -> Int#
 -> Int#
 -> State# RealWorld
 -> (# State# RealWorld, Int# #))
-> MutableByteArray RealWorld -> Int -> Int -> IO Int
doAtomicRMW MutableByteArray# RealWorld
-> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
forall d.
MutableByteArray# d
-> Int# -> Int# -> State# d -> (# State# d, Int# #)
fetchSubIntArray#

-- | Atomically bitwise AND to a word of memory within a `MutableByteArray`,
-- returning the value *before* the operation. Implies a full memory barrier.
fetchAndIntArray :: MutableByteArray RealWorld
                     -> Int    -- ^ The offset into the array
                     -> Int    -- ^ The value to be AND-ed
                     -> IO Int -- ^ The value *before* the addition
fetchAndIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO Int
fetchAndIntArray = (MutableByteArray# RealWorld
 -> Int#
 -> Int#
 -> State# RealWorld
 -> (# State# RealWorld, Int# #))
-> MutableByteArray RealWorld -> Int -> Int -> IO Int
doAtomicRMW MutableByteArray# RealWorld
-> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
forall d.
MutableByteArray# d
-> Int# -> Int# -> State# d -> (# State# d, Int# #)
fetchAndIntArray#

-- | Atomically bitwise NAND to a word of memory within a `MutableByteArray`,
-- returning the value *before* the operation. Implies a full memory barrier.
fetchNandIntArray :: MutableByteArray RealWorld
                     -> Int    -- ^ The offset into the array
                     -> Int    -- ^ The value to be NAND-ed
                     -> IO Int -- ^ The value *before* the addition
fetchNandIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO Int
fetchNandIntArray = (MutableByteArray# RealWorld
 -> Int#
 -> Int#
 -> State# RealWorld
 -> (# State# RealWorld, Int# #))
-> MutableByteArray RealWorld -> Int -> Int -> IO Int
doAtomicRMW MutableByteArray# RealWorld
-> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
forall d.
MutableByteArray# d
-> Int# -> Int# -> State# d -> (# State# d, Int# #)
fetchNandIntArray#

-- | Atomically bitwise OR to a word of memory within a `MutableByteArray`,
-- returning the value *before* the operation. Implies a full memory barrier.
fetchOrIntArray :: MutableByteArray RealWorld
                     -> Int    -- ^ The offset into the array
                     -> Int    -- ^ The value to be OR-ed
                     -> IO Int -- ^ The value *before* the addition
fetchOrIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO Int
fetchOrIntArray = (MutableByteArray# RealWorld
 -> Int#
 -> Int#
 -> State# RealWorld
 -> (# State# RealWorld, Int# #))
-> MutableByteArray RealWorld -> Int -> Int -> IO Int
doAtomicRMW MutableByteArray# RealWorld
-> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
forall d.
MutableByteArray# d
-> Int# -> Int# -> State# d -> (# State# d, Int# #)
fetchOrIntArray#

-- | Atomically bitwise XOR to a word of memory within a `MutableByteArray`,
-- returning the value *before* the operation. Implies a full memory barrier.
fetchXorIntArray :: MutableByteArray RealWorld
                     -> Int    -- ^ The offset into the array
                     -> Int    -- ^ The value to be XOR-ed
                     -> IO Int -- ^ The value *before* the addition
fetchXorIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO Int
fetchXorIntArray = (MutableByteArray# RealWorld
 -> Int#
 -> Int#
 -> State# RealWorld
 -> (# State# RealWorld, Int# #))
-> MutableByteArray RealWorld -> Int -> Int -> IO Int
doAtomicRMW MutableByteArray# RealWorld
-> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
forall d.
MutableByteArray# d
-> Int# -> Int# -> State# d -> (# State# d, Int# #)
fetchXorIntArray#


-- Internals for our fetch* family of functions, with CAS loop fallbacks for
-- GHC < 7.10:
{-# INLINE doAtomicRMW #-}
doAtomicRMW :: (MutableByteArray# RealWorld -> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)) --  primop
            -> MutableByteArray RealWorld -> Int -> Int -> IO Int      --  exported function
doAtomicRMW :: (MutableByteArray# RealWorld
 -> Int#
 -> Int#
 -> State# RealWorld
 -> (# State# RealWorld, Int# #))
-> MutableByteArray RealWorld -> Int -> Int -> IO Int
doAtomicRMW MutableByteArray# RealWorld
-> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
atomicOp# =
  \(MutableByteArray MutableByteArray# RealWorld
mba#) (I# Int#
offset#) (I# Int#
val#) ->
    (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int)
-> (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s1# ->
      let (# State# RealWorld
s2#, Int#
res #) = MutableByteArray# RealWorld
-> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
atomicOp# MutableByteArray# RealWorld
mba# Int#
offset# Int#
val# State# RealWorld
s1# in
      (# State# RealWorld
s2#, (Int# -> Int
I# Int#
res) #)


{-# DEPRECATED fetchAddByteArrayInt "Replaced by fetchAddIntArray which returns the OLD value" #-}
-- | Atomically add to a word of memory within a `MutableByteArray`.
--
--   This function returns the NEW value of the location after the increment.
--   Thus, it is a bit misnamed, and in other contexts might be called "add-and-fetch",
--   such as in GCC's `__sync_add_and_fetch`.
fetchAddByteArrayInt ::  MutableByteArray RealWorld -> Int -> Int -> IO Int
fetchAddByteArrayInt :: MutableByteArray RealWorld -> Int -> Int -> IO Int
fetchAddByteArrayInt (MutableByteArray MutableByteArray# RealWorld
mba#) (I# Int#
offset#) (I# Int#
incr#) = (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int)
-> (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s1# ->
  let (# State# RealWorld
s2#, Int#
res #) = MutableByteArray# RealWorld
-> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
forall d.
MutableByteArray# d
-> Int# -> Int# -> State# d -> (# State# d, Int# #)
fetchAddIntArray# MutableByteArray# RealWorld
mba# Int#
offset# Int#
incr# State# RealWorld
s1# in
  (# State# RealWorld
s2#, (Int# -> Int
I# (Int#
res Int# -> Int# -> Int#
+# Int#
incr#)) #)


--------------------------------------------------------------------------------
{- WIP. Having trouble writing good tests for these, and not sure how useful
 - these are. See #43 discussion
 -
 - Also remember to add these to the INLINE / NOINLINE section when exported



-- | 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
atomicReadIntArray (MutableByteArray mba#) (I# ix#) = IO $ \ s# ->
    case atomicReadIntArray# mba# ix# s# of
        (# s2#, n# #) -> (# s2#, I# n# #)

-- | 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 ()
atomicWriteIntArray (MutableByteArray mba#) (I# ix#) (I# n#) = IO $ \ s# ->
    case atomicWriteIntArray# mba# ix# n# s# of
        s2# -> (# s2#, () #)

-}

--------------------------------------------------------------------------------

-- | Ordinary processor load instruction (non-atomic, not implying any memory barriers).
--
--   The difference between this function and `readIORef`, is that it returns a /ticket/,
--   for use in future compare-and-swap operations.
readForCAS :: IORef a -> IO ( Ticket a )
readForCAS :: forall a. IORef a -> IO (Ticket a)
readForCAS (IORef (STRef MutVar# RealWorld a
mv)) = MutVar# RealWorld a -> IO (Ticket a)
forall a. MutVar# RealWorld a -> IO (Ticket a)
readMutVarForCAS MutVar# RealWorld a
mv

-- | Performs a machine-level compare and swap (CAS) operation on an
-- 'IORef'. Returns a tuple containing a 'Bool' which is 'True' when a
-- swap is performed, along with the most 'current' value from the 'IORef'.
-- Note that this differs from the more common CAS behavior, which is to
-- return the /old/ value before the CAS occured.
--
-- The reason for the difference is the ticket API.  This function always returns the
-- ticket that you should use in your next CAS attempt.  In case of success, this ticket
-- corresponds to the `new` value which you yourself installed in the `IORef`, whereas
-- in the case of failure it represents the preexisting value currently in the IORef.
--
-- Note \"compare\" here means pointer equality in the sense of
-- 'GHC.Prim.reallyUnsafePtrEquality#'.  However, the ticket API absolves
-- the user of this module from needing to worry about the pointer equality of their
-- values, which in general requires reasoning about the details of the Haskell
-- implementation (GHC).
--
-- By convention this function is strict in the "new" value argument.  This isn't
-- absolutely necesary, but we think it's a bad habit to use unevaluated thunks in
-- this context.
casIORef :: IORef a  -- ^ The 'IORef' containing a value 'current'
         -> Ticket a -- ^ A ticket for the 'old' value
         -> a        -- ^ The 'new' value to replace 'current' if @old == current@
         -> IO (Bool, Ticket a) -- ^ Success flag, plus ticket for the NEXT operation.
casIORef :: forall a. IORef a -> Ticket a -> a -> IO (Bool, Ticket a)
casIORef (IORef (STRef MutVar# RealWorld a
var)) Ticket a
old !a
new = MutVar# RealWorld a -> Ticket a -> a -> IO (Bool, Ticket a)
forall a.
MutVar# RealWorld a -> Ticket a -> a -> IO (Bool, Ticket a)
casMutVar MutVar# RealWorld a
var Ticket a
old a
new

-- | This variant takes two tickets, i.e. the 'new' value is a ticket rather than an
-- arbitrary, lifted, Haskell value.
casIORef2 :: IORef a
         -> Ticket a -- ^ A ticket for the 'old' value
         -> Ticket a -- ^ A ticket for the 'new' value
         -> IO (Bool, Ticket a)
casIORef2 :: forall a. IORef a -> Ticket a -> Ticket a -> IO (Bool, Ticket a)
casIORef2 (IORef (STRef MutVar# RealWorld a
var)) Ticket a
old Ticket a
new = MutVar# RealWorld a -> Ticket a -> Ticket a -> IO (Bool, Ticket a)
forall a.
MutVar# RealWorld a -> Ticket a -> Ticket a -> IO (Bool, Ticket a)
casMutVar2 MutVar# RealWorld a
var Ticket a
old Ticket a
new


--------------------------------------------------------------------------------

-- | A ticket contains or can get the usable Haskell value.
--   This function does just that.
{-# NOINLINE peekTicket #-}
-- At least this function MUST remain NOINLINE.  Issue5 is an example of a bug that
-- ensues otherwise.
peekTicket :: Ticket a -> a
peekTicket :: forall a. Ticket a -> a
peekTicket = Ticket a -> a
forall a b. a -> b
unsafeCoerce#

-- Not exposing this for now.  Presently the idea is that you must read from the
-- mutable data structure itself to get a ticket.
seal :: a -> Ticket a
seal :: forall a. a -> Ticket a
seal = a -> Ticket a
forall a b. a -> b
unsafeCoerce#

-- | Like `readForCAS`, but for `MutVar#`.
readMutVarForCAS :: MutVar# RealWorld a -> IO ( Ticket a )
readMutVarForCAS :: forall a. MutVar# RealWorld a -> IO (Ticket a)
readMutVarForCAS MutVar# RealWorld a
mv = (State# RealWorld -> (# State# RealWorld, Ticket a #))
-> IO (Ticket a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO((State# RealWorld -> (# State# RealWorld, Ticket a #))
 -> IO (Ticket a))
-> (State# RealWorld -> (# State# RealWorld, Ticket a #))
-> IO (Ticket a)
forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
st -> MutVar# RealWorld a
-> State# RealWorld -> (# State# RealWorld, Ticket a #)
forall a.
MutVar# RealWorld a
-> State# RealWorld -> (# State# RealWorld, Ticket a #)
readForCAS# MutVar# RealWorld a
mv State# RealWorld
st

-- | MutVar counterpart of `casIORef`.
--
--   By convention this is WHNF strict in the "new" value provided.
casMutVar :: MutVar# RealWorld a -> Ticket a -> a -> IO (Bool, Ticket a)
casMutVar :: forall a.
MutVar# RealWorld a -> Ticket a -> a -> IO (Bool, Ticket a)
casMutVar MutVar# RealWorld a
mv Ticket a
tick !a
new =
  -- trace ("TEMPDBG: Inside casMutVar.. ") $
  MutVar# RealWorld a -> Ticket a -> Ticket a -> IO (Bool, Ticket a)
forall a.
MutVar# RealWorld a -> Ticket a -> Ticket a -> IO (Bool, Ticket a)
casMutVar2 MutVar# RealWorld a
mv Ticket a
tick (a -> Ticket a
forall a. a -> Ticket a
seal a
new)

-- | This variant takes two tickets, i.e. the 'new' value is a ticket rather than an
-- arbitrary, lifted, Haskell value.
casMutVar2 :: MutVar# RealWorld a -> Ticket a -> Ticket a -> IO (Bool, Ticket a)
casMutVar2 :: forall a.
MutVar# RealWorld a -> Ticket a -> Ticket a -> IO (Bool, Ticket a)
casMutVar2 MutVar# RealWorld a
mv Ticket a
tick Ticket a
new = (State# RealWorld -> (# State# RealWorld, (Bool, Ticket a) #))
-> IO (Bool, Ticket a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO((State# RealWorld -> (# State# RealWorld, (Bool, Ticket a) #))
 -> IO (Bool, Ticket a))
-> (State# RealWorld -> (# State# RealWorld, (Bool, Ticket a) #))
-> IO (Bool, Ticket a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
st ->
  case MutVar# RealWorld a
-> Ticket a
-> Ticket a
-> State# RealWorld
-> (# State# RealWorld, Int#, Ticket a #)
forall a.
MutVar# RealWorld a
-> Ticket a
-> Ticket a
-> State# RealWorld
-> (# State# RealWorld, Int#, Ticket a #)
casMutVarTicketed# MutVar# RealWorld a
mv Ticket a
tick Ticket a
new State# RealWorld
st of
    (# State# RealWorld
st', Int#
flag, Ticket a
tick' #) ->
      (# State# RealWorld
st', (Int#
flag Int# -> Int# -> Bool
==# Int#
0#, Ticket a
tick') #)
--      (# st, if flag ==# 0# then Succeed tick' else Fail tick' #)
--      if flag ==# 0#    then       else (# st, Fail (W# tick')  #)

--------------------------------------------------------------------------------
-- Memory barriers
--------------------------------------------------------------------------------

-- | Memory barrier implemented by the GHC rts (see SMP.h).
-- storeLoadBarrier :: IO ()

-- | Memory barrier implemented by the GHC rts (see SMP.h).
-- loadLoadBarrier :: IO ()

-- | Memory barrier implemented by the GHC rts (see SMP.h).
-- writeBarrier :: IO ()

#if __GLASGOW_HASKELL__ >= 909

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 ()

-- | Memory barrier implemented by the GHC rts (see SMP.h).
foreign import ccall unsafe "load_load_barrier" loadLoadBarrier
  :: IO ()

-- | 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."

-- Workaround for Trac #12846, which affects old GHCs on Windows
foreign import ccall  unsafe "DUP_store_load_barrier" storeLoadBarrier
  :: IO ()

foreign import ccall unsafe "DUP_load_load_barrier" loadLoadBarrier
  :: IO ()

foreign import ccall unsafe "DUP_write_barrier" writeBarrier
  :: IO ()
#endif

--------------------------------------------------------------------------------


-- | A drop-in replacement for `atomicModifyIORef` that
--   optimistically attempts to compute the new value and CAS it into
--   place without introducing new thunks or locking anything.  Note
--   that this is more STRICT than its standard counterpart and will only
--   place evaluated (WHNF) values in the IORef.
--
--   The upside is that sometimes we see a performance benefit.
--   The downside is that this version is speculative -- when it
--   retries, it must reexecute the compution.
atomicModifyIORefCAS :: IORef a      -- ^ Mutable location to modify
                     -> (a -> (a,b)) -- ^ Computation runs one or more times (speculation)
                     -> IO b
atomicModifyIORefCAS :: forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORefCAS IORef a
ref a -> (a, b)
fn = do
   -- TODO: Should handle contention in a better way...
   Ticket a
tick <- IORef a -> IO (Ticket a)
forall a. IORef a -> IO (Ticket a)
readForCAS IORef a
ref
   Ticket a -> Int -> IO b
forall {t}. (Eq t, Num t) => Ticket a -> t -> IO b
loop Ticket a
tick Int
effort
  where
   effort :: Int
effort = Int
30 :: Int -- TODO: Tune this.
   loop :: Ticket a -> t -> IO b
loop Ticket a
_   t
0     = IORef a -> (a -> (a, b)) -> IO b
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef a
ref a -> (a, b)
fn -- Fall back to the regular version.
   loop Ticket a
old t
tries = do
     (a
new,b
result) <- (a, b) -> IO (a, b)
forall a. a -> IO a
evaluate ((a, b) -> IO (a, b)) -> (a, b) -> IO (a, b)
forall a b. (a -> b) -> a -> b
$ a -> (a, b)
fn (a -> (a, b)) -> a -> (a, b)
forall a b. (a -> b) -> a -> b
$ Ticket a -> a
forall a. Ticket a -> a
peekTicket Ticket a
old
     (Bool
b,Ticket a
tick) <- IORef a -> Ticket a -> a -> IO (Bool, Ticket a)
forall a. IORef a -> Ticket a -> a -> IO (Bool, Ticket a)
casIORef IORef a
ref Ticket a
old a
new
     if Bool
b
      then b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
result
      else Ticket a -> t -> IO b
loop Ticket a
tick (t
triest -> t -> t
forall a. Num a => a -> a -> a
-t
1)


-- | A simpler version that modifies the state but does not return anything.
atomicModifyIORefCAS_ :: IORef t -> (t -> t) -> IO ()
-- atomicModifyIORefCAS_ ref fn = atomicModifyIORefCAS ref (\ x -> (fn x, ()))
-- Can't inline a function with a loop so we duplicate this:
-- <duplicated code>
atomicModifyIORefCAS_ :: forall t. IORef t -> (t -> t) -> IO ()
atomicModifyIORefCAS_ IORef t
ref t -> t
fn = do
   Ticket t
tick <- IORef t -> IO (Ticket t)
forall a. IORef a -> IO (Ticket a)
readForCAS IORef t
ref
   Ticket t -> Int -> IO ()
forall {t}. (Eq t, Num t) => Ticket t -> t -> IO ()
loop Ticket t
tick Int
effort
  where
   effort :: Int
effort = Int
30 :: Int -- TODO: Tune this.
   loop :: Ticket t -> t -> IO ()
loop Ticket t
_   t
0     = IORef t -> (t -> (t, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef t
ref (\ t
x -> (t -> t
fn t
x, ()))
   loop Ticket t
old t
tries = do
     t
new <- t -> IO t
forall a. a -> IO a
evaluate (t -> IO t) -> t -> IO t
forall a b. (a -> b) -> a -> b
$ t -> t
fn (t -> t) -> t -> t
forall a b. (a -> b) -> a -> b
$ Ticket t -> t
forall a. Ticket a -> a
peekTicket Ticket t
old
     (Bool
b,Ticket t
val) <- IORef t -> Ticket t -> t -> IO (Bool, Ticket t)
forall a. IORef a -> Ticket a -> a -> IO (Bool, Ticket a)
casIORef IORef t
ref Ticket t
old t
new
     if Bool
b
      then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else Ticket t -> t -> IO ()
loop Ticket t
val (t
triest -> t -> t
forall a. Num a => a -> a -> a
-t
1)
-- </duplicated code>