X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO%2FFD.hs;h=b5392d477d1df5ca57b9997d2dbd25eb7c9bc613;hb=41e8fba828acbae1751628af50849f5352b27873;hp=32f4e9bb1957c7d12c52979c98367c67218d1a6f;hpb=d181127657f46b1d0acd3dc94ccce4c0e6241095;p=ghc-base.git

diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs
index 32f4e9b..b5392d4 100644
--- a/GHC/IO/FD.hs
+++ b/GHC/IO/FD.hs
@@ -1,5 +1,13 @@
-{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-}
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , BangPatterns
+           , ForeignFunctionInterface
+           , DeriveDataTypeable
+  #-}
+{-# OPTIONS_GHC -fno-warn-identities #-}
+-- Whether there are identities depends on the platform
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.IO.FD
@@ -22,8 +30,6 @@ module GHC.IO.FD (
   stdin, stdout, stderr
   ) where
 
-#undef DEBUG_DUMP
-
 import GHC.Base
 import GHC.Num
 import GHC.Real
@@ -39,7 +45,7 @@ import GHC.IO.Buffer
 import GHC.IO.BufferedIO
 import qualified GHC.IO.Device
 import GHC.IO.Device (SeekMode(..), IODeviceType(..))
-import GHC.Conc
+import GHC.Conc.IO
 import GHC.IO.Exception
 
 import Foreign
@@ -47,7 +53,10 @@ import Foreign.C
 import qualified System.Posix.Internals
 import System.Posix.Internals hiding (FD, setEcho, getEcho)
 import System.Posix.Types
-import GHC.Ptr
+-- import GHC.Ptr
+
+c_DEBUG_DUMP :: Bool
+c_DEBUG_DUMP = False
 
 -- -----------------------------------------------------------------------------
 -- The file-descriptor IO device
@@ -97,8 +106,15 @@ instance GHC.IO.Device.IODevice FD where
   dup           = dup
   dup2          = dup2
 
+-- We used to use System.Posix.Internals.dEFAULT_BUFFER_SIZE, which is
+-- taken from the value of BUFSIZ on the current platform.  This value
+-- varies too much though: it is 512 on Windows, 1024 on OS X and 8192
+-- on Linux.  So let's just use a decent size on every platform:
+dEFAULT_FD_BUFFER_SIZE :: Int
+dEFAULT_FD_BUFFER_SIZE = 8096
+
 instance BufferedIO FD where
-  newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state
+  newBuffer _dev state = newByteBuffer dEFAULT_FD_BUFFER_SIZE state
   fillReadBuffer    fd buf = readBuf' fd buf
   fillReadBuffer0   fd buf = readBufNonBlocking fd buf
   flushWriteBuffer  fd buf = writeBuf' fd buf
@@ -106,20 +122,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
 
 -- -----------------------------------------------------------------------------
@@ -158,12 +171,13 @@ openFile filepath iomode =
     -- always returns EISDIR if the file is a directory and was opened
     -- for writing, so I think we're ok with a single open() here...
     fd <- throwErrnoIfMinus1Retry "openFile"
-                (c_open f (fromIntegral oflags) 0o666)
+                (c_open f oflags 0o666)
 
     (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
@@ -216,7 +230,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
 
@@ -279,23 +293,25 @@ stderr = stdFD 2
 close :: FD -> IO ()
 close fd =
 #ifndef mingw32_HOST_OS
-  (flip finally) (release fd) $ do
+  (flip finally) (release fd) $
 #endif
-  throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
+  do let closer realFd =
+           throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
 #ifdef mingw32_HOST_OS
-    if fdIsSocket fd then
-       c_closesocket (fdFD fd)
-    else
+           if fdIsSocket fd then
+             c_closesocket (fromIntegral realFd)
+           else
 #endif
-       c_close (fdFD fd)
+             c_close (fromIntegral realFd)
+     closeFdWith closer (fromIntegral (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"
@@ -309,9 +325,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
@@ -330,9 +345,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
@@ -345,7 +359,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
 
@@ -377,7 +391,12 @@ foreign import ccall safe "fdReady"
 -- Terminal-related stuff
 
 isTerminal :: FD -> IO Bool
-isTerminal fd = c_isatty (fdFD fd) >>= return.toBool
+isTerminal fd =
+#if defined(mingw32_HOST_OS)
+    is_console (fdFD fd) >>= return.toBool
+#else
+    c_isatty (fdFD fd) >>= return.toBool
+#endif
 
 setEcho :: FD -> Bool -> IO () 
 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
@@ -392,17 +411,17 @@ setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
 -- Reading and Writing
 
 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
-fdRead fd ptr bytes = do
-  r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
-  return (fromIntegral r)
+fdRead fd ptr bytes
+  = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
+       ; return (fromIntegral r) }
 
 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
 fdReadNonBlocking fd ptr bytes = do
   r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr 
            0 (fromIntegral bytes)
-  case r of
+  case fromIntegral r of
     (-1) -> return (Nothing)
-    n    -> return (Just (fromIntegral n))
+    n    -> return (Just n)
 
 
 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
@@ -580,7 +599,19 @@ blockingWriteRawBufferPtr loc fd buf off len
   = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
         if fdIsSocket fd
            then c_safe_send  (fdFD fd) (buf `plusPtr` off) len 0
-           else c_safe_write (fdFD fd) (buf `plusPtr` off) len
+           else do
+             r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
+             when (r == -1) c_maperrno
+             return r
+      -- we don't trust write() to give us the correct errno, and
+      -- instead do the errno conversion from GetLastError()
+      -- ourselves.  The main reason is that we treat ERROR_NO_DATA
+      -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
+      -- for this case.  We need to detect EPIPE correctly, because it
+      -- shouldn't be reported as an error when it happens on stdout.
+
+foreign import ccall unsafe "maperrno"             -- in Win32Utils.c
+   c_maperrno :: IO ()
 
 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
 -- These calls may block, but that's ok.
@@ -625,8 +656,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