X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=fd06fc6a5b2898e59c359f2ae45e73fbb77c3c24;hb=74bc2d04fdbae494bcf4839c4ec5e6ec1d0bf600;hp=0e9b3be0a957ede3b356cbc61c4d17495525406e;hpb=3b7854b611293af35a1d69dbc9761b973462d8b3;p=haskell-directory.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index 0e9b3be..fd06fc6 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -157,6 +157,7 @@ withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act +withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a withHandle_' fun h m act = block $ do h_ <- takeMVar m @@ -453,7 +454,7 @@ flushReadBuffer fd buf puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n") # endif throwErrnoIfMinus1Retry "flushReadBuffer" - (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR) + (c_lseek fd (fromIntegral off) sEEK_CUR) return buf{ bufWPtr=0, bufRPtr=0 } flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer @@ -466,7 +467,7 @@ flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = if bytes == 0 then return (buf{ bufRPtr=0, bufWPtr=0 }) else do - res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b + res <- writeRawBuffer "flushWriteBuffer" fd is_stream b (fromIntegral r) (fromIntegral bytes) let res' = fromIntegral res if res' < bytes @@ -549,20 +550,20 @@ readRawBufferPtr loc fd is_stream buf off len = writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt writeRawBuffer loc fd is_stream buf off len = throwErrnoIfMinus1RetryMayBlock loc - (write_rawBuffer (fromIntegral fd) buf off len) + (write_rawBuffer fd buf off len) (threadWaitWrite (fromIntegral fd)) writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt writeRawBufferPtr loc fd is_stream buf off len = throwErrnoIfMinus1RetryMayBlock loc - (write_off (fromIntegral fd) buf off len) + (write_off fd buf off len) (threadWaitWrite (fromIntegral fd)) foreign import ccall unsafe "__hscore_PrelHandle_read" - read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt + read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt foreign import ccall unsafe "__hscore_PrelHandle_read" - read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt + read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt foreign import ccall unsafe "__hscore_PrelHandle_write" write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt @@ -594,12 +595,12 @@ writeRawBufferPtr loc fd is_stream buf off len -- ToDo: we don't have a non-blocking primitve read on Win32 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -readRawBufferNoBlock = readRawBufferNoBlock +readRawBufferNoBlock = readRawBuffer -- Async versions of the read/write primitives, for the non-threaded RTS asyncReadRawBuffer loc fd is_stream buf off len = do - (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0) + (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0) (fromIntegral len) off buf if l == (-1) then @@ -607,7 +608,7 @@ asyncReadRawBuffer loc fd is_stream buf off len = do else return (fromIntegral l) asyncReadRawBufferPtr loc fd is_stream buf off len = do - (l, rc) <- asyncRead fd (if is_stream then 1 else 0) + (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off) if l == (-1) then @@ -615,7 +616,7 @@ asyncReadRawBufferPtr loc fd is_stream buf off len = do else return (fromIntegral l) asyncWriteRawBuffer loc fd is_stream buf off len = do - (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0) + (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0) (fromIntegral len) off buf if l == (-1) then @@ -623,7 +624,7 @@ asyncWriteRawBuffer loc fd is_stream buf off len = do else return (fromIntegral l) asyncWriteRawBufferPtr loc fd is_stream buf off len = do - (l, rc) <- asyncWrite fd (if is_stream then 1 else 0) + (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off) if l == (-1) then @@ -648,26 +649,26 @@ blockingReadRawBufferPtr loc fd False buf off len = blockingWriteRawBuffer loc fd True buf off len = throwErrnoIfMinus1Retry loc $ - send_rawBuffer (fromIntegral fd) buf off len + send_rawBuffer fd buf off len blockingWriteRawBuffer loc fd False buf off len = throwErrnoIfMinus1Retry loc $ - write_rawBuffer (fromIntegral fd) buf off len + write_rawBuffer fd buf off len blockingWriteRawBufferPtr loc fd True buf off len = throwErrnoIfMinus1Retry loc $ - send_off (fromIntegral fd) buf off len + send_off fd buf off len blockingWriteRawBufferPtr loc fd False buf off len = throwErrnoIfMinus1Retry loc $ - write_off (fromIntegral fd) buf off len + write_off fd buf 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_read" - read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt + read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt foreign import ccall safe "__hscore_PrelHandle_read" - read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt + read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt foreign import ccall safe "__hscore_PrelHandle_write" write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt @@ -676,10 +677,10 @@ foreign import ccall safe "__hscore_PrelHandle_write" write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt foreign import ccall safe "__hscore_PrelHandle_recv" - recv_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt + recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt foreign import ccall safe "__hscore_PrelHandle_recv" - recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt + recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt foreign import ccall safe "__hscore_PrelHandle_send" send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt @@ -809,14 +810,13 @@ openFile' filepath mode binary = -- directories. However, the man pages I've read say that open() -- 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 <- fromIntegral `liftM` - throwErrnoIfMinus1Retry "openFile" + fd <- throwErrnoIfMinus1Retry "openFile" (c_open f (fromIntegral oflags) 0o666) fd_type <- fdType fd h <- openFd fd (Just fd_type) False filepath mode binary - `catchException` \e -> do c_close (fromIntegral fd); throw e + `catchException` \e -> do c_close fd; throw e -- NB. don't forget to close the FD if openFd fails, otherwise -- this FD leaks. -- ASSERT: if we just created the file, then openFd won't fail @@ -829,7 +829,7 @@ openFile' filepath mode binary = -- like /dev/null. if mode == WriteMode && fd_type == RegularFile then throwErrnoIf (/=0) "openFile" - (c_ftruncate (fromIntegral fd) 0) + (c_ftruncate fd 0) else return 0 #endif return h @@ -873,8 +873,8 @@ openTempFile' loc tmp_dir template binary = do then findTempName (x+1) else ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) else do - h <- openFd (fromIntegral fd) Nothing False filepath ReadWriteMode True - `catchException` \e -> do c_close (fromIntegral fd); throw e + h <- openFd fd Nothing False filepath ReadWriteMode True + `catchException` \e -> do c_close fd; throw e return (filepath, h) where filename = prefix ++ show x ++ suffix @@ -918,22 +918,23 @@ openFd fd mb_fd_type is_socket filepath mode binary = do -- regular files need to be locked RegularFile -> do #ifndef mingw32_HOST_OS - r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-} + r <- lockFile fd (fromBool write) 1{-exclusive-} when (r == -1) $ ioException (IOError Nothing ResourceBusy "openFile" "file is locked" Nothing) #endif mkFileHandle fd is_socket filepath ha_type binary - -- Stream or RawDevice - Stream -> mkIt ha_type - RawDevice -> mkIt ha_type - _ -> - ioException (IOError Nothing UnsupportedOperation "openFd" - "unknown file type" Nothing) - where - mkIt ht - | isReadWriteHandleType ht = mkDuplexHandle fd is_socket filepath binary - | otherwise = mkFileHandle fd is_socket filepath ht binary + + Stream + -- only *Streams* can be DuplexHandles. Other read/write + -- Handles must share a buffer. + | ReadWriteHandle <- ha_type -> + mkDuplexHandle fd is_socket filepath binary + | otherwise -> + mkFileHandle fd is_socket filepath ha_type binary + + RawDevice -> + mkFileHandle fd is_socket filepath ha_type binary fdToHandle :: FD -> IO Handle fdToHandle fd = do @@ -968,6 +969,17 @@ mkStdHandle fd filepath ha_type buf bmode = do mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle mkFileHandle fd is_stream filepath ha_type binary = do (buf, bmode) <- getBuffer fd (initBufferState ha_type) + +#ifdef mingw32_HOST_OS + -- On Windows, if this is a read/write handle and we are in text mode, + -- turn off buffering. We don't correctly handle the case of switching + -- from read mode to write mode on a buffered text-mode handle, see bug + -- \#679. + bmode <- case ha_type of + ReadWriteHandle | not binary -> return NoBuffering + _other -> return bmode +#endif + spares <- newIORef BufferListNil newFileHandle filepath (handleFinalizer filepath) (Handle__ { haFD = fd, @@ -1049,17 +1061,16 @@ hClose_help handle_ = hClose_handle_ handle_ = do let fd = haFD handle_ - c_fd = fromIntegral fd -- close the file descriptor, but not when this is the read -- side of a duplex handle. case haOtherSide handle_ of - Nothing -> + Nothing -> throwErrnoIfMinus1Retry_ "hClose" #ifdef mingw32_HOST_OS - (closeFd (haIsStream handle_) c_fd) + (closeFd (haIsStream handle_) fd) #else - (c_close c_fd) + (c_close fd) #endif Just _ -> return () @@ -1068,7 +1079,7 @@ hClose_handle_ handle_ = do #ifndef mingw32_HOST_OS -- unlock it - unlockFile c_fd + unlockFile fd #endif -- we must set the fd to -1, because the finalizer is going @@ -1107,7 +1118,7 @@ hSetFileSize handle size = SemiClosedHandle -> ioe_closedHandle _ -> do flushWriteBufferOnly handle_ throwErrnoIf (/=0) "hSetFileSize" - (c_ftruncate (fromIntegral (haFD handle_)) (fromIntegral size)) + (c_ftruncate (haFD handle_) (fromIntegral size)) return () -- --------------------------------------------------------------------------- @@ -1346,7 +1357,7 @@ hSeek handle mode offset = let do_seek = throwErrnoIfMinus1Retry_ "hSeek" - (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence) + (c_lseek (haFD handle_) (fromIntegral offset) whence) whence :: CInt whence = case mode of @@ -1379,7 +1390,7 @@ hTell handle = -- current buffer size. Just flush instead. flushBuffer handle_ #endif - let fd = fromIntegral (haFD handle_) + let fd = haFD handle_ posn <- fromIntegral `liftM` throwErrnoIfMinus1Retry "hGetPosn" (c_lseek fd 0 sEEK_CUR) @@ -1518,7 +1529,7 @@ hSetBinaryMode :: Handle -> Bool -> IO () hSetBinaryMode handle bin = withAllHandles__ "hSetBinaryMode" handle $ \ handle_ -> do throwErrnoIfMinus1_ "hSetBinaryMode" - (setmode (fromIntegral (haFD handle_)) bin) + (setmode (haFD handle_) bin) return handle_{haIsBin=bin} foreign import ccall unsafe "__hscore_setmode" @@ -1534,35 +1545,41 @@ foreign import ccall unsafe "__hscore_setmode" hDuplicate :: Handle -> IO Handle hDuplicate h@(FileHandle path m) = do - new_h_ <- withHandle' "hDuplicate" h m (dupHandle Nothing) + new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing) newFileHandle path (handleFinalizer path) new_h_ hDuplicate h@(DuplexHandle path r w) = do - new_w_ <- withHandle' "hDuplicate" h w (dupHandle Nothing) + new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing) new_w <- newMVar new_w_ - new_r_ <- withHandle' "hDuplicate" h r (dupHandle (Just new_w)) + new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w)) new_r <- newMVar new_r_ addMVarFinalizer new_w (handleFinalizer path new_w) return (DuplexHandle path new_r new_w) -dupHandle other_side h_ = do +dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__ + -> IO (Handle__, Handle__) +dupHandle h other_side h_ = do -- flush the buffer first, so we don't have to copy its contents flushBuffer h_ - new_fd <- throwErrnoIfMinus1 "dupHandle" $ - c_dup (fromIntegral (haFD h_)) + new_fd <- case other_side of + Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_) + Just r -> withHandle_' "dupHandle" h r (return . haFD) dupHandle_ other_side h_ new_fd dupHandleTo other_side hto_ h_ = do flushBuffer h_ - new_fd <- throwErrnoIfMinus1 "dupHandleTo" $ - c_dup2 (fromIntegral (haFD h_)) (fromIntegral (haFD hto_)) - dupHandle_ other_side h_ new_fd + -- Windows' dup2 does not return the new descriptor, unlike Unix + throwErrnoIfMinus1 "dupHandleTo" $ + c_dup2 (haFD h_) (haFD hto_) + dupHandle_ other_side h_ (haFD hto_) +dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD + -> IO (Handle__, Handle__) dupHandle_ other_side h_ new_fd = do buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_)) ioref <- newIORef buffer ioref_buffers <- newIORef BufferListNil - let new_handle_ = h_{ haFD = fromIntegral new_fd, + let new_handle_ = h_{ haFD = new_fd, haBuffer = ioref, haBuffers = ioref_buffers, haOtherSide = other_side }