Hi,
The timeout program in the testsuite doesn't seem to work correctly for
me. If I run the okeefe_neural test with a timeout of 10s then the tests
are aborted, but the ghc-6.5 processes aren't killed, leaving me with 7
of them working away when it finishes.
I've attached a replacement that does work for me. It makes a new
process group for the test, and kills that group rather than a single
process when a timeout happens. Annoyingly I can't seem to write it
without resorting to some C - in order to run createSession in a fork I
have to get a ProcessID, but waitForProcess wants a ProcessHandle. I
can't see a way to convert one to the other, nor a waitpid wrapper
working on ProcessIDs.
I don't think this will work on Windows, but driver/testlib.py doesn't
use it on Windows anyway, so this doesn't look like a problem.
Is it OK to commit this?
Thanks
Ian
TOP = ..
include $(TOP)/mk/boilerplate.mk
HC = $(GHC_INPLACE)
MKDEPENDHS = $(GHC_INPLACE)
SRC_HC_OPTS += -threaded -package unix
HS_PROG = timeout
boot :: $(HS_PROG)
include $(TOP)/mk/target.mk
#include "timeout.h"
int mywaitpid(pid_t pid) {
int status;
waitpid(pid, &status, 0);
if (WIFEXITED(status)) {
return WEXITSTATUS(status);
}
else {
return 99;
}
}
#include <sys/types.h>
#include <sys/wait.h>
int mywaitpid(pid_t pid);
{-# OPTIONS_GHC -fffi #-}
import Control.Concurrent
import System.Environment
import System.Process
import System.Exit
import Foreign.C.Types
import System.Posix.Signals
import System.Posix.Types
import System.IO
import System.Posix.Process (forkProcess, createSession)
import System.Cmd (system)
main = do
args <- getArgs
case args of
[secs,cmd] -> do
p <- forkProcess $ do createSession
r <- system cmd
exitWith r
m <- newEmptyMVar
forkIO (do threadDelay (read secs * 1000000)
putMVar m Nothing
)
forkIO (do r <- waitpid p
putMVar m (Just (fromIntegral r)))
r <- takeMVar m
case r of
Nothing -> do signalProcessGroup sigTERM p
exitWith (ExitFailure 99)
Just 0 -> exitWith ExitSuccess
Just r -> exitWith (ExitFailure r)
_other -> do hPutStrLn stderr "timeout: bad arguments"
exitWith (ExitFailure 1)
foreign import ccall "timeout.h mywaitpid" waitpid :: CPid -> IO CInt
_______________________________________________
Cvs-fptools mailing list
[EMAIL PROTECTED]
http://www.haskell.org/mailman/listinfo/cvs-fptools
