From 5c640c3112220f47c56130e37c8ffaffea14f90d Mon Sep 17 00:00:00 2001 From: sof Date: Wed, 17 Nov 2004 19:07:38 +0000 Subject: [PATCH] [project @ 2004-11-17 19:07:38 by sof] Expose Win32 console event handling to the user. Added RTS support for registering and delivering console events quite a while ago (rts/win32/ConsoleHandler.c), but got bored with it before completing the job. Here's the concluding commit; it does the following: - new module, base/GHC/ConsoleHandler.hs which supports registering of console event handlers (the null module on plats other than mingw). - special handling of aborted async read()s on 'standard input' in rts/win32/IOManager.c (together with GHC.Conc.asyncRead). See comments in that IOManager.c as to why this is needed. [ Any other code that performs blocking I/O on 'standard input' will need to be tweaked too to be console event handler/signal friendly.] - for now, disable the delivery of 'close' events (see rts/win32/ConsoleHandler.c:generic_handler() for reasons why) Feel free to hoik GHC/ConsoleHandler.hs around the lib hierarchy to wherever is considered more fitting. Unifying functionality between System.Posix.Signals and GHC.ConsoleHandler is one (obvious) thing to do. -- Demonstrating GHC.ConsoleHandler use; win32 only module Main(main) where import GHC.ConsoleHandler import System.IO (hFlush, stdout) import GHC.Conc (threadDelay) main :: IO () main = do installHandler (Catch (\ _ -> putStrLn "Caught console event; ignoring" >> hFlush stdout)) loop where loop = do threadDelay 100000 ls <- getLine putStrLn ls loop -- --- GHC/Conc.lhs | 11 +++++-- GHC/ConsoleHandler.hs | 88 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 96 insertions(+), 3 deletions(-) create mode 100644 GHC/ConsoleHandler.hs diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index e3bfae2..6488074 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -280,9 +280,14 @@ addMVarFinalizer (MVar m) finalizer = -- in which they're used doesn't cause problems on a Win32 platform though.) asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) -asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) = - IO $ \s -> case asyncRead# fd isSock len buf s of - (# s, len#, err# #) -> (# s, (I# len#, I# err#) #) +asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) = do + (l, rc) <- IO (\s -> case asyncRead# fd isSock len buf s of + (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)) + -- special handling for Ctrl+C-aborted 'standard input' reads; + -- see rts/win32/ConsoleHandler.c for details. + if (l == 0 && rc == -2) + then asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) + else return (l,rc) asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) = diff --git a/GHC/ConsoleHandler.hs b/GHC/ConsoleHandler.hs new file mode 100644 index 0000000..70128b4 --- /dev/null +++ b/GHC/ConsoleHandler.hs @@ -0,0 +1,88 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.ConsoleHandler +-- Copyright : whatevah +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Installing Win32 console handlers. +-- +----------------------------------------------------------------------------- +module GHC.ConsoleHandler +#ifndef mingw32_TARGET_OS + where +#else /* whole file */ + ( Handler(..) + , installHandler + , ConsoleEvent(..) + ) where + +{- +#include "Signals.h" +-} + +import Foreign +import Foreign.C + +data Handler + = Default + | Ignore + | Catch (ConsoleEvent -> IO ()) + +data ConsoleEvent + = ControlC + | Break + | Close + -- these are sent to Services only. + | Logoff + | Shutdown + +installHandler :: Handler -> IO Handler +installHandler handler = + alloca $ \ p_sp -> do + rc <- + case handler of + Default -> rts_installHandler STG_SIG_DFL p_sp + Ignore -> rts_installHandler STG_SIG_IGN p_sp + Catch h -> do + v <- newStablePtr (toHandler h) + poke p_sp v + rts_installHandler STG_SIG_HAN p_sp + case rc of + STG_SIG_DFL -> return Default + STG_SIG_IGN -> return Ignore + STG_SIG_HAN -> do + osptr <- peek p_sp + oldh <- deRefStablePtr osptr + -- stable pointer is no longer in use, free it. + 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-} + Break -> 1 {- CTRL_BREAK_EVENT-} + Close -> 2 {- CTRL_CLOSE_EVENT-} + Logoff -> 5 {- CTRL_LOGOFF_EVENT-} + Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-} + + toHandler hdlr ev = do + case toConsoleEvent ev of + Just x -> hdlr x + Nothing -> return () -- silently ignore.. + +foreign import ccall unsafe "Signals.h stg_InstallConsoleEvent" + rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt +#endif /* mingw32_TARGET_OS */ -- 1.7.10.4