[commit: packages/base] master: Fix OSX RTS crash due to bad coercion. (95a74f9)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/95a74f9b091a8b512828b6930ea46d7ac55be76b/base

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

commit 95a74f9b091a8b512828b6930ea46d7ac55be76b
Author: Merijn Verstraaten <merijn at inconsistent.nl>
Date:   Wed Jul 24 14:37:25 2013 +0100

    Fix OSX RTS crash due to bad coercion.
    
    The code coerces Int to CInt, which causes an overflow if Int is bigger
    than CInt (for example, Int 64bit, CInt 32 bit). This results in a
    negative value being passed to c_poll.
    
    On Linux all negative values are treated as infinite timeouts, which
    gives subtly wrong semantics, but is unlikely to produce actual bugs.
    
    OSX insists that only -1 is a valid value for infinite timeout, any
    other negative timeout is treated as an invalid argument.
    
    This patch replaces the c_poll call with a loop that handles the
    overflow gracefully by chaining multiple calls to poll to obtain the
    proper semantics.
    
    Signed-off-by: Austin Seipp <aseipp at pobox.com>


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

95a74f9b091a8b512828b6930ea46d7ac55be76b
 GHC/Event/Poll.hsc |   24 +++++++++++++++++++++++-
 1 file changed, 23 insertions(+), 1 deletion(-)

diff --git a/GHC/Event/Poll.hsc b/GHC/Event/Poll.hsc
index 665949b..6d089fb 100644
--- a/GHC/Event/Poll.hsc
+++ b/GHC/Event/Poll.hsc
@@ -35,6 +35,7 @@ import Foreign.Ptr (Ptr)
 import Foreign.Storable (Storable(..))
 import GHC.Base
 import GHC.Conc.Sync (withMVar)
+import GHC.Enum (maxBound)
 import GHC.Num (Num(..))
 import GHC.Real (ceiling, fromIntegral)
 import GHC.Show (Show)
@@ -90,7 +91,7 @@ poll p mtout f = do
     E.throwErrnoIfMinus1NoRetry "c_poll" $
     case mtout of
       Just tout ->
-        c_poll ptr (fromIntegral len) (fromIntegral (fromTimeout tout))
+        c_pollLoop ptr (fromIntegral len) (fromTimeout tout)
       Nothing   ->
         c_poll_unsafe ptr (fromIntegral len) 0
   unless (n == 0) $ do
@@ -102,6 +103,27 @@ poll p mtout f = do
                 return (i', i' == n)
         else return (i, True)
   return (fromIntegral n)
+  where
+    -- The poll timeout is specified as an Int, but c_poll takes a CInt. These
+    -- can't be safely coerced as on many systems (e.g. x86_64) CInt has a a
+    -- maxBound of (2^32 - 1), even though Int may have a significantly higher
+    -- bound.
+    --
+    -- This function deals with timeouts greater than maxBound :: CInt, by
+    -- looping until c_poll returns a non-zero value (0 indicates timeout
+    -- 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)
+        | otherwise = do
+            result <- c_poll ptr len (fromIntegral maxPollTimeout)
+            if result == 0
+               then c_pollLoop ptr len (fromIntegral (tout - maxPollTimeout))
+               else return result
+
+    -- Timeout of c_poll is limited by max value of CInt
+    maxPollTimeout :: Int
+    maxPollTimeout = fromIntegral (maxBound :: CInt)
 
 fromTimeout :: E.Timeout -> Int
 fromTimeout E.Forever     = -1