[project @ 2005-08-04 12:22:17 by simonmar]

A better timeout.  This one starts a new session for the child
process, and attempts to kill the entire group when the time expires
(previously we only killed the direct child, if the child itself had
spawned more processes these would continue to run).

The new scheme is only for Unix, presumably we have to do something
different on Windows.

Code partly from Ian Lynagh.

2 files changed, 73 insertions, 25 deletions

diff --git a/testsuite/timeout/Makefile b/testsuite/timeout/Makefile
index 9d438fa8c6..06281e04cb 100644
--- a/testsuite/timeout/Makefile
+++ b/testsuite/timeout/Makefile
@@ -5,6 +5,10 @@ HC = $(GHC_INPLACE)
 MKDEPENDHS = $(GHC_INPLACE)
 SRC_HC_OPTS += -threaded
 
+ifeq "$(Windows)" "NO"
+SRC_HC_OPTS += -package unix
+endif
+
 HS_PROG = timeout
 
 boot :: $(HS_PROG)
diff --git a/testsuite/timeout/timeout.hs b/testsuite/timeout/timeout.hs
index 21a58a430a..904ea93506 100644
--- a/testsuite/timeout/timeout.hs
+++ b/testsuite/timeout/timeout.hs
@@ -1,25 +1,69 @@
-import Control.Concurrent
-import System.Environment
-import System.Process
-import System.Exit
-
-main = do
-  args <- getArgs
-  case args of 
-    [secs,cmd] -> do
-	p <- runCommand cmd
-	m <- newEmptyMVar
-	forkIO (do threadDelay (read secs * 1000000)
-		   putMVar m Nothing
-	       )
-	forkIO (do r <- waitForProcess p
-		   putMVar m (Just r))
-	r <- takeMVar m
-	case r of
-	  Nothing -> do
-		terminateProcess p
-		exitWith (ExitFailure 99)	
-	  Just r -> do
-		exitWith r
-    _other -> exitWith (ExitFailure 1)
-
+{-# OPTIONS -cpp #-}

+

+import Control.Concurrent (forkIO, threadDelay)

+import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)

+import Control.Exception (try)

+import Data.Maybe (isNothing)

+import System.Cmd (system)

+import System.Environment (getArgs)

+import System.Exit (exitWith, ExitCode(ExitFailure))

+import System.IO (hPutStrLn, stderr)

+import System.Process (waitForProcess, getProcessExitCode)

+#if !defined(mingw32_HOST_OS)

+import Control.Monad (when)

+import System.Process.Internals (ProcessHandle(ProcessHandle))

+import System.Posix.Process (forkProcess, createSession)

+import System.Posix.Signals (installHandler, Handler(Catch),

+                             signalProcessGroup, sigINT, sigTERM, sigKILL )

+#endif

+

+main = do

+  args <- getArgs

+  case args of 

+    [secs,cmd] -> do

+        m <- newEmptyMVar

+        mp <- newEmptyMVar

+#if !defined(mingw32_HOST_OS)

+        installHandler sigINT (Catch (putMVar m Nothing)) Nothing

+#endif

+        forkIO (do threadDelay (read secs * 1000000)

+                   putMVar m Nothing

+               )

+        forkIO (do try (do p <- forkProcess $ do

+                               createSession

+                               r <- system cmd

+                               exitWith r

+                           putMVar mp p

+                           r <- waitForProcess (ProcessHandle p)

+                           putMVar m (Just r))

+                   return ())

+        p <- takeMVar mp

+        r <- takeMVar m

+        case r of

+          Nothing -> do

+                killProcess p

+                exitWith (ExitFailure 99)

+          Just r -> do

+                exitWith r

+    _other -> do hPutStrLn stderr "timeout: bad arguments"

+                 exitWith (ExitFailure 1)

+

+#if !defined(mingw32_HOST_OS)

+killProcess p = do

+  try (signalProcessGroup sigTERM p)

+  checkReallyDead 10

+  where

+    checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up"

+    checkReallyDead (n+1) =

+      do threadDelay (3*100000) -- 3/10 sec

+         m <- getProcessExitCode (ProcessHandle p)

+         when (isNothing m) $ do

+             try (signalProcessGroup sigKILL p)

+             checkReallyDead n

+#else

+killProcess p = do

+  terminateProcess p

+  threadDelay (3*100000) -- 3/10 sec

+  m <- getProcessExitCode p

+  when (isNothing m) $ killProcess p

+#endif