Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
GHC
Manage
Activity
Members
Labels
Plan
Issues
0
Issue boards
Milestones
Wiki
Requirements
Code
Merge requests
0
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Locked files
Build
Pipelines
Jobs
Pipeline schedules
Test cases
Artifacts
Deploy
Releases
Package Registry
Container Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Code review analytics
Issue analytics
Insights
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Benjamin Maurer
GHC
Commits
2f6124c3
Commit
2f6124c3
authored
4 years ago
by
Ben Gamari
Browse files
Options
Downloads
Patches
Plain Diff
testsuite: Rewrite timeout
parent
7550417a
Branches
wip/timeout-rewrite
No related tags found
No related merge requests found
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
testsuite/timeout/WinCBindings.hsc
+0
-397
0 additions, 397 deletions
testsuite/timeout/WinCBindings.hsc
testsuite/timeout/timeout.cabal
+3
-7
3 additions, 7 deletions
testsuite/timeout/timeout.cabal
testsuite/timeout/timeout.hs
+42
-131
42 additions, 131 deletions
testsuite/timeout/timeout.hs
with
45 additions
and
535 deletions
testsuite/timeout/WinCBindings.hsc
deleted
100644 → 0
+
0
−
397
View file @
7550417a
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
module WinCBindings where
#if defined(mingw32_HOST_OS)
##if defined(i386_HOST_ARCH)
## define WINDOWS_CCONV stdcall
##elif defined(x86_64_HOST_ARCH)
## define WINDOWS_CCONV ccall
##else
## error Unknown mingw32 arch
##endif
import Foreign
import Foreign.C.Types
import System.Win32.File
import System.Win32.Types
#include <windows.h>
type LPPROCESS_INFORMATION = Ptr PROCESS_INFORMATION
data PROCESS_INFORMATION = PROCESS_INFORMATION
{ piProcess :: HANDLE
, piThread :: HANDLE
, piProcessId :: DWORD
, piThreadId :: DWORD
} deriving Show
instance Storable PROCESS_INFORMATION where
sizeOf = const #size PROCESS_INFORMATION
alignment = sizeOf
poke buf pi = do
(#poke PROCESS_INFORMATION, hProcess) buf (piProcess pi)
(#poke PROCESS_INFORMATION, hThread) buf (piThread pi)
(#poke PROCESS_INFORMATION, dwProcessId) buf (piProcessId pi)
(#poke PROCESS_INFORMATION, dwThreadId) buf (piThreadId pi)
peek buf = do
vhProcess <- (#peek PROCESS_INFORMATION, hProcess) buf
vhThread <- (#peek PROCESS_INFORMATION, hThread) buf
vdwProcessId <- (#peek PROCESS_INFORMATION, dwProcessId) buf
vdwThreadId <- (#peek PROCESS_INFORMATION, dwThreadId) buf
return $ PROCESS_INFORMATION {
piProcess = vhProcess,
piThread = vhThread,
piProcessId = vdwProcessId,
piThreadId = vdwThreadId}
type LPSTARTUPINFO = Ptr STARTUPINFO
data STARTUPINFO = STARTUPINFO
{ siCb :: DWORD
, siDesktop :: LPTSTR
, siTitle :: LPTSTR
, siX :: DWORD
, siY :: DWORD
, siXSize :: DWORD
, siYSize :: DWORD
, siXCountChars :: DWORD
, siYCountChars :: DWORD
, siFillAttribute :: DWORD
, siFlags :: DWORD
, siShowWindow :: WORD
, siStdInput :: HANDLE
, siStdOutput :: HANDLE
, siStdError :: HANDLE
} deriving Show
instance Storable STARTUPINFO where
sizeOf = const #size STARTUPINFO
alignment = sizeOf
poke buf si = do
(#poke STARTUPINFO, cb) buf (siCb si)
(#poke STARTUPINFO, lpDesktop) buf (siDesktop si)
(#poke STARTUPINFO, lpTitle) buf (siTitle si)
(#poke STARTUPINFO, dwX) buf (siX si)
(#poke STARTUPINFO, dwY) buf (siY si)
(#poke STARTUPINFO, dwXSize) buf (siXSize si)
(#poke STARTUPINFO, dwYSize) buf (siYSize si)
(#poke STARTUPINFO, dwXCountChars) buf (siXCountChars si)
(#poke STARTUPINFO, dwYCountChars) buf (siYCountChars si)
(#poke STARTUPINFO, dwFillAttribute) buf (siFillAttribute si)
(#poke STARTUPINFO, dwFlags) buf (siFlags si)
(#poke STARTUPINFO, wShowWindow) buf (siShowWindow si)
(#poke STARTUPINFO, hStdInput) buf (siStdInput si)
(#poke STARTUPINFO, hStdOutput) buf (siStdOutput si)
(#poke STARTUPINFO, hStdError) buf (siStdError si)
peek buf = do
vcb <- (#peek STARTUPINFO, cb) buf
vlpDesktop <- (#peek STARTUPINFO, lpDesktop) buf
vlpTitle <- (#peek STARTUPINFO, lpTitle) buf
vdwX <- (#peek STARTUPINFO, dwX) buf
vdwY <- (#peek STARTUPINFO, dwY) buf
vdwXSize <- (#peek STARTUPINFO, dwXSize) buf
vdwYSize <- (#peek STARTUPINFO, dwYSize) buf
vdwXCountChars <- (#peek STARTUPINFO, dwXCountChars) buf
vdwYCountChars <- (#peek STARTUPINFO, dwYCountChars) buf
vdwFillAttribute <- (#peek STARTUPINFO, dwFillAttribute) buf
vdwFlags <- (#peek STARTUPINFO, dwFlags) buf
vwShowWindow <- (#peek STARTUPINFO, wShowWindow) buf
vhStdInput <- (#peek STARTUPINFO, hStdInput) buf
vhStdOutput <- (#peek STARTUPINFO, hStdOutput) buf
vhStdError <- (#peek STARTUPINFO, hStdError) buf
return $ STARTUPINFO {
siCb = vcb,
siDesktop = vlpDesktop,
siTitle = vlpTitle,
siX = vdwX,
siY = vdwY,
siXSize = vdwXSize,
siYSize = vdwYSize,
siXCountChars = vdwXCountChars,
siYCountChars = vdwYCountChars,
siFillAttribute = vdwFillAttribute,
siFlags = vdwFlags,
siShowWindow = vwShowWindow,
siStdInput = vhStdInput,
siStdOutput = vhStdOutput,
siStdError = vhStdError}
data JOBOBJECT_EXTENDED_LIMIT_INFORMATION = JOBOBJECT_EXTENDED_LIMIT_INFORMATION
{ jeliBasicLimitInformation :: JOBOBJECT_BASIC_LIMIT_INFORMATION
, jeliIoInfo :: IO_COUNTERS
, jeliProcessMemoryLimit :: SIZE_T
, jeliJobMemoryLimit :: SIZE_T
, jeliPeakProcessMemoryUsed :: SIZE_T
, jeliPeakJobMemoryUsed :: SIZE_T
} deriving Show
instance Storable JOBOBJECT_EXTENDED_LIMIT_INFORMATION where
sizeOf = const #size JOBOBJECT_EXTENDED_LIMIT_INFORMATION
alignment = const #alignment JOBOBJECT_EXTENDED_LIMIT_INFORMATION
poke buf jeli = do
(#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, BasicLimitInformation) buf (jeliBasicLimitInformation jeli)
(#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, IoInfo) buf (jeliIoInfo jeli)
(#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, ProcessMemoryLimit) buf (jeliProcessMemoryLimit jeli)
(#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, JobMemoryLimit) buf (jeliJobMemoryLimit jeli)
(#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, PeakProcessMemoryUsed) buf (jeliPeakProcessMemoryUsed jeli)
(#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, PeakJobMemoryUsed) buf (jeliPeakJobMemoryUsed jeli)
peek buf = do
vBasicLimitInformation <- (#peek JOBOBJECT_EXTENDED_LIMIT_INFORMATION, BasicLimitInformation) buf
vIoInfo <- (#peek JOBOBJECT_EXTENDED_LIMIT_INFORMATION, IoInfo) buf
vProcessMemoryLimit <- (#peek JOBOBJECT_EXTENDED_LIMIT_INFORMATION, ProcessMemoryLimit) buf
vJobMemoryLimit <- (#peek JOBOBJECT_EXTENDED_LIMIT_INFORMATION, JobMemoryLimit) buf
vPeakProcessMemoryUsed <- (#peek JOBOBJECT_EXTENDED_LIMIT_INFORMATION, PeakProcessMemoryUsed) buf
vPeakJobMemoryUsed <- (#peek JOBOBJECT_EXTENDED_LIMIT_INFORMATION, PeakJobMemoryUsed) buf
return $ JOBOBJECT_EXTENDED_LIMIT_INFORMATION {
jeliBasicLimitInformation = vBasicLimitInformation,
jeliIoInfo = vIoInfo,
jeliProcessMemoryLimit = vProcessMemoryLimit,
jeliJobMemoryLimit = vJobMemoryLimit,
jeliPeakProcessMemoryUsed = vPeakProcessMemoryUsed,
jeliPeakJobMemoryUsed = vPeakJobMemoryUsed}
type ULONGLONG = #type ULONGLONG
data IO_COUNTERS = IO_COUNTERS
{ icReadOperationCount :: ULONGLONG
, icWriteOperationCount :: ULONGLONG
, icOtherOperationCount :: ULONGLONG
, icReadTransferCount :: ULONGLONG
, icWriteTransferCount :: ULONGLONG
, icOtherTransferCount :: ULONGLONG
} deriving Show
instance Storable IO_COUNTERS where
sizeOf = const #size IO_COUNTERS
alignment = const #alignment IO_COUNTERS
poke buf ic = do
(#poke IO_COUNTERS, ReadOperationCount) buf (icReadOperationCount ic)
(#poke IO_COUNTERS, WriteOperationCount) buf (icWriteOperationCount ic)
(#poke IO_COUNTERS, OtherOperationCount) buf (icOtherOperationCount ic)
(#poke IO_COUNTERS, ReadTransferCount) buf (icReadTransferCount ic)
(#poke IO_COUNTERS, WriteTransferCount) buf (icWriteTransferCount ic)
(#poke IO_COUNTERS, OtherTransferCount) buf (icOtherTransferCount ic)
peek buf = do
vReadOperationCount <- (#peek IO_COUNTERS, ReadOperationCount) buf
vWriteOperationCount <- (#peek IO_COUNTERS, WriteOperationCount) buf
vOtherOperationCount <- (#peek IO_COUNTERS, OtherOperationCount) buf
vReadTransferCount <- (#peek IO_COUNTERS, ReadTransferCount) buf
vWriteTransferCount <- (#peek IO_COUNTERS, WriteTransferCount) buf
vOtherTransferCount <- (#peek IO_COUNTERS, OtherTransferCount) buf
return $ IO_COUNTERS {
icReadOperationCount = vReadOperationCount,
icWriteOperationCount = vWriteOperationCount,
icOtherOperationCount = vOtherOperationCount,
icReadTransferCount = vReadTransferCount,
icWriteTransferCount = vWriteTransferCount,
icOtherTransferCount = vOtherTransferCount}
data JOBOBJECT_BASIC_LIMIT_INFORMATION = JOBOBJECT_BASIC_LIMIT_INFORMATION
{ jbliPerProcessUserTimeLimit :: LARGE_INTEGER
, jbliPerJobUserTimeLimit :: LARGE_INTEGER
, jbliLimitFlags :: DWORD
, jbliMinimumWorkingSetSize :: SIZE_T
, jbliMaximumWorkingSetSize :: SIZE_T
, jbliActiveProcessLimit :: DWORD
, jbliAffinity :: ULONG_PTR
, jbliPriorityClass :: DWORD
, jbliSchedulingClass :: DWORD
} deriving Show
instance Storable JOBOBJECT_BASIC_LIMIT_INFORMATION where
sizeOf = const #size JOBOBJECT_BASIC_LIMIT_INFORMATION
alignment = const #alignment JOBOBJECT_BASIC_LIMIT_INFORMATION
poke buf jbli = do
(#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, PerProcessUserTimeLimit) buf (jbliPerProcessUserTimeLimit jbli)
(#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, PerJobUserTimeLimit) buf (jbliPerJobUserTimeLimit jbli)
(#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, LimitFlags) buf (jbliLimitFlags jbli)
(#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, MinimumWorkingSetSize) buf (jbliMinimumWorkingSetSize jbli)
(#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, MaximumWorkingSetSize) buf (jbliMaximumWorkingSetSize jbli)
(#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, ActiveProcessLimit) buf (jbliActiveProcessLimit jbli)
(#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, Affinity) buf (jbliAffinity jbli)
(#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, PriorityClass) buf (jbliPriorityClass jbli)
(#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, SchedulingClass) buf (jbliSchedulingClass jbli)
peek buf = do
vPerProcessUserTimeLimit <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, PerProcessUserTimeLimit) buf
vPerJobUserTimeLimit <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, PerJobUserTimeLimit) buf
vLimitFlags <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, LimitFlags) buf
vMinimumWorkingSetSize <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, MinimumWorkingSetSize) buf
vMaximumWorkingSetSize <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, MaximumWorkingSetSize) buf
vActiveProcessLimit <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, ActiveProcessLimit) buf
vAffinity <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, Affinity) buf
vPriorityClass <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, PriorityClass) buf
vSchedulingClass <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, SchedulingClass) buf
return $ JOBOBJECT_BASIC_LIMIT_INFORMATION {
jbliPerProcessUserTimeLimit = vPerProcessUserTimeLimit,
jbliPerJobUserTimeLimit = vPerJobUserTimeLimit,
jbliLimitFlags = vLimitFlags,
jbliMinimumWorkingSetSize = vMinimumWorkingSetSize,
jbliMaximumWorkingSetSize = vMaximumWorkingSetSize,
jbliActiveProcessLimit = vActiveProcessLimit,
jbliAffinity = vAffinity,
jbliPriorityClass = vPriorityClass,
jbliSchedulingClass = vSchedulingClass}
data JOBOBJECT_ASSOCIATE_COMPLETION_PORT = JOBOBJECT_ASSOCIATE_COMPLETION_PORT
{ jacpCompletionKey :: PVOID
, jacpCompletionPort :: HANDLE
} deriving Show
instance Storable JOBOBJECT_ASSOCIATE_COMPLETION_PORT where
sizeOf = const #size JOBOBJECT_ASSOCIATE_COMPLETION_PORT
alignment = const #alignment JOBOBJECT_ASSOCIATE_COMPLETION_PORT
poke buf jacp = do
(#poke JOBOBJECT_ASSOCIATE_COMPLETION_PORT, CompletionKey) buf (jacpCompletionKey jacp)
(#poke JOBOBJECT_ASSOCIATE_COMPLETION_PORT, CompletionPort) buf (jacpCompletionPort jacp)
peek buf = do
vCompletionKey <- (#peek JOBOBJECT_ASSOCIATE_COMPLETION_PORT, CompletionKey) buf
vCompletionPort <- (#peek JOBOBJECT_ASSOCIATE_COMPLETION_PORT, CompletionPort) buf
return $ JOBOBJECT_ASSOCIATE_COMPLETION_PORT {
jacpCompletionKey = vCompletionKey,
jacpCompletionPort = vCompletionPort}
foreign import WINDOWS_CCONV unsafe "windows.h WaitForSingleObject"
waitForSingleObject :: HANDLE -> DWORD -> IO DWORD
type JOBOBJECTINFOCLASS = CInt
type PVOID = Ptr ()
type PULONG_PTR = Ptr ULONG_PTR
jobObjectExtendedLimitInformation :: JOBOBJECTINFOCLASS
jobObjectExtendedLimitInformation = #const JobObjectExtendedLimitInformation
jobObjectAssociateCompletionPortInformation :: JOBOBJECTINFOCLASS
jobObjectAssociateCompletionPortInformation = #const JobObjectAssociateCompletionPortInformation
cJOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE :: DWORD
cJOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE = #const JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE
cJOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO :: DWORD
cJOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO = #const JOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO
cJOB_OBJECT_MSG_EXIT_PROCESS :: DWORD
cJOB_OBJECT_MSG_EXIT_PROCESS = #const JOB_OBJECT_MSG_EXIT_PROCESS
cJOB_OBJECT_MSG_NEW_PROCESS :: DWORD
cJOB_OBJECT_MSG_NEW_PROCESS = #const JOB_OBJECT_MSG_NEW_PROCESS
cWAIT_ABANDONED :: DWORD
cWAIT_ABANDONED = #const WAIT_ABANDONED
cWAIT_OBJECT_0 :: DWORD
cWAIT_OBJECT_0 = #const WAIT_OBJECT_0
cWAIT_TIMEOUT :: DWORD
cWAIT_TIMEOUT = #const WAIT_TIMEOUT
cCREATE_SUSPENDED :: DWORD
cCREATE_SUSPENDED = #const CREATE_SUSPENDED
cHANDLE_FLAG_INHERIT :: DWORD
cHANDLE_FLAG_INHERIT = #const HANDLE_FLAG_INHERIT
foreign import WINDOWS_CCONV unsafe "windows.h GetExitCodeProcess"
getExitCodeProcess :: HANDLE -> LPDWORD -> IO BOOL
foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle"
closeHandle :: HANDLE -> IO BOOL
foreign import WINDOWS_CCONV unsafe "windows.h TerminateJobObject"
terminateJobObject :: HANDLE -> UINT -> IO BOOL
foreign import WINDOWS_CCONV unsafe "windows.h AssignProcessToJobObject"
assignProcessToJobObject :: HANDLE -> HANDLE -> IO BOOL
foreign import WINDOWS_CCONV unsafe "windows.h CreateJobObjectW"
createJobObjectW :: LPSECURITY_ATTRIBUTES -> LPCTSTR -> IO HANDLE
foreign import WINDOWS_CCONV unsafe "windows.h CreateProcessW"
createProcessW :: LPCTSTR -> LPTSTR
-> LPSECURITY_ATTRIBUTES -> LPSECURITY_ATTRIBUTES
-> BOOL -> DWORD -> LPVOID -> LPCTSTR -> LPSTARTUPINFO
-> LPPROCESS_INFORMATION -> IO BOOL
foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a)
foreign import WINDOWS_CCONV unsafe "windows.h SetInformationJobObject"
setInformationJobObject :: HANDLE -> JOBOBJECTINFOCLASS -> LPVOID -> DWORD -> IO BOOL
foreign import WINDOWS_CCONV unsafe "windows.h CreateIoCompletionPort"
createIoCompletionPort :: HANDLE -> HANDLE -> ULONG_PTR -> DWORD -> IO HANDLE
foreign import WINDOWS_CCONV unsafe "windows.h GetQueuedCompletionStatus"
getQueuedCompletionStatus :: HANDLE -> LPDWORD -> PULONG_PTR -> Ptr LPOVERLAPPED -> DWORD -> IO BOOL
foreign import WINDOWS_CCONV unsafe "windows.h SetHandleInformation"
setHandleInformation :: HANDLE -> DWORD -> DWORD -> IO BOOL
setJobParameters :: HANDLE -> IO BOOL
setJobParameters hJob = alloca $ \p_jeli -> do
let jeliSize = sizeOf (undefined :: JOBOBJECT_EXTENDED_LIMIT_INFORMATION)
_ <- memset p_jeli 0 $ fromIntegral jeliSize
-- Configure all child processes associated with the job to terminate when the
-- last handle to the job is closed. This prevent half dead processes and that
-- hanging ghc-iserv.exe process that happens when you interrupt the testsuite.
(#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, BasicLimitInformation.LimitFlags)
p_jeli cJOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE
setInformationJobObject hJob jobObjectExtendedLimitInformation
p_jeli (fromIntegral jeliSize)
createCompletionPort :: HANDLE -> IO HANDLE
createCompletionPort hJob = do
ioPort <- createIoCompletionPort iNVALID_HANDLE_VALUE nullPtr 0 1
if ioPort == nullPtr
then do err_code <- getLastError
putStrLn $ "CreateIoCompletionPort error: " ++ show err_code
return nullPtr
else with (JOBOBJECT_ASSOCIATE_COMPLETION_PORT {
jacpCompletionKey = hJob,
jacpCompletionPort = ioPort}) $ \p_Port -> do
res <- setInformationJobObject hJob jobObjectAssociateCompletionPortInformation
(castPtr p_Port) (fromIntegral (sizeOf (undefined :: JOBOBJECT_ASSOCIATE_COMPLETION_PORT)))
if res
then return ioPort
else do err_code <- getLastError
putStrLn $ "SetInformation, error: " ++ show err_code
return nullPtr
waitForJobCompletion :: HANDLE -> HANDLE -> DWORD -> IO BOOL
waitForJobCompletion hJob ioPort timeout
= alloca $ \p_CompletionCode ->
alloca $ \p_CompletionKey ->
alloca $ \p_Overlapped -> do
-- getQueuedCompletionStatus is a blocking call,
-- it will wake up for each completion event. So if it's
-- not the one we want, sleep again.
let loop :: IO ()
loop = do
res <- getQueuedCompletionStatus ioPort p_CompletionCode p_CompletionKey
p_Overlapped timeout
case res of
False -> return ()
True -> do
completionCode <- peek p_CompletionCode
if completionCode == cJOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO
then return ()
else if completionCode == cJOB_OBJECT_MSG_EXIT_PROCESS
then loop -- Debug point, do nothing for now
else if completionCode == cJOB_OBJECT_MSG_NEW_PROCESS
then loop -- Debug point, do nothing for now
else loop
loop -- Kick it all off
overlapped <- peek p_Overlapped
code <- peek $ p_CompletionCode
return $ if overlapped == nullPtr && code /= cJOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO
then False -- Timeout occurred. *dark voice* YOU HAVE FAILED THIS TEST!.
else True
#endif
This diff is collapsed.
Click to expand it.
testsuite/timeout/timeout.cabal
+
3
−
7
View file @
2f6124c3
...
...
@@ -2,8 +2,8 @@ Name: timeout
Version: 1
Copyright: GHC Team
License: BSD3
Author: GHC Team <
cvs-ghc
@haskell.org>
Maintainer: GHC Team <
cvs-ghc
@haskell.org>
Author: GHC Team <
ghc-devs
@haskell.org>
Maintainer: GHC Team <
ghc-devs
@haskell.org>
Synopsis: timeout utility
Description: timeout utility
Category: Development
...
...
@@ -12,11 +12,7 @@ cabal-version: >=1.2
Executable timeout
Main-Is: timeout.hs
Other-Modules: WinCBindings
Extensions: CPP
Ghc-Options: -threaded
Build-Depends: base, process
if os(windows)
Build-Depends: Win32
else
Build-Depends: unix
This diff is collapsed.
Click to expand it.
testsuite/timeout/timeout.hs
+
42
−
131
View file @
2f6124c3
...
...
@@ -3,27 +3,15 @@
module
Main
where
import
Control.Concurrent
(
forkIO
,
threadDelay
)
import
Control.Concurrent.MVar
(
putMVar
,
takeMVar
,
newEmptyMVar
)
import
Control.Concurrent.MVar
import
Control.Monad
import
Control.Exception
import
Data.Maybe
(
isNothing
)
import
System.Environment
(
getArgs
)
import
System.Exit
import
System.Process
import
System.IO
(
hPutStrLn
,
stderr
)
#
if
!
defined
(
mingw32_HOST_OS
)
import
System.Posix
hiding
(
killProcess
)
import
System.IO.Error
hiding
(
try
,
catch
)
#
endif
#
if
defined
(
mingw32_HOST_OS
)
import
System.Process
import
WinCBindings
import
Foreign
import
System.Win32.DebugApi
import
System.Win32.Types
import
System.Win32.Console.CtrlHandler
#
endif
main
::
IO
()
main
=
do
...
...
@@ -35,22 +23,40 @@ main = do
_
->
die
(
"Can't parse "
++
show
secs
++
" as a number of seconds"
)
_
->
die
(
"Bad arguments "
++
show
args
)
data
FinishedReason
=
TimedOut
|
Exited
ExitCode
|
InterruptedSignal
|
OtherError
SomeException
run
::
Int
->
String
->
IO
()
#
if
!
defined
(
mingw32_HOST_OS
)
run
secs
cmd
=
do
m
<-
newEmptyMVar
mp
<-
newEmptyMVar
installHandler
sigINT
(
Catch
(
putMVar
m
Nothing
))
Nothing
forkIO
$
do
threadDelay
(
secs
*
1000000
)
putMVar
m
Nothing
forkIO
$
do
ei
<-
try
$
do
pid
<-
systemSession
cmd
return
pid
putMVar
mp
ei
case
ei
of
Left
_
->
return
()
Right
pid
->
do
r
<-
getProcessStatus
True
False
pid
putMVar
m
r
m
<-
newEmptyMVar
::
IO
(
MVar
FinishedReason
)
mp
<-
newEmptyMVar
::
IO
(
MVar
(
Either
IOException
ProcessHandle
))
-- The timeout thread
forkIO
$
do
threadDelay
(
secs
*
1000000
)
putMVar
m
TimedOut
-- the process itself
forkIO
$
handle
(
\
exc
->
putMVar
mp
$
Left
(
userError
$
show
(
exc
::
SomeException
)))
$
do
ei
<-
fmap
(
fmap
(
\
(
_
,
_
,
_
,
ph
)
->
ph
))
$
try
$
createProcess
(
shell
cmd
)
{
new_session
=
True
,
use_process_jobs
=
True
}
putMVar
mp
ei
case
ei
of
Left
_
->
return
()
Right
pid
->
do
r
<-
waitForProcess
pid
putMVar
m
(
Exited
r
)
-- Be sure to catch SIGINT while waiting
let
handleINT
UserInterrupt
=
putMVar
m
InterruptedSignal
handleINT
other
=
throwIO
other
handle
handleINT
$
do
ei_pid_ph
<-
takeMVar
mp
case
ei_pid_ph
of
Left
e
->
do
hPutStrLn
stderr
...
...
@@ -59,107 +65,12 @@ run secs cmd = do
Right
pid
->
do
r
<-
takeMVar
m
case
r
of
Nothing
->
do
killProcess
pid
exitWith
(
ExitFailure
99
)
Just
(
Exited
r
)
->
exitWith
r
Just
(
Terminated
s
)
->
raiseSignal
s
Just
_
->
exitWith
(
ExitFailure
1
)
systemSession
cmd
=
forkProcess
$
do
createSession
executeFile
"/bin/sh"
False
[
"-c"
,
cmd
]
Nothing
-- need to use exec() directly here, rather than something like
-- System.Process.system, because we are in a forked child and some
-- pthread libraries get all upset if you start doing certain
-- things in a forked child of a pthread process, such as forking
-- more threads.
killProcess
pid
=
do
ignoreIOExceptions
(
signalProcessGroup
sigTERM
pid
)
checkReallyDead
10
where
checkReallyDead
0
=
hPutStrLn
stderr
"checkReallyDead: Giving up"
checkReallyDead
(
n
+
1
)
=
do
threadDelay
(
3
*
100000
)
-- 3/10 sec
m
<-
tryJust
(
guard
.
isDoesNotExistError
)
$
getProcessStatus
False
False
pid
case
m
of
Right
Nothing
->
return
()
Left
_
->
return
()
_
->
do
ignoreIOExceptions
(
signalProcessGroup
sigKILL
pid
)
checkReallyDead
n
ignoreIOExceptions
::
IO
()
->
IO
()
ignoreIOExceptions
io
=
io
`
catch
`
((
\
_
->
return
()
)
::
IOException
->
IO
()
)
#
else
run
secs
cmd
=
let
escape
'
\\
'
=
"
\\\\
"
escape
'"'
=
"
\\\"
"
escape
c
=
[
c
]
cmd'
=
"sh -c
\"
"
++
concatMap
escape
cmd
++
"
\"
"
in
alloca
$
\
p_startupinfo
->
alloca
$
\
p_pi
->
withTString
cmd'
$
\
cmd''
->
do
job
<-
createJobObjectW
nullPtr
nullPtr
b_info
<-
setJobParameters
job
unless
b_info
$
errorWin
"setJobParameters"
ioPort
<-
createCompletionPort
job
when
(
ioPort
==
nullPtr
)
$
errorWin
"createCompletionPort, cannot continue."
-- We're explicitly turning off handle inheritance to prevent misc handles
-- from being inherited by the child. Notable we don't want the I/O Completion
-- Ports and Job handles to be inherited. So we mark them as non-inheritable.
setHandleInformation
job
cHANDLE_FLAG_INHERIT
0
setHandleInformation
ioPort
cHANDLE_FLAG_INHERIT
0
-- Now create the process suspended so we can add it to the job and then resume.
-- This is so we don't miss any events on the receiving end of the I/O port.
let
creationflags
=
cCREATE_SUSPENDED
b
<-
createProcessW
nullPtr
cmd''
nullPtr
nullPtr
True
creationflags
nullPtr
nullPtr
p_startupinfo
p_pi
unless
b
$
errorWin
"createProcessW"
pi
<-
peek
p_pi
b_assign
<-
assignProcessToJobObject
job
(
piProcess
pi
)
unless
b_assign
$
errorWin
"assignProcessToJobObject, cannot continue."
let
handleInterrupt
action
=
action
`
onException
`
terminateJobObject
job
99
handleCtrl
_
=
do
terminateJobObject
job
99
closeHandle
ioPort
closeHandle
job
exitWith
(
ExitFailure
99
)
return
True
withConsoleCtrlHandler
handleCtrl
$
handleInterrupt
$
do
resumeThread
(
piThread
pi
)
-- The program is now running
let
handle
=
piProcess
pi
let
millisecs
=
secs
*
1000
rc
<-
waitForJobCompletion
job
ioPort
(
fromIntegral
millisecs
)
closeHandle
ioPort
if
not
rc
then
do
terminateJobObject
job
99
closeHandle
job
TimedOut
->
do
interruptProcessGroupOf
pid
terminateProcess
pid
exitWith
(
ExitFailure
99
)
else
alloca
$
\
p_exitCode
->
do
terminateJobObject
job
0
-- Ensured it's all really dead.
closeHandle
job
r
<-
getExitCodeProcess
handle
p_exitCode
if
r
then
peek
p_exitCode
>>=
\
case
0
->
exitWith
ExitSuccess
e
->
exitWith
$
ExitFailure
(
fromIntegral
e
)
else
errorWin
"getExitCodeProcess"
#
endif
InterruptedSignal
->
do
interruptProcessGroupOf
pid
terminateProcess
pid
exitWith
(
ExitFailure
2
)
Exited
r
->
exitWith
r
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment