Merge branch 'master' of http://darcs.haskell.org/testsuite
[ghc.git] / testsuite / timeout / timeout.hs
1 {-# OPTIONS -cpp #-}
2 module Main where
3
4 import Prelude hiding (catch)
5
6 import Control.Concurrent (forkIO, threadDelay)
7 import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)
8 import Control.Monad
9 import Control.Exception
10 import Data.Maybe (isNothing)
11 import System.Environment (getArgs)
12 import System.Exit
13 import System.IO (hPutStrLn, stderr)
14
15 #if !defined(mingw32_HOST_OS)
16 import System.Posix hiding (killProcess)
17 import System.IO.Error hiding (try,catch)
18 #endif
19
20 #if defined(mingw32_HOST_OS)
21 import System.Process
22 import WinCBindings
23 import Foreign
24 import System.Win32.DebugApi
25 import System.Win32.Types
26 #endif
27
28 main :: IO ()
29 main = do
30 args <- getArgs
31 case args of
32 [secs,cmd] ->
33 case reads secs of
34 [(secs', "")] -> run secs' cmd
35 _ -> die ("Can't parse " ++ show secs ++ " as a number of seconds")
36 _ -> die ("Bad arguments " ++ show args)
37
38 die :: String -> IO ()
39 die msg = do hPutStrLn stderr ("timeout: " ++ msg)
40 exitWith (ExitFailure 1)
41
42 timeoutMsg :: String
43 timeoutMsg = "Timeout happened...killing process..."
44
45 run :: Int -> String -> IO ()
46 #if !defined(mingw32_HOST_OS)
47 run secs cmd = do
48 m <- newEmptyMVar
49 mp <- newEmptyMVar
50 installHandler sigINT (Catch (putMVar m Nothing)) Nothing
51 forkIO $ do threadDelay (secs * 1000000)
52 putMVar m Nothing
53 forkIO $ do ei <- try $ do pid <- systemSession cmd
54 return pid
55 putMVar mp ei
56 case ei of
57 Left _ -> return ()
58 Right pid -> do
59 r <- getProcessStatus True False pid
60 putMVar m r
61 ei_pid_ph <- takeMVar mp
62 case ei_pid_ph of
63 Left e -> do hPutStrLn stderr
64 ("Timeout:\n" ++ show (e :: IOException))
65 exitWith (ExitFailure 98)
66 Right pid -> do
67 r <- takeMVar m
68 case r of
69 Nothing -> do
70 hPutStrLn stderr timeoutMsg
71 killProcess pid
72 exitWith (ExitFailure 99)
73 Just (Exited r) -> exitWith r
74 Just (Terminated s) -> raiseSignal s
75 Just _ -> exitWith (ExitFailure 1)
76
77 systemSession cmd =
78 forkProcess $ do
79 createSession
80 executeFile "/bin/sh" False ["-c", cmd] Nothing
81 -- need to use exec() directly here, rather than something like
82 -- System.Process.system, because we are in a forked child and some
83 -- pthread libraries get all upset if you start doing certain
84 -- things in a forked child of a pthread process, such as forking
85 -- more threads.
86
87 killProcess pid = do
88 ignoreIOExceptions (signalProcessGroup sigTERM pid)
89 checkReallyDead 10
90 where
91 checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up"
92 checkReallyDead (n+1) =
93 do threadDelay (3*100000) -- 3/10 sec
94 m <- tryJust (guard . isDoesNotExistError) $
95 getProcessStatus False False pid
96 case m of
97 Right Nothing -> return ()
98 Left _ -> return ()
99 _ -> do
100 ignoreIOExceptions (signalProcessGroup sigKILL pid)
101 checkReallyDead n
102
103 ignoreIOExceptions :: IO () -> IO ()
104 ignoreIOExceptions io = io `catch` ((\_ -> return ()) :: IOException -> IO ())
105
106 #else
107 run secs cmd =
108 let escape '\\' = "\\\\"
109 escape '"' = "\\\""
110 escape c = [c]
111 cmd' = "sh -c \"" ++ concatMap escape cmd ++ "\"" in
112 alloca $ \p_startupinfo ->
113 alloca $ \p_pi ->
114 withTString cmd' $ \cmd'' ->
115 do job <- createJobObjectW nullPtr nullPtr
116 let creationflags = 0
117 b <- createProcessW nullPtr cmd'' nullPtr nullPtr True
118 creationflags
119 nullPtr nullPtr p_startupinfo p_pi
120 unless b $ errorWin "createProcessW"
121 pi <- peek p_pi
122 assignProcessToJobObject job (piProcess pi)
123 resumeThread (piThread pi)
124
125 -- The program is now running
126
127 let handle = piProcess pi
128 let millisecs = secs * 1000
129 rc <- waitForSingleObject handle (fromIntegral millisecs)
130 if rc == cWAIT_TIMEOUT
131 then do hPutStrLn stderr timeoutMsg
132 terminateJobObject job 99
133 exitWith (ExitFailure 99)
134 else alloca $ \p_exitCode ->
135 do r <- getExitCodeProcess handle p_exitCode
136 if r then do ec <- peek p_exitCode
137 let ec' = if ec == 0
138 then ExitSuccess
139 else ExitFailure $ fromIntegral ec
140 exitWith ec'
141 else errorWin "getExitCodeProcess"
142 #endif
143