From 7f530103a6da6e386984f9bc8b0ff2b4d97821d9 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Tue, 4 Dec 2007 15:39:40 +0000 Subject: [PATCH] protect console handler against concurrent access (#1922) --- GHC/Conc.lhs | 62 ++++++++++++++++++++++++++++++++++++------------- GHC/ConsoleHandler.hs | 48 +++++++++++++++++++++++--------------- 2 files changed, 75 insertions(+), 35 deletions(-) diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index 142115c..233c1f9 100644 --- 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 --- 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" -- 1.7.10.4