Commit 24e05f48 authored by Merijn Verstraaten's avatar Merijn Verstraaten Committed by Austin Seipp

*Really*, really fix RTS crash due to bad coercion.

Summary:
My previous attempt to fix the new coercion bug introduced by my fix actually
just reverted back to the *old* bug. This time it should properly handle all
three size scenarios.
Signed-off-by: Merijn Verstraaten's avatarMerijn Verstraaten <merijn@inconsistent.nl>

Test Plan: validate

Reviewers: dfeuer, austin, hvr

Reviewed By: austin, hvr

Subscribers: thomie, carter, simonmar

Differential Revision: https://phabricator.haskell.org/D407

GHC Trac Issues: #8089
parent b0e8e34a
......@@ -112,12 +112,17 @@ poll p mtout f = do
-- expired) OR the full timeout has passed.
c_pollLoop :: Ptr PollFd -> (#type nfds_t) -> Int -> IO CInt
c_pollLoop ptr len tout
| tout <= maxPollTimeout = c_poll ptr len (fromIntegral tout)
| isShortTimeout = c_poll ptr len (fromIntegral tout)
| otherwise = do
result <- c_poll ptr len (fromIntegral maxPollTimeout)
if result == 0
then c_pollLoop ptr len (fromIntegral (tout - maxPollTimeout))
else return result
where
-- maxPollTimeout is smaller than 0 IFF Int is smaller than CInt.
-- This means any possible Int input to poll can be safely directly
-- converted to CInt.
isShortTimeout = tout <= maxPollTimeout || maxPollTimeout < 0
-- We need to account for 3 cases:
-- 1. Int and CInt are of equal size.
......@@ -131,11 +136,10 @@ poll p mtout f = do
-- c_pollLoop recursing if the provided timeout is larger.
--
-- In case 3, "fromIntegral (maxBound :: CInt) :: Int" will result in a
-- negative Int, max will thus return maxBound :: Int. Since poll doesn't
-- accept values bigger than maxBound :: Int and CInt is larger than Int,
-- there is no problem converting Int to CInt for the c_poll call.
-- negative Int. This will cause isShortTimeout to be true and result in
-- the timeout being directly converted to a CInt.
maxPollTimeout :: Int
maxPollTimeout = max maxBound (fromIntegral (maxBound :: CInt))
maxPollTimeout = fromIntegral (maxBound :: CInt)
fromTimeout :: E.Timeout -> Int
fromTimeout E.Forever = -1
......
import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad
import System.Environment
import System.Exit
import System.Process
import System.Timeout
testLoop :: Int -> IO (Maybe a) -> IO (Maybe a)
testLoop 0 _ = return Nothing
testLoop i act = do
result <- act
case result of
Nothing -> threadDelay 100000 >> testLoop (i-1) act
Just x -> return (Just x)
forkTestChild :: IO ()
forkTestChild = do
(_, _, _, hnd) <- createProcess (proc "./T8089" ["test"])
result <- testLoop 50 $ getProcessExitCode hnd
case result of
Nothing -> terminateProcess hnd >> exitSuccess
Just exitCode -> exitWith exitCode
main :: IO ()
main = do
numArgs <- length <$> getArgs
if numArgs > 0
then threadDelay maxBound
else forkTestChild
......@@ -174,3 +174,4 @@ test('T9395', normal, compile_and_run, [''])
test('T9532', normal, compile_and_run, [''])
test('T9586', normal, compile, [''])
test('T9681', normal, compile_fail, [''])
test('T8089', normal, compile_and_run, [''])
......@@ -295,9 +295,32 @@ awaitEvent(rtsBool wait)
tv.tv_usec = 0;
ptv = &tv;
} else if (sleeping_queue != END_TSO_QUEUE) {
/* SUSv2 allows implementations to have an implementation defined
* maximum timeout for select(2). The standard requires
* implementations to silently truncate values exceeding this maximum
* to the maximum. Unfortunately, OSX and the BSD don't comply with
* SUSv2, instead opting to return EINVAL for values exceeding a
* timeout of 1e8.
*
* Select returning an error crashes the runtime in a bad way. To
* play it safe we truncate any timeout to 31 days, as SUSv2 requires
* any implementations maximum timeout to be larger than this.
*
* Truncating the timeout is not an issue, because if nothing
* interesting happens when the timeout expires, we'll see that the
* thread still wants to be blocked longer and simply block on a new
* iteration of select(2).
*/
const time_t max_seconds = 2678400; // 31 * 24 * 60 * 60
Time min = LowResTimeToTime(sleeping_queue->block_info.target - now);
tv.tv_sec = TimeToSeconds(min);
tv.tv_usec = TimeToUS(min) % 1000000;
if (tv.tv_sec < max_seconds) {
tv.tv_usec = TimeToUS(min) % 1000000;
} else {
tv.tv_sec = max_seconds;
tv.tv_usec = 0;
}
ptv = &tv;
} else {
ptv = NULL;
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment