rts/winio: Fix #18382

Here we refactor WinIO's IO completion scheme, squashing a memory leak
and fixing #18382.
To fix #18382 we drop the special thread status introduced for IoPort
blocking, BlockedOnIoCompletion, as well as drop the non-threaded RTS's
special dead-lock detection logic (which is redundant to the GC's
deadlock detection logic), as proposed in #20947.

Previously WinIO relied on foreign import ccall "wrapper" to create an
adjustor thunk which can be attached to the OVERLAPPED structure passed
to the operating system. It would then use foreign import ccall
"dynamic" to back out the original continuation from the adjustor. This
roundtrip is significantly more expensive than the alternative, using a
StablePtr. Furthermore, the implementation let the adjustor leak,
meaning that every IO request would leak a page of memory.

Fixes T18382.

5 files changed, 20 insertions, 28 deletions

diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index d5fb4868df..99df92daed 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -544,8 +544,6 @@ data BlockReason
         -- ^blocked in 'retry' in an STM transaction
   | BlockedOnForeignCall
         -- ^currently in a foreign call
-  | BlockedOnIOCompletion
-        -- ^currently blocked on an I/O Completion port
   | BlockedOnOther
         -- ^blocked on some other resource.  Without @-threaded@,
         -- I\/O and 'Control.Concurrent.threadDelay' show up as
@@ -584,7 +582,6 @@ threadStatus (ThreadId t) = IO $ \s ->
      mk_stat 11 = ThreadBlocked BlockedOnForeignCall
      mk_stat 12 = ThreadBlocked BlockedOnException
      mk_stat 14 = ThreadBlocked BlockedOnMVar -- possibly: BlockedOnMVarRead
-     mk_stat 15 = ThreadBlocked BlockedOnIOCompletion
      -- NB. these are hardcoded in rts/PrimOps.cmm
      mk_stat 16 = ThreadFinished
      mk_stat 17 = ThreadDied
diff --git a/libraries/base/GHC/Conc/Sync.hs-boot b/libraries/base/GHC/Conc/Sync.hs-boot
index 07b4ef05ab..4a8e4192c2 100644
--- a/libraries/base/GHC/Conc/Sync.hs-boot
+++ b/libraries/base/GHC/Conc/Sync.hs-boot
@@ -49,8 +49,6 @@ data BlockReason
               -- ^blocked in 'retry' in an STM transaction
         | BlockedOnForeignCall
               -- ^currently in a foreign call
-        | BlockedOnIOCompletion
-              -- ^currently blocked on an I/O Completion port
         | BlockedOnOther
               -- ^blocked on some other resource.  Without @-threaded@,
               -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc
index cc6bbaa927..973f25722b 100644
--- a/libraries/base/GHC/Event/Windows.hsc
+++ b/libraries/base/GHC/Event/Windows.hsc
@@ -542,18 +542,19 @@ withOverlappedEx mgr fname h async offset startCB completionCB = do
         signalThrow ex = failIfFalse_ (dbgMsg "signalThrow") $
                             writeIOPort signal (IOFailed ex)
     mask_ $ do
-      let completionCB' e b = completionCB e b >>= \result ->
-                                case result of
-                                  IOSuccess val -> signalReturn val
-                                  IOFailed  err -> signalThrow err
-      let callbackData = CompletionData h completionCB'
+      let completionCB' e b = do
+            result <- completionCB e b
+            case result of
+              IOSuccess val -> signalReturn val
+              IOFailed  err -> signalThrow err
+
       -- Note [Memory Management]
       -- These callback data and especially the overlapped structs have to keep
       -- alive throughout the entire lifetime of the requests.   Since this
       -- function will block until done so it can call completionCB at the end
       -- we can safely use dynamic memory management here and so reduce the
       -- possibility of memory errors.
-      withRequest async offset callbackData $ \hs_lpol cdData -> do
+      withRequest async offset h completionCB' $ \hs_lpol cdData -> do
         let ptr_lpol = hs_lpol `plusPtr` cdOffset
         let lpol = castPtr hs_lpol
         -- We need to add the payload before calling startCBResult, the reason being
@@ -1066,7 +1067,7 @@ processCompletion Manager{..} n delay = do
           when (oldDataPtr /= nullPtr && oldDataPtr /= castPtr nullReq) $
             do debugIO $ "exchanged: " ++ show oldDataPtr
                payload <- peek oldDataPtr :: IO CompletionData
-               let !cb = cdCallback payload
+               cb <- deRefStablePtr (cdCallback payload)
                reqs <- removeRequest
                debugIO $ "-1.. " ++ show reqs ++ " requests queued."
                status <- FFI.overlappedIOStatus (lpOverlapped oe)
