[commit: ghc] master: *Really*, really fix RTS crash due to bad coercion. (24e05f4)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/24e05f48f3a3a1130ecd5a46e3089b76ee5a2304/ghc

>---------------------------------------------------------------

commit 24e05f48f3a3a1130ecd5a46e3089b76ee5a2304
Author: Merijn Verstraaten <merijn at inconsistent.nl>
Date:   Fri Nov 7 07:32:18 2014 -0600

    *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 <merijn at 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


>---------------------------------------------------------------

24e05f48f3a3a1130ecd5a46e3089b76ee5a2304
 libraries/base/GHC/Event/Poll.hsc | 14 +++++++++-----
 libraries/base/tests/T8089.hs     | 32 ++++++++++++++++++++++++++++++++
 libraries/base/tests/all.T        |  1 +
 rts/posix/Select.c                | 25 ++++++++++++++++++++++++-
 4 files changed, 66 insertions(+), 6 deletions(-)

diff --git a/libraries/base/GHC/Event/Poll.hsc b/libraries/base/GHC/Event/Poll.hsc
index b8f8c02..6cbe143 100644
--- a/libraries/base/GHC/Event/Poll.hsc
+++ b/libraries/base/GHC/Event/Poll.hsc
@@ -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
diff --git a/libraries/base/tests/T8089.hs b/libraries/base/tests/T8089.hs
new file mode 100644
index 0000000..2b98f94
--- /dev/null
+++ b/libraries/base/tests/T8089.hs
@@ -0,0 +1,32 @@
+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
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index ee0fb6b..f7944f4 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -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, [''])
diff --git a/rts/posix/Select.c b/rts/posix/Select.c
index 38b0821..4b19235 100644
--- a/rts/posix/Select.c
+++ b/rts/posix/Select.c
@@ -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;