From 202065fe56bd604d26d1924cbc9c0959266ca7ea Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Thu, 7 Apr 2005 14:33:32 +0000
Subject: [PATCH] [project @ 2005-04-07 14:33:31 by simonmar] Support handling
 signals in the threaded RTS by passing the signal number
 down the pipe to the IO manager.  This avoids needing
 synchronisation in the signal handler.

Signals should now work with -threaded.  Since this is a bugfix, I'll
merge the changes into the 6.4 branch.
---
 GHC/Conc.lhs            |   40 ++++++++++++++++++++++++++++++++--------
 System/Posix/Signals.hs |    2 ++
 2 files changed, 34 insertions(+), 8 deletions(-)

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 8476498..f56cf61 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -68,6 +68,10 @@ module GHC.Conc
 	, asyncReadBA   -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
 	, asyncWriteBA  -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
 #endif
+
+#ifndef mingw32_HOST_OS
+	, ensureIOManagerIsRunning
+#endif
         ) where
 
 import System.Posix.Types
@@ -524,20 +528,26 @@ pendingDelays :: IORef [DelayReq]
 {-# NOINLINE pendingEvents #-}
 {-# NOINLINE pendingDelays #-}
 (pendingEvents,pendingDelays) = unsafePerformIO $ do
-  startIOServiceThread
+  startIOManagerThread
   reqs <- newIORef []
   dels <- newIORef []
   return (reqs, dels)
 	-- the first time we schedule an IO request, the service thread
 	-- will be created (cool, huh?)
 
-startIOServiceThread :: IO ()
-startIOServiceThread = do
+ensureIOManagerIsRunning :: IO ()
+ensureIOManagerIsRunning 
+  | threaded  = seq pendingEvents $ return ()
+  | otherwise = return ()
+
+startIOManagerThread :: IO ()
+startIOManagerThread = do
         allocaArray 2 $ \fds -> do
-	throwErrnoIfMinus1 "startIOServiceThread" (c_pipe fds)
+	throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)
 	rd_end <- peekElemOff fds 0
 	wr_end <- peekElemOff fds 1
 	writeIORef stick (fromIntegral wr_end)
+	c_setIOManagerPipe wr_end
 	quickForkIO $ do
 	    allocaBytes sizeofFdSet   $ \readfds -> do
 	    allocaBytes sizeofFdSet   $ \writefds -> do 
@@ -595,9 +605,17 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
   (res,delays') <- do_select delays
   -- ToDo: check result
 
-  b <- takeMVar prodding
-  if b then alloca $ \p -> do c_read (fromIntegral wakeup) p 1; return ()
-       else return ()
+  b <- fdIsSet wakeup readfds
+  if b == 0 
+    then return ()
+    else alloca $ \p -> do 
+	    c_read (fromIntegral wakeup) p 1; return ()
+	    s <- peek p		
+	    if (s == 0xff) 
+	      then return ()
+	      else c_startSignalHandler (fromIntegral s)
+
+  takeMVar prodding
   putMVar prodding False
 
   reqs' <- completeRequests reqs readfds writefds []
@@ -616,10 +634,16 @@ prodServiceThread = do
   b <- takeMVar prodding
   if (not b) 
     then do fd <- readIORef stick
-	    with 42 $ \pbuf -> do c_write (fromIntegral fd) pbuf 1; return ()
+	    with 0xff $ \pbuf -> do c_write (fromIntegral fd) pbuf 1; return ()
     else return ()
   putMVar prodding True
 
+foreign import ccall unsafe "startSignalHandler"
+  c_startSignalHandler :: CInt -> IO ()
+
+foreign import ccall "setIOManagerPipe"
+  c_setIOManagerPipe :: CInt -> IO ()
+
 -- -----------------------------------------------------------------------------
 -- IO requests
 
diff --git a/System/Posix/Signals.hs b/System/Posix/Signals.hs
index 0392b05..4393c64 100644
--- a/System/Posix/Signals.hs
+++ b/System/Posix/Signals.hs
@@ -98,6 +98,7 @@ import Prelude -- necessary to get dependencies right
 
 #ifdef __GLASGOW_HASKELL__
 #include "Signals.h"
+import GHC.Conc	( ensureIOManagerIsRunning )
 #endif
 
 import Foreign
@@ -306,6 +307,7 @@ installHandler =
 #else
 
 installHandler int handler maybe_mask = do
+    ensureIOManagerIsRunning  -- for the threaded RTS
     case maybe_mask of
 	Nothing -> install' nullPtr
         Just (SignalSet x) -> withForeignPtr x $ install' 
-- 
1.7.10.4