From e225c624c6bc7099da8e2092d76563e43b7ba3f2 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Fri, 22 Apr 2005 17:00:49 +0000
Subject: [PATCH] [project @ 2005-04-22 17:00:49 by sof] [mingw only] Better
 handling of I/O request abortions upon throwing an exception to a Haskell
 thread. As was, a thread blocked on an I/O request was simply unblocked, but
 its corresponding worker thread wasn't notified that the request had been
 abandoned.

This manifested itself in GHCi upon Ctrl-C being hit at the prompt -- the
worker thread blocked waiting for input on stdin prior to Ctrl-C would
stick around even though its corresponding Haskell thread had been
thrown an Interrupted exception. The upshot was that the worker would
consume the next character typed in after Ctrl-C, but then just dropping
it. Dealing with this turned out to be even more interesting due to
Win32 aborting any console reads when Ctrl-C/Break events are delivered.

The story could be improved upon (at the cost of portability) by making
the Scheduler able to abort worker thread system calls; as is, requests
are cooperatively abandoned. Maybe later.

Also included are other minor tidyups to Ctrl-C handling under mingw.

Merge to STABLE.
---
 GHC/ConsoleHandler.hs | 8 ++++++--
 1 file changed, 6 insertions(+), 2 deletions(-)

diff --git a/GHC/ConsoleHandler.hs b/GHC/ConsoleHandler.hs
index 945be3c5..77ea7b44 100644
--- a/GHC/ConsoleHandler.hs
+++ b/GHC/ConsoleHandler.hs
@@ -84,9 +84,13 @@ installHandler handler =
 
    toHandler hdlr ev = do
       case toConsoleEvent ev of
-        Just x  -> hdlr x
+	 -- see rts/win32/ConsoleHandler.c for comments as to why
+	 -- rts_ConsoleHandlerDone is called here.
+        Just x  -> hdlr x >> rts_ConsoleHandlerDone ev
 	Nothing -> return () -- silently ignore..
 
-foreign import ccall unsafe "Signals.h stg_InstallConsoleEvent" 
+foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent" 
   rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
+foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
+  rts_ConsoleHandlerDone :: CInt -> IO ()
 #endif /* mingw32_HOST_OS */
-- 
GitLab