summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreas Klebinger <klebinger.andreas@gmx.at>2020-09-25 15:58:36 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-10-07 15:00:20 -0400
commitb41f7c3814b2e0e765311babc851cd3d9b6a78d8 (patch)
treeff0dd8327fb48f68e5351cb8501d4bac16c32668
parent5fc4243bf2da2adbae3d01d163053e8895bc52d9 (diff)
downloadhaskell-b41f7c3814b2e0e765311babc851cd3d9b6a78d8.tar.gz
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.
-rw-r--r--compiler/GHC/Builtin/primops.txt.pp26
-rw-r--r--compiler/GHC/CmmToAsm/X86/CodeGen.hs2
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs4
-rw-r--r--libraries/base/GHC/Event/Internal.hs16
-rw-r--r--libraries/base/GHC/Event/Windows.hsc12
-rw-r--r--libraries/base/GHC/Ptr.hs12
-rw-r--r--libraries/ghc-prim/changelog.md4
-rw-r--r--testsuite/tests/codeGen/should_compile/cg011.hs6
-rw-r--r--testsuite/tests/codeGen/should_run/all.T1
-rw-r--r--testsuite/tests/codeGen/should_run/cas_int.hs54
-rw-r--r--testsuite/tests/codeGen/should_run/cas_int.stdout4
-rw-r--r--testsuite/tests/codeGen/should_run/cgrun080.hs2
12 files changed, 117 insertions, 26 deletions
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 305f692908..16a908afe5 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -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.}
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
index e9b54c6b45..aa4769f376 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -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
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 90cb963e89..4a58873992 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -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
diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs
index 2ed8d2e66c..0c3a98cdf9 100644
--- a/libraries/base/GHC/Event/Internal.hs
+++ b/libraries/base/GHC/Event/Internal.hs
@@ -1,5 +1,7 @@
{-# 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 #)
diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc
index fdf01e527a..d4321a0f09 100644
--- a/libraries/base/GHC/Event/Windows.hsc
+++ b/libraries/base/GHC/Event/Windows.hsc
@@ -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 ()
diff --git a/libraries/base/GHC/Ptr.hs b/libraries/base/GHC/Ptr.hs
index 6cbcc07ddc..f19e7b90c8 100644
--- a/libraries/base/GHC/Ptr.hs
+++ b/libraries/base/GHC/Ptr.hs
@@ -25,8 +25,6 @@ module GHC.Ptr (
-- * Unsafe functions
castFunPtrToPtr, castPtrToFunPtr,
- -- * Atomic operations
- exchangePtr
) where
import GHC.Base
@@ -165,16 +163,6 @@ 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
-- | @since 2.01
diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md
index 3df0b5e2ed..e4fab631dc 100644
--- a/libraries/ghc-prim/changelog.md
+++ b/libraries/ghc-prim/changelog.md
@@ -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 `(~~)`:
diff --git a/testsuite/tests/codeGen/should_compile/cg011.hs b/testsuite/tests/codeGen/should_compile/cg011.hs
index 5d80968547..5d86621784 100644
--- a/testsuite/tests/codeGen/should_compile/cg011.hs
+++ b/testsuite/tests/codeGen/should_compile/cg011.hs
@@ -1,11 +1,11 @@
{-# 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 #) -> (# #)
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 8892b506e4..bc7dcbd8f1 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -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, [''])
diff --git a/testsuite/tests/codeGen/should_run/cas_int.hs b/testsuite/tests/codeGen/should_run/cas_int.hs
new file mode 100644
index 0000000000..e1d4905944
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/cas_int.hs
@@ -0,0 +1,54 @@
+{-# 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 #)
diff --git a/testsuite/tests/codeGen/should_run/cas_int.stdout b/testsuite/tests/codeGen/should_run/cas_int.stdout
new file mode 100644
index 0000000000..0b50c37bfd
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/cas_int.stdout
@@ -0,0 +1,4 @@
+Returned results:
+(1,2)
+Stored results:
+(3,2)
diff --git a/testsuite/tests/codeGen/should_run/cgrun080.hs b/testsuite/tests/codeGen/should_run/cgrun080.hs
index 5390dd11ae..4e09cd7634 100644
--- a/testsuite/tests/codeGen/should_run/cgrun080.hs
+++ b/testsuite/tests/codeGen/should_run/cgrun080.hs
@@ -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 #)