more on GHC 6.4 Debian packages

Ian Lynagh igloo at
Fri Jul 29 16:59:43 EDT 2005

On Fri, Jul 29, 2005 at 09:27:08PM +0100, Simon Marlow wrote:
> On 28 July 2005 22:42, Ian Lynagh wrote:
> > However, the timeout program tickles known bugs in Linux 2.4 on hppa
> > (and possibly unknown bugs on ia64, as discussed briefly on ghc-cvs).
> I'd still like to get your souped-up timeout program into CVS.  Would
> you like to post it?

Here's what I've currently got. I suspect the second forkIO should
really be forkOS, but it might not be necessary at all on non-buggy
systems (in which case the code can be simplified a bit).


-------------- next part --------------
{-# 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 )

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
        forkIO (do threadDelay (read secs * 1000000)
                   putMVar m Nothing
        forkIO (do try (do p <- forkProcess $ do
                               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
    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
killProcess p = do
  terminateProcess p
  threadDelay (3*100000) -- 3/10 sec
  m <- getProcessExitCode p
  when (isNothing m) $ killProcess p

More information about the Glasgow-haskell-users mailing list