Commit b41f7c38 authored by Andreas Klebinger's avatar Andreas Klebinger Committed by Marge Bot

WinIO: Small changes related to atomic request swaps.

Move the atomix exchange over the Ptr type to an internal module.

Fix a bug caused by us passing ptr-to-ptr instead of ptr to
atomic exchange.

Renamed interlockedExchange to exchangePtr.

I've also added an cas primitive. It turned out we don't need it
for WinIO but I'm leaving it in as it's useful for other things.
parent 5fc4243b
......@@ -2527,18 +2527,40 @@ primop WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp
with has_side_effects = True
can_fail = True
primop InterlockedExchange_Addr "interlockedExchangeAddr#" GenPrimOp
primop InterlockedExchange_Addr "atomicExchangeAddr#" GenPrimOp
Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
{The atomic exchange operation. Atomically exchanges the value at the first address
with the Addr# given as second argument. Implies a read barrier.}
with has_side_effects = True
primop InterlockedExchange_Int "interlockedExchangeInt#" GenPrimOp
primop InterlockedExchange_Int "atomicExchangeInt#" GenPrimOp
Addr# -> Int# -> State# s -> (# State# s, Int# #)
{The atomic exchange operation. Atomically exchanges the value at the address
with the given value. Returns the old value. Implies a read barrier.}
with has_side_effects = True
primop AtomicCompareExchange_Int "atomicCasInt#" GenPrimOp
Addr# -> Int# -> Int# -> State# s -> (# State# s, Int# #)
{ Compare and swap on a word-sized memory location.
Use as atomicCasInt# location expected desired
This version always returns the old value read. This follows the normal protocol for CAS operations (and matches the underlying instruction on most architectures).
Implies a full memory barrier.}
with has_side_effects = True
primop AtomicCompareExchange_Addr "atomicCasAddr#" GenPrimOp
Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
{ Compare and swap on a word-sized memory location.
Use as atomicCasAddr# location expected desired
This version always returns the old value read. This follows the normal protocol for CAS operations (and matches the underlying instruction on most architectures).
Implies a full memory barrier.}
with has_side_effects = True
------------------------------------------------------------------------
section "Mutable variables"
{Operations on MutVar\#s.}
......
......@@ -2561,6 +2561,8 @@ genCCall' config is32Bit (PrimTarget (MO_Xchg width)) [dst] [addr, value] _
-- Copy the value into the target register, perform the exchange.
let code = toOL
[ MOV format (OpReg newval) (OpReg dst_r)
-- On X86 xchg implies a lock prefix if we use a memory argument.
-- so this is atomic.
, XCHG format (OpAddr amode) dst_r
]
return $ addr_code `appOL` newval_code `appOL` code
......
......@@ -850,6 +850,10 @@ emitPrimOp dflags primop = case primop of
emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]
InterlockedExchange_Int -> \[src, value] -> opIntoRegs $ \[res] ->
emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]
AtomicCompareExchange_Int -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]
AtomicCompareExchange_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]
-- SIMD primops
(VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do
......
{-# LANGUAGE Unsafe #-}
{-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
module GHC.Event.Internal
(
......@@ -13,6 +15,9 @@ module GHC.Event.Internal
, module GHC.Event.Internal.Types
-- * Helpers
, throwErrnoIfMinus1NoRetry
-- Atomic ptr exchange for WinIO
, exchangePtr
) where
import Foreign.C.Error (eINTR, getErrno, throwErrno)
......@@ -21,6 +26,8 @@ import GHC.Base
import GHC.Num (Num(..))
import GHC.Event.Internal.Types
import GHC.Ptr (Ptr(..))
-- | Event notification backend.
data Backend = forall a. Backend {
_beState :: !a
......@@ -95,3 +102,12 @@ throwErrnoIfMinus1NoRetry loc f = do
err <- getErrno
if err == eINTR then return 0 else throwErrno loc
else return res
{-# INLINE exchangePtr #-}
-- | @exchangePtr pptr x@ swaps the pointer pointed to by @pptr@ with the value
-- @x@, returning the old value.
exchangePtr :: Ptr (Ptr a) -> Ptr a -> IO (Ptr a)
exchangePtr (Ptr dst) (Ptr val) =
IO $ \s ->
case (atomicExchangeAddr# dst val s) of
(# s2, old_val #) -> (# s2, Ptr old_val #)
......@@ -116,7 +116,6 @@ import GHC.Real
import GHC.Enum (maxBound)
import GHC.Windows
import GHC.List (null)
import GHC.Ptr
import Text.Show
#if defined(DEBUG)
......@@ -307,8 +306,9 @@ cdOffset :: Int
cdOffset = #{const __builtin_offsetof (HASKELL_OVERLAPPED, hoData)}
-- | Terminator symbol for IOCP request
nullReq :: Ptr (Ptr a)
nullReq = castPtr $ unsafePerformIO $ new $ (nullPtr :: Ptr ())
nullReq :: Ptr CompletionData
nullReq = castPtr $ unsafePerformIO $ new (0 :: Int)
{-# NOINLINE nullReq #-}
-- I don't expect a lot of events, so a simple linked lists should be enough.
type EventElements = [(Event, HandleData)]
......@@ -667,7 +667,7 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
-- the pointer.
debugIO $ "## Waiting for cancellation record... "
_ <- FFI.getOverlappedResult h lpol True
oldDataPtr <- exchangePtr ptr_lpol nullReq
oldDataPtr <- I.exchangePtr ptr_lpol nullReq
when (oldDataPtr == cdData) $
do reqs <- removeRequest
debugIO $ "-1.. " ++ show reqs ++ " requests queued after error."
......@@ -1039,7 +1039,7 @@ processCompletion Manager{..} n delay = do
++ " offset: " ++ show cdOffset
++ " cdData: " ++ show cdDataCheck
++ " at idx " ++ show idx
oldDataPtr <- exchangePtr ptr_lpol nullReq :: IO (Ptr CompletionData)
oldDataPtr <- I.exchangePtr ptr_lpol nullReq :: IO (Ptr CompletionData)
debugIO $ ":: oldDataPtr " ++ show oldDataPtr
when (oldDataPtr /= nullPtr) $
do debugIO $ "exchanged: " ++ show oldDataPtr
......@@ -1269,4 +1269,4 @@ debugIO _ = return ()
-- _ <- withCStringLen (pref ++ "winio: " ++ s ++ " (" ++
-- showThreadId tid ++ ")\n") $
-- \(p, len) -> c_write 2 (castPtr p) (fromIntegral len)
-- return ()
\ No newline at end of file
-- return ()
......@@ -25,8 +25,6 @@ module GHC.Ptr (
-- * Unsafe functions
castFunPtrToPtr, castPtrToFunPtr,
-- * Atomic operations
exchangePtr
) where
import GHC.Base
......@@ -164,16 +162,6 @@ castFunPtrToPtr (FunPtr addr) = Ptr addr
castPtrToFunPtr :: Ptr a -> FunPtr b
castPtrToFunPtr (Ptr addr) = FunPtr addr
------------------------------------------------------------------------
-- Atomic operations for Ptr
{-# INLINE exchangePtr #-}
exchangePtr :: Ptr (Ptr a) -> Ptr b -> IO (Ptr c)
exchangePtr (Ptr dst) (Ptr val) =
IO $ \s ->
case (interlockedExchangeAddr# dst val s) of
(# s2, old_val #) -> (# s2, Ptr old_val #)
------------------------------------------------------------------------
-- Show instances for Ptr and FunPtr
......
......@@ -21,8 +21,8 @@
- Add primops for atomic exchange:
interlockedExchangeAddr# :: Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
interlockedExchangeInt# :: Addr# -> Int# -> State# s -> (# State# s, Int# #)
atomicExchangeAddr# :: Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
atomicExchangeInt# :: Addr# -> Int# -> State# s -> (# State# s, Int# #)
- Add an explicit fixity for `(~)` and `(~~)`:
......
{-# LANGUAGE CPP, MagicHash, BlockArguments, UnboxedTuples #-}
-- Tests compilation for interlockedExchange primop.
-- Tests compilation for atomic exchange primop.
module M where
import GHC.Exts (interlockedExchangeInt#, Int#, Addr#, State# )
import GHC.Exts (atomicExchangeInt#, Int#, Addr#, State# )
swap :: Addr# -> Int# -> State# s -> (# #)
swap ptr val s = case (interlockedExchangeInt# ptr val s) of
swap ptr val s = case (atomicExchangeInt# ptr val s) of
(# s2, old_val #) -> (# #)
......@@ -90,6 +90,7 @@ test('cgrun077', [when(have_cpu_feature('bmi2'), extra_hc_opts('-mbmi2'))], comp
test('cgrun078', omit_ways(['ghci']), compile_and_run, [''])
test('cgrun079', normal, compile_and_run, [''])
test('cgrun080', normal, compile_and_run, [''])
test('cas_int', normal, compile_and_run, [''])
test('T1852', normal, compile_and_run, [''])
test('T1861', extra_run_opts('0'), compile_and_run, [''])
......
{-# LANGUAGE CPP, MagicHash, BlockArguments, UnboxedTuples #-}
{-# LANGUAGE CPP, MagicHash, BlockArguments, ScopedTypeVariables #-}
-- Test the atomic exchange primop.
-- We initialize a value with 1, and then perform exchanges on it
-- with two different values. At the end all the values should still
-- be present.
module Main ( main ) where
import Data.Bits
import GHC.Int
import GHC.Prim
import GHC.Word
import Control.Monad
import Control.Concurrent
import Foreign.Marshal.Alloc
import Foreign.Storable
import Data.List (sort)
import GHC.Exts
import GHC.Types
import GHC.Ptr
#include "MachDeps.h"
main = do
alloca $ \(ptr_p :: Ptr (Ptr Int)) -> do
alloca $ \(ptr_i :: Ptr Int) -> do
alloca $ \(ptr_j :: Ptr Int) -> do
poke ptr_i (1 :: Int)
poke ptr_j (2 :: Int)
--expected to swap
res_i <- cas ptr_i 1 3 :: IO Int
-- expected to fail
res_j <- cas ptr_j 1 4 :: IO Int
putStrLn "Returned results:"
--(1,2)
print (res_i, res_j)
i <-peek ptr_i
j <-peek ptr_j
putStrLn "Stored results:"
--(3,2)
print (i,j)
cas :: Ptr Int -> Int -> Int -> IO Int
cas (Ptr ptr) (I# expected) (I# desired)= do
IO $ \s -> case (atomicCasInt# ptr expected desired s) of
(# s2, old_val #) -> (# s2, I# old_val #)
Returned results:
(1,2)
Stored results:
(3,2)
......@@ -46,6 +46,6 @@ swapN n val ptr = do
swap :: Ptr Int -> Int -> IO Int
swap (Ptr ptr) (I# val) = do
IO $ \s -> case (interlockedExchangeInt# ptr val s) of
IO $ \s -> case (atomicExchangeInt# ptr val s) of
(# s2, old_val #) -> (# s2, I# old_val #)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment