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.

4 files changed, 24 insertions, 20 deletions

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 `(~~)`: