[Git][ghc/ghc][wip/andreask/winio_atomics] WinIO: Small changes related to atomic request swaps.
Andreas Klebinger
gitlab at gitlab.haskell.org
Tue Sep 29 15:32:33 UTC 2020
Andreas Klebinger pushed to branch wip/andreask/winio_atomics at Glasgow Haskell Compiler / GHC
Commits:
1ee84b85 by Andreas Klebinger at 2020-09-29T17:31:27+02:00
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.
- - - - -
12 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/StgToCmm/Prim.hs
- libraries/base/GHC/Event/Internal.hs
- libraries/base/GHC/Event/Windows.hsc
- libraries/base/GHC/Ptr.hs
- libraries/ghc-prim/changelog.md
- testsuite/tests/codeGen/should_compile/cg011.hs
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/codeGen/should_run/cas_int.hs
- + testsuite/tests/codeGen/should_run/cas_int.stdout
- testsuite/tests/codeGen/should_run/cgrun080.hs
Changes:
=====================================
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.}
=====================================
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
=====================================
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
=====================================
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 #)
\ No newline at end of file
=====================================
libraries/base/GHC/Event/Windows.hsc
=====================================
@@ -306,10 +306,6 @@ foreign import ccall safe "completeSynchronousRequest"
cdOffset :: Int
cdOffset = #{const __builtin_offsetof (HASKELL_OVERLAPPED, hoData)}
--- | Terminator symbol for IOCP request
-nullReq :: Ptr (Ptr a)
-nullReq = castPtr $ unsafePerformIO $ new $ (nullPtr :: Ptr ())
-
-- I don't expect a lot of events, so a simple linked lists should be enough.
type EventElements = [(Event, HandleData)]
data EventData = EventData { evtTopLevel :: !Event, evtElems :: !EventElements }
@@ -667,7 +663,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 nullPtr
when (oldDataPtr == cdData) $
do reqs <- removeRequest
debugIO $ "-1.. " ++ show reqs ++ " requests queued after error."
@@ -1039,7 +1035,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 nullPtr :: IO (Ptr CompletionData)
debugIO $ ":: oldDataPtr " ++ show oldDataPtr
when (oldDataPtr /= nullPtr) $
do debugIO $ "exchanged: " ++ show oldDataPtr
=====================================
libraries/base/GHC/Ptr.hs
=====================================
@@ -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
=====================================
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 `(~~)`:
=====================================
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 #) -> (# #)
=====================================
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, [''])
=====================================
testsuite/tests/codeGen/should_run/cas_int.hs
=====================================
@@ -0,0 +1,83 @@
+{-# 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)
+ -- let x = 0
+ -- exchangePtr ptr_p ptr_j
+
+ -- p <- peek ptr_p
+ -- poke p 99
+ -- -- poke ptr_j 2
+
+ -- p1 <- peek ptr_i
+ -- p2 <- peek ptr_j
+ -- print (x,p1,p2)
+
+
+ -- w1 <- newEmptyMVar :: IO (MVar Int)
+ -- forkIO $ do
+ -- v <- swapN 50000 2 ptr_i
+ -- putMVar w1 v
+
+ -- v2 <- swapN 50000 3 ptr_i
+ -- v1 <- takeMVar w1
+ -- v0 <- peek ptr_i
+ -- -- Should be [1,2,3]
+ -- print $ sort [v0,v1,v2]
+
+-- swapN :: Int -> Int -> Ptr Int -> IO Int
+-- swapN 0 val ptr = return val
+-- swapN n val ptr = do
+-- val' <- swap ptr val
+-- swapN (n-1) val' ptr
+
+
+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 #)
=====================================
testsuite/tests/codeGen/should_run/cas_int.stdout
=====================================
@@ -0,0 +1,4 @@
+Returned results:
+(1,2)
+Stored results:
+(3,2)
=====================================
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 #)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ee84b859b5561f7b04bb7122a145da81ec064cd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ee84b859b5561f7b04bb7122a145da81ec064cd
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200929/dce15a5d/attachment-0001.html>
More information about the ghc-commits
mailing list