diff options
author | Andreas Klebinger <klebinger.andreas@gmx.at> | 2020-09-25 15:58:36 +0200 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2020-11-30 18:56:35 -0500 |
commit | 824332c47098bcf5031050e1c2807686f3fbf214 (patch) | |
tree | f4c10437cd01219d0c986d68f73177a0560d35e8 | |
parent | cb365f512cb6ed88c56f10d7529ebbfdf4ad84dc (diff) | |
download | haskell-824332c47098bcf5031050e1c2807686f3fbf214.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.
(cherry picked from commit 401a64b80fb210fa1b403afe5b28d16f961f21bc)
-rw-r--r-- | compiler/GHC/CmmToAsm/X86/CodeGen.hs | 2 | ||||
-rw-r--r-- | libraries/base/GHC/Event/Internal.hs | 16 | ||||
-rw-r--r-- | libraries/base/GHC/Event/Windows.hsc | 6 | ||||
-rw-r--r-- | libraries/base/GHC/Ptr.hs | 12 | ||||
-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 |
7 files changed, 80 insertions, 15 deletions
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index 22735e5756..2cce508a00 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -2625,6 +2625,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/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs index 2ed8d2e66c..32609b478b 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 (atomicExchangeAddrAddr# 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 aa340ae02f..1d81819e2f 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)] diff --git a/libraries/base/GHC/Ptr.hs b/libraries/base/GHC/Ptr.hs index 612d3ef94b..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 (atomicExchangeAddrAddr# dst val s) of - (# s2, old_val #) -> (# s2, Ptr old_val #) - ------------------------------------------------------------------------- -- Show instances for Ptr and FunPtr -- | @since 2.01 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) |