From: Simon Marlow <marlowsd@gmail.com>
Date: Wed, 24 Jun 2009 11:50:29 +0000 (+0000)
Subject: setNonBlockingMode now takes a flag, can turn blocking mode back on again
X-Git-Tag: 2009-06-25~4
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6c4536b0ff00f8bda65b3aef770174fae2d4f88c;hp=185bcffd05a9a289fe8cb6240de3255ffe534b5d;p=ghc-base.git

setNonBlockingMode now takes a flag, can turn blocking mode back on again
---

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 1d6d9ed..4010c85 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -955,8 +955,8 @@ startIOManagerThread = do
         throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)
         rd_end <- peekElemOff fds 0
         wr_end <- peekElemOff fds 1
-        setNonBlockingFD wr_end -- writes happen in a signal handler, we
-                                -- don't want them to block.
+        setNonBlockingFD wr_end True -- writes happen in a signal handler, we
+                                     -- don't want them to block.
         setCloseOnExec rd_end
         setCloseOnExec wr_end
         writeIORef stick (fromIntegral wr_end)
diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs
index 44490fb..038319e 100644
--- a/GHC/IO/FD.hs
+++ b/GHC/IO/FD.hs
@@ -343,8 +343,10 @@ dup2 fd fdto = do
     c_dup2 (fdFD fd) (fdFD fdto)
   return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
 
-setNonBlockingMode :: FD -> IO ()
-setNonBlockingMode fd = setNonBlockingFD (fdFD fd)
+setNonBlockingMode :: FD -> Bool -> IO FD
+setNonBlockingMode fd set = do 
+  setNonBlockingFD (fdFD fd) set
+  return fd{ fdIsNonBlocking = fromEnum set }
 
 ready :: FD -> Bool -> Int -> IO Bool
 ready fd write msecs = do
diff --git a/GHC/IO/Handle/FD.hs b/GHC/IO/Handle/FD.hs
index d74dd2d..a2a3d14 100644
--- a/GHC/IO/Handle/FD.hs
+++ b/GHC/IO/Handle/FD.hs
@@ -172,13 +172,16 @@ mkHandleFromFD
    -> Maybe TextEncoding
    -> IO Handle
 
-mkHandleFromFD fd fd_type filepath iomode set_non_blocking mb_codec
+mkHandleFromFD fd0 fd_type filepath iomode set_non_blocking mb_codec
   = do
 #ifndef mingw32_HOST_OS
-    when set_non_blocking $ FD.setNonBlockingMode fd
     -- turn on non-blocking mode
+    fd <- if set_non_blocking 
+             then FD.setNonBlockingMode fd0 True
+             else return fd0
 #else
     let _ = set_non_blocking -- warning suppression
+    fd <- return fd0
 #endif
 
     let nl | isJust mb_codec = nativeNewlineMode
diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs
index 8916059..bfa5b2b 100644
--- a/System/Posix/Internals.hs
+++ b/System/Posix/Internals.hs
@@ -314,21 +314,23 @@ foreign import ccall unsafe "consUtils.h get_console_echo__"
 -- ---------------------------------------------------------------------------
 -- Turning on non-blocking for a file descriptor
 
-setNonBlockingFD :: FD -> IO ()
+setNonBlockingFD :: FD -> Bool -> IO ()
 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-setNonBlockingFD fd = do
+setNonBlockingFD fd set = do
   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
                  (c_fcntl_read fd const_f_getfl)
   -- An error when setting O_NONBLOCK isn't fatal: on some systems 
   -- there are certain file handles on which this will fail (eg. /dev/null
   -- on FreeBSD) so we throw away the return code from fcntl_write.
-  unless (testBit flags (fromIntegral o_NONBLOCK)) $ do
-    c_fcntl_write fd const_f_setfl (fromIntegral (flags .|. o_NONBLOCK))
+  let flags' | set       = flags .|. o_NONBLOCK
+             | otherwise = flags .&. complement o_NONBLOCK
+  unless (flags == flags') $ do
+    c_fcntl_write fd const_f_setfl (fromIntegral flags')
     return ()
 #else
 
 -- bogus defns for win32
-setNonBlockingFD _ = return ()
+setNonBlockingFD _ _ = return ()
 
 #endif