diff --git a/libraries/base/GHC/Event/Windows/FFI.hsc b/libraries/base/GHC/Event/Windows/FFI.hsc
index c9c96d9d1e..c087f94eb1 100644
--- a/libraries/base/GHC/Event/Windows/FFI.hsc
+++ b/libraries/base/GHC/Event/Windows/FFI.hsc
@@ -231,14 +231,6 @@ type CompletionCallback a = ErrCode   -- ^ 0 indicates success
 -- | Callback type that will be called when an I/O operation completes.
 type IOCallback = CompletionCallback ()
 
--- | Wrap the IOCallback type into a FunPtr.
-foreign import ccall "wrapper"
-  wrapIOCallback :: IOCallback -> IO (FunPtr IOCallback)
-
--- | Unwrap a FunPtr IOCallback to a normal Haskell function.
-foreign import ccall "dynamic"
-  mkIOCallback :: FunPtr IOCallback -> IOCallback
-
 -- | Structure that the I/O manager uses to associate callbacks with
 -- additional payload such as their OVERLAPPED structure and Win32 handle
 -- etc.  *Must* be kept in sync with that in `winio_structs.h` or horrible things
@@ -247,7 +239,7 @@ foreign import ccall "dynamic"
 -- We keep the handle around for the benefit of ghc-external libraries making
 -- use of the manager.
 data CompletionData = CompletionData { cdHandle   :: !HANDLE
-                                     , cdCallback :: !IOCallback
+                                     , cdCallback :: !(StablePtr IOCallback)
                                      }
 
 instance Storable CompletionData where
@@ -255,14 +247,13 @@ instance Storable CompletionData where
     alignment _ = #{alignment CompletionData}
 
     peek ptr = do
-      cdCallback <- mkIOCallback `fmap` #{peek CompletionData, cdCallback} ptr
+      cdCallback <- #{peek CompletionData, cdCallback} ptr
       cdHandle   <- #{peek CompletionData, cdHandle} ptr
       let !cd = CompletionData{..}
       return cd
 
     poke ptr CompletionData{..} = do
-      cb <- wrapIOCallback cdCallback
-      #{poke CompletionData, cdCallback} ptr cb
+      #{poke CompletionData, cdCallback} ptr cdCallback
       #{poke CompletionData, cdHandle} ptr cdHandle
 
 ------------------------------------------------------------------------
@@ -402,10 +393,10 @@ pokeEventOverlapped lpol event = do
 --    the native OS Handle not the Haskell one. i.e. remote-iserv.
 
 -- See [Note AsyncHandles]
-withRequest :: Bool -> Word64 -> CompletionData
+withRequest :: Bool -> Word64 -> HANDLE -> IOCallback
             -> (Ptr HASKELL_OVERLAPPED -> Ptr CompletionData -> IO a)
             -> IO a
-withRequest async offset cbData f =
+withRequest async offset hdl cb f = do
     -- Create the completion record and store it.
     -- We only need the record when we enqueue a request, however if we
     -- delay creating it then we will run into a race condition where the
@@ -417,7 +408,10 @@ withRequest async offset cbData f =
     --
     -- Todo: Use a memory pool for this so we don't have to hit malloc every
     --       time.  This would allow us to scale better.
-    allocaBytes #{size HASKELL_OVERLAPPED} $ \hs_lpol ->
+    cb_sptr <- newStablePtr cb
+    let cbData :: CompletionData
+        cbData = CompletionData hdl cb_sptr
+    r <- allocaBytes #{size HASKELL_OVERLAPPED} $ \hs_lpol ->
       with cbData $ \cdData -> do
         zeroOverlapped hs_lpol
         let lpol = castPtr hs_lpol
@@ -436,6 +430,9 @@ withRequest async offset cbData f =
             failIfFalse_ "withRequest (free)" $ c_CloseHandle event
             return res
 
+    freeStablePtr cb_sptr
+    return r
+
 
 -- | Create an event object for use when the HANDLE isn't asynchronous
 foreign import WINDOWS_CCONV unsafe "windows.h CreateEventW"
diff --git a/libraries/base/tests/T18382/all.T b/libraries/base/tests/T18382/all.T
index f58231688d..4e65d556ce 100644
--- a/libraries/base/tests/T18382/all.T
+++ b/libraries/base/tests/T18382/all.T
@@ -1,7 +1,6 @@
 test('T18382',
      [unless(opsys('mingw32'), skip),
       extra_run_opts('+RTS --io-manager=native -RTS'),
-      expect_broken(18382),
      ],
      compile_and_run,
      [''])