[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
--

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index e3bfae2..6488074 100644 (file)
--- 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 (file)
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 */