diff options
| -rw-r--r-- | compiler/GHC/Builtin/primops.txt.pp | 26 | ||||
| -rw-r--r-- | compiler/GHC/CmmToAsm/X86/CodeGen.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Prim.hs | 4 | ||||
| -rw-r--r-- | libraries/base/GHC/Event/Internal.hs | 16 | ||||
| -rw-r--r-- | libraries/base/GHC/Event/Windows.hsc | 12 | ||||
| -rw-r--r-- | libraries/base/GHC/Ptr.hs | 12 | ||||
| -rw-r--r-- | libraries/ghc-prim/changelog.md | 4 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_compile/cg011.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/all.T | 1 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/cas_int.hs | 54 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/cas_int.stdout | 4 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/cgrun080.hs | 2 |
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 #) |