attempt to work around restrictions with fork() & pthreads
[ghc.git] / testsuite / timeout / timeout.hs
1 {-# OPTIONS -cpp #-}
2
3 import Control.Concurrent (forkIO, threadDelay)
4 import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)
5 import Control.Exception (try)
6 import Data.Maybe (isNothing)
7 import System.Cmd (system)
8 import System.Environment (getArgs)
9 import System.Exit (exitWith, ExitCode(ExitFailure))
10 import System.IO (hPutStrLn, stderr)
11 import System.Process
12 import Control.Monad (when)
13 #if !defined(mingw32_HOST_OS)
14 import System.Process.Internals (mkProcessHandle)
15 import System.Posix.Process (forkProcess, createSession, executeFile)
16 import System.Posix.Signals (installHandler, Handler(Catch),
17 signalProcessGroup, sigINT, sigTERM, sigKILL )
18 #endif
19
20
21
22 #if !defined(mingw32_HOST_OS)
23 main = do
24 args <- getArgs
25 case args of
26 [secs,cmd] -> do
27 m <- newEmptyMVar
28 mp <- newEmptyMVar
29 installHandler sigINT (Catch (putMVar m Nothing)) Nothing
30 forkIO (do threadDelay (read secs * 1000000)
31 putMVar m Nothing
32 )
33 forkIO (do try (do pid <- systemSession cmd
34 ph <- mkProcessHandle pid
35 putMVar mp (pid,ph)
36 r <- waitForProcess ph
37 putMVar m (Just r))
38 return ())
39
40 (pid,ph) <- takeMVar mp
41 r <- takeMVar m
42 case r of
43 Nothing -> do
44 killProcess pid ph
45 exitWith (ExitFailure 99)
46 Just r -> do
47 exitWith r
48 _other -> do hPutStrLn stderr "timeout: bad arguments"
49 exitWith (ExitFailure 1)
50
51 systemSession cmd =
52 forkProcess $ do
53 createSession
54 executeFile "/bin/sh" False ["-c", cmd] Nothing
55 -- need to use exec() directly here, rather than something like
56 -- System.Process.system, because we are in a forked child and some
57 -- pthread libraries get all upset if you start doing certain
58 -- things in a forked child of a pthread process, such as forking
59 -- more threads.
60
61 killProcess pid ph = do
62 try (signalProcessGroup sigTERM pid)
63 checkReallyDead 10
64 where
65 checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up"
66 checkReallyDead (n+1) =
67 do threadDelay (3*100000) -- 3/10 sec
68 m <- getProcessExitCode ph
69 when (isNothing m) $ do
70 try (signalProcessGroup sigKILL pid)
71 checkReallyDead n
72
73 #else
74
75 main = do
76 args <- getArgs
77 case args of
78 [secs,cmd] -> do
79 m <- newEmptyMVar
80 mp <- newEmptyMVar
81 forkIO (do threadDelay (read secs * 1000000)
82 putMVar m Nothing
83 )
84 forkIO (do p <- runCommand cmd
85 putMVar mp p
86 r <- waitForProcess p
87 putMVar m (Just r))
88 p <- takeMVar mp
89 r <- takeMVar m
90 case r of
91 Nothing -> do
92 killProcess p
93 exitWith (ExitFailure 99)
94 Just r -> do
95 exitWith r
96 _other -> do hPutStrLn stderr "timeout: bad arguments"
97 exitWith (ExitFailure 1)
98
99 killProcess p = do
100 terminateProcess p
101 -- ToDo: we should kill the process and its descendents on Win32
102 threadDelay (3*100000) -- 3/10 sec
103 m <- getProcessExitCode p
104 when (isNothing m) $ killProcess p
105
106 #endif