protect console handler against concurrent access (#1922)

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 142115c..233c1f9 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -85,6 +85,12 @@ module GHC.Conc
 #endif
 
        , ensureIOManagerIsRunning
+
+#ifdef mingw32_HOST_OS
+        , ConsoleEvent(..)
+        , win32ConsoleHandler
+        , toWin32ConsoleEvent
+#endif
         ) where
 
 import System.Posix.Types
@@ -107,6 +113,10 @@ import GHC.Real            ( fromIntegral, div )
 #ifndef mingw32_HOST_OS
 import GHC.Base                ( Int(..) )
 #endif
+#ifdef mingw32_HOST_OS
+import GHC.Read         ( Read )
+import GHC.Enum         ( Enum )
+#endif
 import GHC.Exception
 import GHC.Pack                ( packCString# )
 import GHC.Ptr          ( Ptr(..), plusPtr, FunPtr(..) )
@@ -561,6 +571,15 @@ isEmptyMVar (MVar mv#) = IO $ \ s# ->
 addMVarFinalizer :: MVar a -> IO () -> IO ()
 addMVarFinalizer (MVar m) finalizer = 
   IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
+
+withMVar :: MVar a -> (a -> IO b) -> IO b
+withMVar m io = 
+  block $ do
+    a <- takeMVar m
+    b <- catchException (unblock (io a))
+           (\e -> do putMVar m a; throw e)
+    putMVar m a
+    return b
 \end{code}
 
 
@@ -821,14 +840,34 @@ service_cont wakeup delays = do
 io_MANAGER_WAKEUP = 0xffffffff :: Word32
 io_MANAGER_DIE    = 0xfffffffe :: Word32
 
-start_console_handler :: Word32 -> IO ()
-start_console_handler r = do                   
-  stableptr <- peek console_handler
-  forkIO $ do io <- deRefStablePtr stableptr; io (fromIntegral r)
-  return ()
+data ConsoleEvent
+ = ControlC
+ | Break
+ | Close
+    -- these are sent to Services only.
+ | Logoff
+ | Shutdown
+ deriving (Eq, Ord, Enum, Show, Read, Typeable)
 
-foreign import ccall "&console_handler" 
-   console_handler :: Ptr (StablePtr (CInt -> IO ()))
+start_console_handler :: Word32 -> IO ()
+start_console_handler r =
+  case toWin32ConsoleEvent r of
+     Just x  -> withMVar win32ConsoleHandler $ \handler -> do
+                    forkIO (handler x)
+                    return ()
+     Nothing -> return ()
+
+toWin32ConsoleEvent ev = 
+   case ev of
+       0 {- CTRL_C_EVENT-}        -> Just ControlC
+       1 {- CTRL_BREAK_EVENT-}    -> Just Break
+       2 {- CTRL_CLOSE_EVENT-}    -> Just Close
+       5 {- CTRL_LOGOFF_EVENT-}   -> Just Logoff
+       6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
+       _ -> Nothing
+
+win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
+win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
 
 stick :: IORef HANDLE
 {-# NOINLINE stick #-}
@@ -978,15 +1017,6 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
 
   service_loop wakeup readfds writefds ptimeval reqs' delays'
 
-withMVar :: MVar a -> (a -> IO b) -> IO b
-withMVar m io = 
-  block $ do
-    a <- takeMVar m
-    b <- catchException (unblock (io a))
-           (\e -> do putMVar m a; throw e)
-    putMVar m a
-    return b
-
 io_MANAGER_WAKEUP = 0xff :: CChar
 io_MANAGER_DIE    = 0xfe :: CChar
 

diff --git a/GHC/ConsoleHandler.hs b/GHC/ConsoleHandler.hs
index 3c3d2f4..42ec54f 100644 (file)
--- a/GHC/ConsoleHandler.hs
+++ b/GHC/ConsoleHandler.hs
@@ -35,23 +35,16 @@ import Prelude -- necessary to get dependencies right
 import Foreign
 import Foreign.C
 import GHC.IOBase
+import GHC.Conc
 import GHC.Handle
 import Data.Typeable
+import Control.Concurrent
 
 data Handler
  = Default
  | Ignore
  | Catch (ConsoleEvent -> IO ())
 
-data ConsoleEvent
- = ControlC
- | Break
- | Close
-    -- these are sent to Services only.
- | Logoff
- | Shutdown
- deriving (Eq, Ord, Enum, Show, Read, Typeable)
-
 -- | Allows Windows console events to be caught and handled.  To
 -- handle a console event, call 'installHandler' passing the
 -- appropriate 'Handler' value.  When the event is received, if the
@@ -72,7 +65,28 @@ data ConsoleEvent
 -- it in one of these environments.
 --
 installHandler :: Handler -> IO Handler
-installHandler handler = 
+installHandler handler 
+  | threaded =
+    modifyMVar win32ConsoleHandler $ \old_h -> do
+      (new_h,rc) <- 
+        case handler of
+          Default -> do
+            r <- rts_installHandler STG_SIG_DFL nullPtr
+            return (no_handler, r)
+          Ignore  -> do
+            r <- rts_installHandler STG_SIG_IGN nullPtr
+            return (no_handler, r)
+          Catch h -> do
+            r <- rts_installHandler STG_SIG_HAN nullPtr
+            return (h, r)
+      prev_handler <- 
+        case rc of
+          STG_SIG_DFL -> return Default
+          STG_SIG_IGN -> return Ignore
+          STG_SIG_HAN -> return (Catch old_h)
+      return (new_h, prev_handler)
+
+  | otherwise =
   alloca $ \ p_sp -> do
    rc <- 
     case handler of
@@ -92,14 +106,6 @@ installHandler handler =
        freeStablePtr osptr
        return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
   where
-   toConsoleEvent ev = 
-     case ev of
-       0 {- CTRL_C_EVENT-}        -> Just ControlC
-       1 {- CTRL_BREAK_EVENT-}    -> Just Break
-       2 {- CTRL_CLOSE_EVENT-}    -> Just Close
-       5 {- CTRL_LOGOFF_EVENT-}   -> Just Logoff
-       6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
-       _ -> Nothing
    fromConsoleEvent ev = 
      case ev of
        ControlC -> 0 {- CTRL_C_EVENT-}
@@ -109,12 +115,16 @@ installHandler handler =
        Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
 
    toHandler hdlr ev = do
-      case toConsoleEvent ev of
+      case toWin32ConsoleEvent ev of
         -- 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..
 
+   no_handler = error "win32ConsoleHandler"
+
+foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
+
 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"