Fix some "warn-unused-do-bind" warnings where we want to ignore the value

[ghc-base.git] / GHC / TopHandler.lhs

diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs
index 6a2520a..ffc62f9 100644 (file)
--- a/GHC/TopHandler.lhs
+++ b/GHC/TopHandler.lhs
@@ -28,6 +28,7 @@ module GHC.TopHandler (
 
 import Control.Exception
 import Data.Maybe
+import Data.Dynamic (toDyn)
 
 import Foreign
 import Foreign.C
@@ -35,8 +36,11 @@ import GHC.Base
 import GHC.Conc hiding (throwTo)
 import GHC.Num
 import GHC.Real
-import GHC.Handle
-import GHC.IOBase
+import GHC.MVar
+import GHC.IO
+import GHC.IO.Handle.FD
+import GHC.IO.Handle
+import GHC.IO.Exception
 import GHC.Weak
 import Data.Typeable
 #if defined(mingw32_HOST_OS)
@@ -79,27 +83,18 @@ install_interrupt_handler handler = do
 -- isn't available here.
 install_interrupt_handler handler = do
    let sig = CONST_SIGINT :: CInt
-   withSignalHandlerLock $
-     alloca $ \p_sp -> do
-       sptr <- newStablePtr handler
-       poke p_sp sptr
-       stg_sig_install sig STG_SIG_RST p_sp nullPtr
-       return ()
-
-withSignalHandlerLock :: IO () -> IO ()
-withSignalHandlerLock io
- = block $ do
-       takeMVar signalHandlerLock
-       catchAny (unblock io) (\e -> do putMVar signalHandlerLock (); throw e)
-       putMVar signalHandlerLock ()
+   setHandler sig (Just (const handler, toDyn handler))
+   stg_sig_install sig STG_SIG_RST nullPtr
+     -- STG_SIG_RST: the second ^C kills us for real, just in case the
+     -- RTS or program is unresponsive.
+   return ()
 
 foreign import ccall unsafe
   stg_sig_install
        :: CInt                         -- sig no.
        -> CInt                         -- action code (STG_SIG_HAN etc.)
-       -> Ptr (StablePtr (IO ()))      -- (in, out) Haskell handler
        -> Ptr ()                       -- (in, out) blocked
-       -> IO CInt                      -- (ret) action code
+       -> IO CInt                      -- (ret) old action code
 #endif
 
 -- make a weak pointer to a ThreadId: holding the weak pointer doesn't