X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO%2FFD.hs;h=0480bb60c141b463dd5b68ccc5b258c2dad8a055;hb=9520c5735e69668a33013c36f85152a1ef656b8d;hp=a54dd5237aaa517bb354b5ca8164e9f410abbce5;hpb=1df344fea8ea411ad92db0c586b39b3374c6a3fa;p=ghc-base.git diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs index a54dd52..0480bb6 100644 --- a/GHC/IO/FD.hs +++ b/GHC/IO/FD.hs @@ -22,8 +22,6 @@ module GHC.IO.FD ( stdin, stdout, stderr ) where -#undef DEBUG_DUMP - import GHC.Base import GHC.Num import GHC.Real @@ -39,7 +37,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 +45,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 @@ -106,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 -- ----------------------------------------------------------------------------- @@ -163,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 @@ -216,7 +215,8 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do _ -> True #ifdef mingw32_HOST_OS - let _ = (dev,ino,write,fd) -- warning suppression + _ <- setmode fd True -- unconditionally set binary mode + let _ = (dev,ino,write) -- warning suppression #endif case fd_type of @@ -247,6 +247,11 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do }, fd_type) +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "__hscore_setmode" + setmode :: CInt -> Bool -> IO CInt +#endif + -- ----------------------------------------------------------------------------- -- Standard file descriptors @@ -284,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" @@ -303,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 @@ -324,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 @@ -339,12 +342,18 @@ 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 -setNonBlockingMode :: FD -> IO () -setNonBlockingMode fd = setNonBlockingFD (fdFD fd) +setNonBlockingMode :: FD -> Bool -> IO FD +setNonBlockingMode fd set = do + setNonBlockingFD (fdFD fd) set +#if defined(mingw32_HOST_OS) + return fd +#else + return fd{ fdIsNonBlocking = fromEnum set } +#endif ready :: FD -> Bool -> Int -> IO Bool ready fd write msecs = do @@ -398,7 +407,7 @@ fdWrite fd ptr bytes = do res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes) let res' = fromIntegral res if res' < bytes - then fdWrite fd (ptr `plusPtr` bytes) (bytes - res') + then fdWrite fd (ptr `plusPtr` res') (bytes - res') else return () -- XXX ToDo: this isn't non-blocking @@ -447,7 +456,7 @@ indicates that there's no data, we call threadWaitRead. -} -readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int readRawBufferPtr loc !fd buf off len | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block | otherwise = do r <- throwErrnoIfMinus1 loc @@ -456,14 +465,15 @@ readRawBufferPtr loc !fd buf off len then read else do threadWaitRead (fromIntegral (fdFD fd)); read where - do_read call = throwErrnoIfMinus1RetryMayBlock loc call + do_read call = fromIntegral `fmap` + throwErrnoIfMinus1RetryMayBlock loc call (threadWaitRead (fromIntegral (fdFD fd))) read = if threaded then safe_read else unsafe_read - unsafe_read = do_read (read_off (fdFD fd) buf off len) - safe_read = do_read (safe_read_off (fdFD fd) buf off len) + unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len) + safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len) -- return: -1 indicates EOF, >=0 is bytes read -readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int readRawBufferPtrNoBlock loc !fd buf off len | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0 @@ -475,11 +485,11 @@ readRawBufferPtrNoBlock loc !fd buf off len case r of (-1) -> return 0 0 -> return (-1) - n -> return n - unsafe_read = do_read (read_off (fdFD fd) buf off len) - safe_read = do_read (safe_read_off (fdFD fd) buf off len) + n -> return (fromIntegral n) + unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len) + safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len) -writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt writeRawBufferPtr loc !fd buf off len | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0 @@ -487,13 +497,14 @@ writeRawBufferPtr loc !fd buf off len then write else do threadWaitWrite (fromIntegral (fdFD fd)); write where - do_write call = throwErrnoIfMinus1RetryMayBlock loc call + do_write call = fromIntegral `fmap` + throwErrnoIfMinus1RetryMayBlock loc call (threadWaitWrite (fromIntegral (fdFD fd))) write = if threaded then safe_write else unsafe_write - unsafe_write = do_write (write_off (fdFD fd) buf off len) - safe_write = do_write (safe_write_off (fdFD fd) buf off len) + unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len) + safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len) -writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt writeRawBufferPtrNoBlock loc !fd buf off len | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0 @@ -503,44 +514,38 @@ writeRawBufferPtrNoBlock loc !fd buf off len do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1)) case r of (-1) -> return 0 - n -> return n + n -> return (fromIntegral n) write = if threaded then safe_write else unsafe_write - unsafe_write = do_write (write_off (fdFD fd) buf off len) - safe_write = do_write (safe_write_off (fdFD fd) buf off len) + unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len) + safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len) isNonBlocking :: FD -> Bool isNonBlocking fd = fdIsNonBlocking fd /= 0 -foreign import ccall unsafe "__hscore_PrelHandle_read" - read_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "__hscore_PrelHandle_write" - write_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt - foreign import ccall unsafe "fdReady" unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt #else /* mingw32_HOST_OS.... */ -readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt readRawBufferPtr loc !fd buf off len | threaded = blockingReadRawBufferPtr loc fd buf off len | otherwise = asyncReadRawBufferPtr loc fd buf off len -writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt writeRawBufferPtr loc !fd buf off len | threaded = blockingWriteRawBufferPtr loc fd buf off len | otherwise = asyncWriteRawBufferPtr loc fd buf off len -readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt readRawBufferPtrNoBlock = readRawBufferPtr -writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt writeRawBufferPtrNoBlock = writeRawBufferPtr -- Async versions of the read/write primitives, for the non-threaded RTS -asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt asyncReadRawBufferPtr loc !fd buf off len = do (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd) (fromIntegral len) (buf `plusPtr` off) @@ -549,7 +554,7 @@ asyncReadRawBufferPtr loc !fd buf off len = do ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) else return (fromIntegral l) -asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt asyncWriteRawBufferPtr loc !fd buf off len = do (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd) (fromIntegral len) (buf `plusPtr` off) @@ -560,48 +565,42 @@ asyncWriteRawBufferPtr loc !fd buf off len = do -- Blocking versions of the read/write primitives, for the threaded RTS -blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt blockingReadRawBufferPtr loc fd buf off len - = throwErrnoIfMinus1Retry loc $ + = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $ if fdIsSocket fd - then safe_recv_off (fdFD fd) buf off len - else safe_read_off (fdFD fd) buf off len + then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0 + else c_safe_read (fdFD fd) (buf `plusPtr` off) len -blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CInt -> IO CInt +blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt blockingWriteRawBufferPtr loc fd buf off len - = throwErrnoIfMinus1Retry loc $ + = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $ if fdIsSocket fd - then safe_send_off (fdFD fd) buf off len - else safe_write_off (fdFD fd) buf off len + then c_safe_send (fdFD fd) (buf `plusPtr` off) len 0 + else c_safe_write (fdFD fd) (buf `plusPtr` off) len -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. -- These calls may block, but that's ok. -foreign import ccall safe "__hscore_PrelHandle_recv" - safe_recv_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt +foreign import stdcall safe "recv" + c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize -foreign import ccall safe "__hscore_PrelHandle_send" - safe_send_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt +foreign import stdcall safe "send" + c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize #endif foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool -foreign import ccall safe "__hscore_PrelHandle_read" - safe_read_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_write" - safe_write_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt - -- ----------------------------------------------------------------------------- -- utils #ifndef mingw32_HOST_OS -throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt +throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize throwErrnoIfMinus1RetryOnBlock loc f on_block = do res <- f - if (res :: CInt) == -1 + if (res :: CSsize) == -1 then do err <- getErrno if err == eINTR @@ -623,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