Revert "rts/winio: Fix #18382"wip/andreask/unbreak_master

This commit prevents master from being built by ghc 9.0/9.2 so I will revert it for now.

This reverts commit 5a6efd218734dbb5c1350531680cd3f4177690f1.

20 files changed, 92 insertions, 31 deletions

diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index 99df92daed..d5fb4868df 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -544,6 +544,8 @@ 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
@@ -582,6 +584,7 @@ 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 4a8e4192c2..07b4ef05ab 100644
--- a/libraries/base/GHC/Conc/Sync.hs-boot
+++ b/libraries/base/GHC/Conc/Sync.hs-boot
@@ -49,6 +49,8 @@ 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 973f25722b..cc6bbaa927 100644
--- a/libraries/base/GHC/Event/Windows.hsc
+++ b/libraries/base/GHC/Event/Windows.hsc
@@ -542,19 +542,18 @@ withOverlappedEx mgr fname h async offset startCB completionCB = do
         signalThrow ex = failIfFalse_ (dbgMsg "signalThrow") $
                             writeIOPort signal (IOFailed ex)
     mask_ $ do
-      let completionCB' e b = do
-            result <- completionCB e b
-            case result of
-              IOSuccess val -> signalReturn val
-              IOFailed  err -> signalThrow err
-
+      let completionCB' e b = completionCB e b >>= \result ->
+                                case result of
+                                  IOSuccess val -> signalReturn val
+                                  IOFailed  err -> signalThrow err
+      let callbackData = CompletionData h completionCB'
       -- 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 h completionCB' $ \hs_lpol cdData -> do
+      withRequest async offset callbackData $ \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
@@ -1067,7 +1066,7 @@ processCompletion Manager{..} n delay = do
           when (oldDataPtr /= nullPtr && oldDataPtr /= castPtr nullReq) $
             do debugIO $ "exchanged: " ++ show oldDataPtr
                payload <- peek oldDataPtr :: IO CompletionData
-               cb <- deRefStablePtr (cdCallback payload)
+               let !cb = 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 c087f94eb1..c9c96d9d1e 100644
--- a/libraries/base/GHC/Event/Windows/FFI.hsc
+++ b/libraries/base/GHC/Event/Windows/FFI.hsc
@@ -231,6 +231,14 @@ 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
@@ -239,7 +247,7 @@ type IOCallback = CompletionCallback ()
 -- We keep the handle around for the benefit of ghc-external libraries making
 -- use of the manager.
 data CompletionData = CompletionData { cdHandle   :: !HANDLE
-                                     , cdCallback :: !(StablePtr IOCallback)
+                                     , cdCallback :: !IOCallback
                                      }
 
 instance Storable CompletionData where
@@ -247,13 +255,14 @@ instance Storable CompletionData where
     alignment _ = #{alignment CompletionData}
 
     peek ptr = do
-      cdCallback <- #{peek CompletionData, cdCallback} ptr
+      cdCallback <- mkIOCallback `fmap` #{peek CompletionData, cdCallback} ptr
       cdHandle   <- #{peek CompletionData, cdHandle} ptr
       let !cd = CompletionData{..}
       return cd
 
     poke ptr CompletionData{..} = do
-      #{poke CompletionData, cdCallback} ptr cdCallback
+      cb <- wrapIOCallback cdCallback
+      #{poke CompletionData, cdCallback} ptr cb
       #{poke CompletionData, cdHandle} ptr cdHandle
 
 ------------------------------------------------------------------------
@@ -393,10 +402,10 @@ pokeEventOverlapped lpol event = do
 --    the native OS Handle not the Haskell one. i.e. remote-iserv.
 
 -- See [Note AsyncHandles]
-withRequest :: Bool -> Word64 -> HANDLE -> IOCallback
+withRequest :: Bool -> Word64 -> CompletionData
             -> (Ptr HASKELL_OVERLAPPED -> Ptr CompletionData -> IO a)
             -> IO a
-withRequest async offset hdl cb f = do
+withRequest async offset cbData f =
     -- 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
@@ -408,10 +417,7 @@ withRequest async offset hdl cb f = do
     --
     -- Todo: Use a memory pool for this so we don't have to hit malloc every
     --       time.  This would allow us to scale better.
-    cb_sptr <- newStablePtr cb
-    let cbData :: CompletionData
-        cbData = CompletionData hdl cb_sptr
-    r <- allocaBytes #{size HASKELL_OVERLAPPED} $ \hs_lpol ->
+    allocaBytes #{size HASKELL_OVERLAPPED} $ \hs_lpol ->
       with cbData $ \cdData -> do
         zeroOverlapped hs_lpol
         let lpol = castPtr hs_lpol
