raise asynchronous exceptions asynchronously (#3997)

[ghc-base.git] / GHC / IO / FD.hs

diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs
index 8e52584..4425a3a 100644 (file)
--- a/GHC/IO/FD.hs
+++ b/GHC/IO/FD.hs
@@ -22,17 +22,13 @@ module GHC.IO.FD (
   stdin, stdout, stderr
   ) where
 
-#undef DEBUG_DUMP
-
 import GHC.Base
 import GHC.Num
 import GHC.Real
 import GHC.Show
 import GHC.Enum
 import Data.Maybe
-#ifndef mingw32_HOST_OS
 import Control.Monad
-#endif
 import Data.Typeable
 
 import GHC.IO
@@ -51,6 +47,9 @@ import System.Posix.Internals hiding (FD, setEcho, getEcho)
 import System.Posix.Types
 -- import GHC.Ptr
 
+c_DEBUG_DUMP :: Bool
+c_DEBUG_DUMP = False
+
 -- -----------------------------------------------------------------------------
 -- The file-descriptor IO device
 
@@ -108,20 +107,17 @@ instance BufferedIO FD where
 
 readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
 readBuf' fd buf = do
-#ifdef DEBUG_DUMP
-  puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
-#endif
+  when c_DEBUG_DUMP $
+      puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
   (r,buf') <- readBuf fd buf
-#ifdef DEBUG_DUMP
-  puts ("after: " ++ summaryBuffer buf' ++ "\n")
-#endif
+  when c_DEBUG_DUMP $
+      puts ("after: " ++ summaryBuffer buf' ++ "\n")
   return (r,buf')
 
-writeBuf' :: FD -> Buffer Word8 -> IO ()
+writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
 writeBuf' fd buf = do
-#ifdef DEBUG_DUMP
-  puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
-#endif
+  when c_DEBUG_DUMP $
+      puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
   writeBuf fd buf
 
 -- -----------------------------------------------------------------------------
@@ -165,7 +161,8 @@ openFile filepath iomode =
     (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
                             False{-not a socket-} 
                             True{-is non-blocking-}
-            `catchAny` \e -> do c_close fd; throwIO e
+            `catchAny` \e -> do _ <- c_close fd
+                                throwIO e
 
 #ifndef mingw32_HOST_OS
         -- we want to truncate() if this is an open in WriteMode, but only
@@ -218,7 +215,7 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do
                    _ -> True
 
 #ifdef mingw32_HOST_OS
-    setmode fd True -- unconditionally set binary mode
+    _ <- setmode fd True -- unconditionally set binary mode
     let _ = (dev,ino,write) -- warning suppression
 #endif
 
@@ -292,12 +289,12 @@ close fd =
        c_close (fdFD fd)
 
 release :: FD -> IO ()
-release fd = do
-#ifndef mingw32_HOST_OS
-   unlockFile (fdFD fd)
+#ifdef mingw32_HOST_OS
+release _ = return ()
+#else
+release fd = do _ <- unlockFile (fdFD fd)
+                return ()
 #endif
-   let _ = fd -- warning suppression
-   return ()
 
 #ifdef mingw32_HOST_OS
 foreign import stdcall unsafe "HsBase.h closesocket"
@@ -311,9 +308,8 @@ isSeekable fd = do
 
 seek :: FD -> SeekMode -> Integer -> IO ()
 seek fd mode off = do
-  throwErrnoIfMinus1Retry "seek" $
+  throwErrnoIfMinus1Retry_ "seek" $
      c_lseek (fdFD fd) (fromIntegral off) seektype
-  return ()
  where
     seektype :: CInt
     seektype = case mode of
@@ -332,9 +328,8 @@ getSize fd = fdFileSize (fdFD fd)
 
 setSize :: FD -> Integer -> IO () 
 setSize fd size = do
-  throwErrnoIf (/=0) "GHC.IO.FD.setSize"  $
+  throwErrnoIf_ (/=0) "GHC.IO.FD.setSize"  $
      c_ftruncate (fdFD fd) (fromIntegral size)
-  return ()
 
 devType :: FD -> IO IODeviceType
 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
@@ -347,7 +342,7 @@ dup fd = do
 dup2 :: FD -> FD -> IO FD
 dup2 fd fdto = do
   -- Windows' dup2 does not return the new descriptor, unlike Unix
-  throwErrnoIfMinus1 "GHC.IO.FD.dup2" $ 
+  throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
     c_dup2 (fdFD fd) (fdFD fdto)
   return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
 
@@ -627,8 +622,7 @@ foreign import ccall unsafe "unlockFile"
   unlockFile :: CInt -> IO CInt
 #endif
 
-#if defined(DEBUG_DUMP)
 puts :: String -> IO ()
-puts s = do withCStringLen s $ \(p,len) -> c_write 1 p (fromIntegral len)
+puts s = do _ <- withCStringLen s $ \(p,len) ->
+                     c_write 1 (castPtr p) (fromIntegral len)
             return ()
-#endif