We need to tell Cabal that WinCBindings is a module of the timeout program
[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
10 import System.IO (hPutStrLn, stderr)
11 import System.Process
12 import Control.Monad
13
14 #if !defined(mingw32_HOST_OS)
15 import System.Process.Internals (mkProcessHandle)
16 import System.Posix.Process (forkProcess, createSession, executeFile)
17 import System.Posix.Signals (installHandler, Handler(Catch),
18 signalProcessGroup, sigINT, sigTERM, sigKILL )
19 #endif
20
21 #if defined(mingw32_HOST_OS)
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] -> run (read secs) cmd
33 _ -> do hPutStrLn stderr $ "timeout: bad arguments " ++ show args
34 exitWith (ExitFailure 1)
35
36 timeoutMsg :: String
37 timeoutMsg = "Timeout happened...killing process..."
38
39 run :: Int -> String -> IO ()
40 #if !defined(mingw32_HOST_OS)
41 run secs cmd = do
42 m <- newEmptyMVar
43 mp <- newEmptyMVar
44 installHandler sigINT (Catch (putMVar m Nothing)) Nothing
45 forkIO (do threadDelay (secs * 1000000)
46 putMVar m Nothing
47 )
48 forkIO (do try (do pid <- systemSession cmd
49 ph <- mkProcessHandle pid
50 putMVar mp (pid,ph)
51 r <- waitForProcess ph
52 putMVar m (Just r))
53 return ())
54
55 (pid,ph) <- takeMVar mp
56 r <- takeMVar m
57 case r of
58 Nothing -> do
59 hPutStrLn stderr timeoutMsg
60 killProcess pid ph
61 exitWith (ExitFailure 99)
62 Just r -> do
63 exitWith r
64
65 systemSession cmd =
66 forkProcess $ do
67 createSession
68 executeFile "/bin/sh" False ["-c", cmd] Nothing
69 -- need to use exec() directly here, rather than something like
70 -- System.Process.system, because we are in a forked child and some
71 -- pthread libraries get all upset if you start doing certain
72 -- things in a forked child of a pthread process, such as forking
73 -- more threads.
74
75 killProcess pid ph = do
76 try (signalProcessGroup sigTERM pid)
77 checkReallyDead 10
78 where
79 checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up"
80 checkReallyDead (n+1) =
81 do threadDelay (3*100000) -- 3/10 sec
82 m <- getProcessExitCode ph
83 when (isNothing m) $ do
84 try (signalProcessGroup sigKILL pid)
85 checkReallyDead n
86
87 #else
88 run secs cmd =
89 alloca $ \p_startupinfo ->
90 alloca $ \p_pi ->
91 withTString ("sh -c \"" ++ cmd ++ "\"") $ \cmd' ->
92 do job <- createJobObjectW nullPtr nullPtr
93 let creationflags = 0
94 b <- createProcessW nullPtr cmd' nullPtr nullPtr True
95 creationflags
96 nullPtr nullPtr p_startupinfo p_pi
97 unless b $ errorWin "createProcessW"
98 pi <- peek p_pi
99 assignProcessToJobObject job (piProcess pi)
100 resumeThread (piThread pi)
101
102 -- The program is now running
103
104 let handle = piProcess pi
105 let millisecs = secs * 1000
106 rc <- waitForSingleObject handle (fromIntegral millisecs)
107 if rc == cWAIT_TIMEOUT
108 then do hPutStrLn stderr timeoutMsg
109 terminateJobObject job 99
110 exitWith (ExitFailure 99)
111 else alloca $ \p_exitCode ->
112 do r <- getExitCodeProcess handle p_exitCode
113 if r then do ec <- peek p_exitCode
114 let ec' = if ec == 0
115 then ExitSuccess
116 else ExitFailure $ fromIntegral ec
117 exitWith ec'
118 else errorWin "getExitCodeProcess"
119 #endif
120