@@ -430,9 +436,6 @@ withRequest async offset hdl cb f = do
             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 4e65d556ce..f58231688d 100644
--- a/libraries/base/tests/T18382/all.T
+++ b/libraries/base/tests/T18382/all.T
@@ -1,6 +1,7 @@
 test('T18382',
      [unless(opsys('mingw32'), skip),
       extra_run_opts('+RTS --io-manager=native -RTS'),
+      expect_broken(18382),
      ],
      compile_and_run,
      [''])
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
index 075e2a5b17..e15ae7008b 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
@@ -387,6 +387,7 @@ data WhyBlocked
   | BlockedOnCCall_Interruptible
   | BlockedOnMsgThrowTo
   | ThreadMigrating
+  | BlockedOnIOCompletion
   | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug
   deriving (Eq, Show, Generic, Ord)
 
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
index 48f99d2fcb..69c88db57d 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
+++ b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
@@ -77,7 +77,7 @@ parseWhyBlocked w = case w of
                         (#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible
                         (#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo
                         (#const ThreadMigrating) -> ThreadMigrating
-#if __GLASGOW_HASKELL__ >= 811 && __GLASGOW_HASKELL__ < 903
+#if __GLASGOW_HASKELL__ >= 811
                         (#const BlockedOnIOCompletion) -> BlockedOnIOCompletion
 #endif
                         _ -> WhyBlockedUnknownValue w
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
index e9d106d46a..17bf3c8334 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
+++ b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
@@ -77,7 +77,7 @@ parseWhyBlocked w = case w of
                         (#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible
                         (#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo
                         (#const ThreadMigrating) -> ThreadMigrating
-#if __GLASGOW_HASKELL__ >= 811 && __GLASGOW_HASKELL__ < 903
+#if __GLASGOW_HASKELL__ >= 811
                         (#const BlockedOnIOCompletion) -> BlockedOnIOCompletion
 #endif
                         _ -> WhyBlockedUnknownValue w
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 15f9e949b0..edbd435702 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -2222,7 +2222,7 @@ stg_readIOPortzh ( P_ ioport /* :: IOPort a */ )
         StgMVar_head(ioport) = q;
         StgTSO__link(CurrentTSO)       = q;
         StgTSO_block_info(CurrentTSO)  = ioport;
-        StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
+        StgTSO_why_blocked(CurrentTSO) = BlockedOnIOCompletion::I16;
 
         //Unlocks the closure as well
         jump stg_block_readmvar(ioport);
@@ -2328,8 +2328,8 @@ loop:
     // at this point.
 
     //Either there was no reader queued, or he must have been
-    //blocked on BlockedOnMVar
-    ASSERT(why_blocked == BlockedOnMVar);
+    //blocked on BlockedOnIOCompletion
+    ASSERT(why_blocked == BlockedOnIOCompletion);
 
     unlockClosure(ioport, info);
     return (1);
diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index 39f39a22b4..a0719024b4 100644
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -175,7 +175,7 @@ throwToSelf (Capability *cap, StgTSO *tso, StgClosure *exception)
      - or it is masking exceptions (TSO_BLOCKEX)
 
    Currently, if the target is BlockedOnMVar, BlockedOnSTM,
-   or BlockedOnBlackHole then we acquire ownership of the
+   BlockedOnIOCompletion or BlockedOnBlackHole then we acquire ownership of the
    TSO by locking its parent container (e.g. the MVar) and then raise the
    exception.  We might change these cases to be more message-passing-like in
    the future.
@@ -344,6 +344,7 @@ check_target:
 
     case BlockedOnMVar:
     case BlockedOnMVarRead:
+    case BlockedOnIOCompletion:
     {
         /*
           To establish ownership of this TSO, we need to acquire a
@@ -369,7 +370,8 @@ check_target:
         // we have the MVar, let's check whether the thread
         // is still blocked on the same MVar.
         if ((target->why_blocked != BlockedOnMVar
-             && target->why_blocked != BlockedOnMVarRead)
+             && target->why_blocked != BlockedOnMVarRead
+             && target->why_blocked != BlockedOnIOCompletion)
             || (StgMVar *)target->block_info.closure != mvar) {
             unlockClosure((StgClosure *)mvar, info);
             goto retry;
@@ -682,6 +684,7 @@ removeFromQueues(Capability *cap, StgTSO *tso)
 
   case BlockedOnMVar:
   case BlockedOnMVarRead:
+  case BlockedOnIOCompletion:
       removeFromMVarBlockedQueue(tso);
       goto done;
 
diff --git a/rts/Schedule.c b/rts/Schedule.c
index b9b15811c9..4fe18fa769 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -942,6 +942,7 @@ scheduleDetectDeadlock (Capability **pcap, Task *task)
          */
         if (SEQ_CST_LOAD(&recent_activity) != ACTIVITY_INACTIVE) return;
 #endif
+        if (task->incall->tso && task->incall->tso->why_blocked == BlockedOnIOCompletion) return;
 
         debugTrace(DEBUG_sched, "deadlocked, forcing major GC...");
 
@@ -979,6 +980,31 @@ scheduleDetectDeadlock (Capability **pcap, Task *task)
             return;
         }
 #endif
+
+#if !defined(THREADED_RTS)
+        /* Probably a real deadlock.  Send the current main thread the
+         * Deadlock exception.
+         */
+        if (task->incall->tso) {
+            switch (task->incall->tso->why_blocked) {
+            case BlockedOnSTM:
+            case BlockedOnBlackHole:
+            case BlockedOnMsgThrowTo:
+            case BlockedOnMVar:
+            case BlockedOnMVarRead:
+                throwToSingleThreaded(cap, task->incall->tso,
+                                      (StgClosure *)nonTermination_closure);
+                return;
+            case BlockedOnIOCompletion:
+                /* We're blocked waiting for an external I/O call, let's just
+                   chill for a bit.  */
+                return;
+            default:
+                barf("deadlock: main thread blocked in a strange way");
+            }
+        }
+        return;
+#endif
     }
 }
 
@@ -3192,6 +3218,11 @@ resurrectThreads (StgTSO *threads)
             throwToSingleThreaded(cap, tso,
                                   (StgClosure *)blockedIndefinitelyOnSTM_closure);
             break;
+        case BlockedOnIOCompletion:
+            /* I/O Ports may not be reachable by the GC as they may be getting
+             * notified by the RTS.  As such this call should be treated as if
+             * it is masking the exception.  */
+            continue;
         case NotBlocked:
             /* This might happen if the thread was blocked on a black hole
              * belonging to a thread that we've just woken up (raiseAsync
diff --git a/rts/Threads.c b/rts/Threads.c
index ab7af2e52c..b9f753234f 100644
--- a/rts/Threads.c
+++ b/rts/Threads.c
@@ -286,6 +286,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso)
 
     switch (tso->why_blocked)
     {
+    case BlockedOnIOCompletion:
     case BlockedOnMVar:
     case BlockedOnMVarRead:
     {
@@ -887,6 +888,8 @@ printThreadBlockage(StgTSO *tso)
   case BlockedOnMVarRead:
     debugBelch("is blocked on atomic MVar read @ %p", tso->block_info.closure);
     break;
+  case BlockedOnIOCompletion:
+    debugBelch("is blocked on I/O Completion port @ %p", tso->block_info.closure);
     break;
   case BlockedOnBlackHole:
       debugBelch("is blocked on a black hole %p",
diff --git a/rts/Trace.c b/rts/Trace.c
index f68a72cf2a..9edac3565e 100644
--- a/rts/Trace.c
+++ b/rts/Trace.c
@@ -183,6 +183,7 @@ static char *thread_stop_reasons[] = {
     [6 + BlockedOnSTM]          = "blocked on STM",
     [6 + BlockedOnDoProc]       = "blocked on asyncDoProc",
     [6 + BlockedOnCCall]        = "blocked on a foreign call",
+    [6 + BlockedOnIOCompletion] = "blocked on I/O Completion port",
     [6 + BlockedOnCCall_Interruptible] = "blocked on a foreign call (interruptible)",
     [6 + BlockedOnMsgThrowTo]   =  "blocked on throwTo",
     [6 + ThreadMigrating]       =  "migrating"
diff --git a/rts/TraverseHeap.c b/rts/TraverseHeap.c
index 3b92bb9f98..2285a93b6f 100644
--- a/rts/TraverseHeap.c
+++ b/rts/TraverseHeap.c
@@ -1239,6 +1239,7 @@ inner_loop:
         traversePushClosure(ts, (StgClosure *) tso->trec, c, sep, child_data);
         if (   tso->why_blocked == BlockedOnMVar
                || tso->why_blocked == BlockedOnMVarRead
+               || tso->why_blocked == BlockedOnIOCompletion
                || tso->why_blocked == BlockedOnBlackHole
                || tso->why_blocked == BlockedOnMsgThrowTo
             ) {
diff --git a/rts/include/rts/Constants.h b/rts/include/rts/Constants.h
index b601999f88..9cbe47752e 100644
--- a/rts/include/rts/Constants.h
+++ b/rts/include/rts/Constants.h
@@ -256,7 +256,13 @@
    by tryWakeupThread() */
 #define ThreadMigrating     13
 
-/* Next number is 15.  */
+/* Lightweight non-deadlock checked version of MVar.  Used for the why_blocked
+   field of a TSO. Threads blocked for this reason are not forcibly release by
+   the GC, as we expect them to be unblocked in the future based on outstanding
+   IO events.  */
+#define BlockedOnIOCompletion  15
+
+/* Next number is 16.  */
 
 /*
  * These constants are returned to the scheduler by a thread that has
diff --git a/rts/include/rts/storage/TSO.h b/rts/include/rts/storage/TSO.h
index a6bd9e9087..fcbf7f7ab1 100644
--- a/rts/include/rts/storage/TSO.h
+++ b/rts/include/rts/storage/TSO.h
@@ -304,6 +304,7 @@ void dirty_STACK (Capability *cap, StgStack *stack);
         BlockedOnBlackHole     MessageBlackHole *   TSO->bq
 
         BlockedOnMVar          the MVAR             the MVAR's queue
+        BlockedOnIOCompletion  the PortEVent        the IOCP's queue
 
         BlockedOnSTM           END_TSO_QUEUE        STM wait queue(s)
         BlockedOnSTM           STM_AWOKEN           run queue
diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c
index 3e71c30d35..43867343fc 100644
--- a/rts/sm/Compact.c
+++ b/rts/sm/Compact.c
@@ -461,6 +461,7 @@ thread_TSO (StgTSO *tso)
         || tso->why_blocked == BlockedOnMVarRead
         || tso->why_blocked == BlockedOnBlackHole
         || tso->why_blocked == BlockedOnMsgThrowTo
+        || tso->why_blocked == BlockedOnIOCompletion
         || tso->why_blocked == NotBlocked
         ) {
         thread_(&tso->block_info.closure);
diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c
index cf4e2dfea6..63ef9732dd 100644
--- a/rts/sm/Sanity.c
+++ b/rts/sm/Sanity.c
@@ -729,6 +729,7 @@ checkTSO(StgTSO *tso)
         || tso->why_blocked == BlockedOnMVarRead
         || tso->why_blocked == BlockedOnBlackHole
         || tso->why_blocked == BlockedOnMsgThrowTo
+        || tso->why_blocked == BlockedOnIOCompletion
         || tso->why_blocked == NotBlocked
         ) {
         ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->block_info.closure));
diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c
index a36ebbb331..9316f395a8 100644
--- a/rts/sm/Scav.c
+++ b/rts/sm/Scav.c
@@ -131,6 +131,7 @@ scavengeTSO (StgTSO *tso)
         || tso->why_blocked == BlockedOnMVarRead
         || tso->why_blocked == BlockedOnBlackHole
         || tso->why_blocked == BlockedOnMsgThrowTo
+        || tso->why_blocked == BlockedOnIOCompletion
         || tso->why_blocked == NotBlocked
         ) {
         evacuate(&tso->block_info.closure);
diff --git a/rts/win32/AsyncWinIO.c b/rts/win32/AsyncWinIO.c
index fa397c343d..5f61f815f3 100644
--- a/rts/win32/AsyncWinIO.c
+++ b/rts/win32/AsyncWinIO.c
@@ -24,7 +24,6 @@
 #include <stdio.h>
 
 /* Note [Non-Threaded WINIO design]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Compared to Async MIO, Async WINIO does all of the heavy processing at the
    Haskell side of things.  The same code as the threaded WINIO is re-used for
    the Non-threaded version.  Of course since we are in a non-threaded rts we
@@ -123,8 +122,10 @@
    See also Note [WINIO Manager design].
 
 
-  Note [Notifying the RTS/Haskell of completed events]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    Note [Notifying the RTS/Haskell of completed events]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
   The C side runner can't directly create a haskell thread.
   With the current API of the haskell runtime this would be terrible
   unsound. In particular the GC assumes no heap objects are generated,
@@ -136,8 +137,10 @@
   ensures there is only one OS thread at a time making use of the haskell
   heap.
 
-  Note [Non-Threaded IO Manager startup sequence]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    Note [Non-Threaded IO Manager startup sequence]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
   Under the new IO Manager we run a bit of initialization under
   hs_init(). The first call into actual IO manager code is a
   invocation of startupAsyncWinIO();