From 9746e23a7eec9cce118f0f5e69aa95168143a7d7 Mon Sep 17 00:00:00 2001 From: sof Date: Mon, 26 Nov 2001 20:04:00 +0000 Subject: [PATCH] [project @ 2001-11-26 20:04:00 by sof] Make the IO implementation work with WinSock once again. When creating sockets with WinSock, you don't get back a file descriptor, but a SOCKET (which just so happens to map to the same type as a 'normal' file descriptor). This SOCKET value cannot be used with the CRT ops read(), write(), close(), but you have to use the socket-specific operations (recv(), send(), and closesocket(), respectively) instead. To keep track of this distinction between file and socket file descriptors, the following changes were made: * a Handle__ has got a new field, haIsStream, which is True for sockets / streams. (this field is essentially unused in non-Win32 settings, but I decided not to conditionalise its presence). * PrelHandle.openFd now takes an extra (Maybe FDType) argument, which lets you force what type of FD we're converting into a Handle (this is crucial for WinSock SOCKETs, since we don't want to attempt fstat()ing them). Fixes breakage that was introduced with May 2001 (or earlier) rewrite of the IO layer. This commit build upon recent IO changes to HEAD, so merging it to STABLE will require importing those changes too (I'll let others be the judge whether this should be done or not). --- ghc/lib/std/PrelHandle.hs | 77 +++++++++++++++++++++++---------------- ghc/lib/std/PrelIO.hs | 24 ++++++------ ghc/lib/std/PrelIOBase.lhs | 3 +- ghc/lib/std/cbits/HsStd.h | 5 ++- ghc/lib/std/cbits/PrelIOUtils.c | 15 +++++++- ghc/lib/std/cbits/PrelIOUtils.h | 4 +- 6 files changed, 78 insertions(+), 50 deletions(-) diff --git a/ghc/lib/std/PrelHandle.hs b/ghc/lib/std/PrelHandle.hs index 57f85a1..58214f3 100644 --- a/ghc/lib/std/PrelHandle.hs +++ b/ghc/lib/std/PrelHandle.hs @@ -4,7 +4,7 @@ #undef DEBUG -- ----------------------------------------------------------------------------- --- $Id: PrelHandle.hs,v 1.3 2001/11/14 11:39:29 simonmar Exp $ +-- $Id: PrelHandle.hs,v 1.4 2001/11/26 20:04:00 sof Exp $ -- -- (c) The University of Glasgow, 1994-2001 -- @@ -232,7 +232,7 @@ checkReadableHandle act handle_ = let ref = haBuffer handle_ buf <- readIORef ref when (bufferIsWritable buf) $ do - new_buf <- flushWriteBuffer (haFD handle_) buf + new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf writeIORef ref new_buf{ bufState=ReadBuffer } act handle_ _other -> act handle_ @@ -308,7 +308,12 @@ handleFinalizer m = do let fd = fromIntegral (haFD h_) unlockFile fd -- ToDo: closesocket() for a WINSOCK socket? - when (fd /= -1) (c_close fd >> return ()) + when (fd /= -1) +#ifdef mingw32_TARGET_OS + (c_close fd >> return ()) +#else + (closeFd (haIsStream handle_ fd >> return ()) +#endif return () -- --------------------------------------------------------------------------- @@ -375,7 +380,7 @@ flushWriteBufferOnly h_ = do ref = haBuffer h_ buf <- readIORef ref new_buf <- if bufferIsWritable buf - then flushWriteBuffer fd buf + then flushWriteBuffer fd (haIsStream h_) buf else return buf writeIORef ref new_buf @@ -389,7 +394,7 @@ flushBuffer h_ = do flushed_buf <- case bufState buf of ReadBuffer -> flushReadBuffer (haFD h_) buf - WriteBuffer -> flushWriteBuffer (haFD h_) buf + WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf writeIORef ref flushed_buf @@ -410,8 +415,8 @@ flushReadBuffer fd buf (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR) return buf{ bufWPtr=0, bufRPtr=0 } -flushWriteBuffer :: FD -> Buffer -> IO Buffer -flushWriteBuffer fd buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do +flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer +flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do let bytes = w - r #ifdef DEBUG_DUMP puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n") @@ -420,24 +425,24 @@ flushWriteBuffer fd buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do then return (buf{ bufRPtr=0, bufWPtr=0 }) else do res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer" - (write_off (fromIntegral fd) b (fromIntegral r) + (write_off (fromIntegral fd) is_stream b (fromIntegral r) (fromIntegral bytes)) (threadWaitWrite fd) let res' = fromIntegral res if res' < bytes - then flushWriteBuffer fd (buf{ bufRPtr = r + res' }) + then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' }) else return buf{ bufRPtr=0, bufWPtr=0 } foreign import "prel_PrelHandle_write" unsafe - write_off :: CInt -> RawBuffer -> Int -> CInt -> IO CInt + write_off :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -fillReadBuffer :: FD -> Bool -> Buffer -> IO Buffer -fillReadBuffer fd is_line +fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer +fillReadBuffer fd is_line is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } = -- buffer better be empty: assert (r == 0 && w == 0) $ do - fillReadBufferLoop fd is_line buf b w size + fillReadBufferLoop fd is_line is_stream buf b w size -- For a line buffer, we just get the first chunk of data to arrive, -- and don't wait for the whole buffer to be full (but we *do* wait @@ -445,7 +450,7 @@ fillReadBuffer fd is_line -- appears to be what GHC has done for a long time, and I suspect it -- is more useful than line buffering in most cases. -fillReadBufferLoop fd is_line buf b w size = do +fillReadBufferLoop fd is_line is_stream buf b w size = do let bytes = size - w if bytes == 0 -- buffer full? then return buf{ bufRPtr=0, bufWPtr=w } @@ -454,7 +459,7 @@ fillReadBufferLoop fd is_line buf b w size = do puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n") #endif res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer" - (read_off fd b (fromIntegral w) (fromIntegral bytes)) + (read_off fd is_stream b (fromIntegral w) (fromIntegral bytes)) (threadWaitRead fd) let res' = fromIntegral res #ifdef DEBUG_DUMP @@ -465,11 +470,11 @@ fillReadBufferLoop fd is_line buf b w size = do then ioe_EOF else return buf{ bufRPtr=0, bufWPtr=w } else if res' < bytes && not is_line - then fillReadBufferLoop fd is_line buf b (w+res') size + then fillReadBufferLoop fd is_line is_stream buf b (w+res') size else return buf{ bufRPtr=0, bufWPtr=w+res' } foreign import "prel_PrelHandle_read" unsafe - read_off :: FD -> RawBuffer -> Int -> CInt -> IO CInt + read_off :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -- --------------------------------------------------------------------------- -- Standard Handles @@ -599,7 +604,7 @@ openFile' filepath ex_mode = throwErrnoIfMinus1Retry "openFile" (c_open f (fromIntegral oflags) 0o666) - openFd fd filepath mode binary truncate + openFd fd Nothing filepath mode binary truncate -- ASSERT: if we just created the file, then openFd won't fail -- (so we don't need to worry about removing the newly created file -- in the event of an error). @@ -615,8 +620,8 @@ append_flags = write_flags .|. o_APPEND -- --------------------------------------------------------------------------- -- openFd -openFd :: FD -> FilePath -> IOMode -> Bool -> Bool -> IO Handle -openFd fd filepath mode binary truncate = do +openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle +openFd fd mb_fd_type filepath mode binary truncate = do -- turn on non-blocking mode setNonBlockingFD fd @@ -629,15 +634,19 @@ openFd fd filepath mode binary truncate = do -- open() won't tell us if it was a directory if we only opened for -- reading, so check again. - fd_type <- fdType fd + fd_type <- + case mb_fd_type of + Just x -> return x + Nothing -> fdType fd + let is_stream = fd_type == Stream case fd_type of Directory -> ioException (IOError Nothing InappropriateType "openFile" "is a directory" Nothing) Stream - | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath binary - | otherwise -> mkFileHandle fd filepath ha_type binary + | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary + | otherwise -> mkFileHandle fd is_stream filepath ha_type binary -- regular files need to be locked RegularFile -> do @@ -649,7 +658,7 @@ openFd fd filepath mode binary truncate = do -- truncate the file if necessary when truncate (fileTruncate filepath) - mkFileHandle fd filepath ha_type binary + mkFileHandle fd is_stream filepath ha_type binary foreign import "lockFile" unsafe @@ -666,6 +675,7 @@ mkStdHandle fd filepath ha_type buf bmode = do (Handle__ { haFD = fd, haType = ha_type, haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, + haIsStream = False, haBufferMode = bmode, haFilePath = filepath, haBuffer = buf, @@ -673,14 +683,15 @@ mkStdHandle fd filepath ha_type buf bmode = do haOtherSide = Nothing }) -mkFileHandle :: FD -> FilePath -> HandleType -> Bool -> IO Handle -mkFileHandle fd filepath ha_type binary = 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) spares <- newIORef BufferListNil newFileHandle handleFinalizer (Handle__ { haFD = fd, haType = ha_type, haIsBin = binary, + haIsStream = is_stream, haBufferMode = bmode, haFilePath = filepath, haBuffer = buf, @@ -688,14 +699,15 @@ mkFileHandle fd filepath ha_type binary = do haOtherSide = Nothing }) -mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle -mkDuplexHandle fd filepath binary = do +mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle +mkDuplexHandle fd is_stream filepath binary = do (w_buf, w_bmode) <- getBuffer fd WriteBuffer w_spares <- newIORef BufferListNil let w_handle_ = Handle__ { haFD = fd, haType = WriteHandle, haIsBin = binary, + haIsStream = is_stream, haBufferMode = w_bmode, haFilePath = filepath, haBuffer = w_buf, @@ -710,6 +722,7 @@ mkDuplexHandle fd filepath binary = do Handle__ { haFD = fd, haType = ReadHandle, haIsBin = binary, + haIsStream = is_stream, haBufferMode = r_bmode, haFilePath = filepath, haBuffer = r_buf, @@ -756,7 +769,7 @@ hClose_help handle_ = -- close the file descriptor, but not when this is the read side -- of a duplex handle. case haOtherSide handle_ of - Nothing -> throwErrnoIfMinus1Retry_ "hClose" (c_close fd) + Nothing -> throwErrnoIfMinus1Retry_ "hClose" (closeFd (haIsStream handle_) fd) Just _ -> return () -- free the spare buffers @@ -825,7 +838,7 @@ hLookAhead handle = do -- fill up the read buffer if necessary new_buf <- if bufferEmpty buf - then fillReadBuffer fd is_line buf + then fillReadBuffer fd is_line (haIsStream handle_) buf else return buf writeIORef ref new_buf @@ -914,7 +927,7 @@ hFlush handle = wantWritableHandle "hFlush" handle $ \ handle_ -> do buf <- readIORef (haBuffer handle_) if bufferIsWritable buf && not (bufferEmpty buf) - then do flushed_buf <- flushWriteBuffer (haFD handle_) buf + then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf writeIORef (haBuffer handle_) flushed_buf else return () @@ -1028,7 +1041,7 @@ hSeek handle mode offset = SeekFromEnd -> sEEK_END if bufferIsWritable buf - then do new_buf <- flushWriteBuffer fd buf + then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf writeIORef ref new_buf do_seek else do diff --git a/ghc/lib/std/PrelIO.hs b/ghc/lib/std/PrelIO.hs index d30dc9d..6c2e612 100644 --- a/ghc/lib/std/PrelIO.hs +++ b/ghc/lib/std/PrelIO.hs @@ -3,7 +3,7 @@ #undef DEBUG_DUMP -- ----------------------------------------------------------------------------- --- $Id: PrelIO.hs,v 1.3 2001/11/14 11:35:23 simonmar Exp $ +-- $Id: PrelIO.hs,v 1.4 2001/11/26 20:04:00 sof Exp $ -- -- (c) The University of Glasgow, 1992-2001 -- @@ -162,16 +162,16 @@ hGetChar handle = -- buffer is empty. case haBufferMode handle_ of LineBuffering -> do - new_buf <- fillReadBuffer fd True buf + new_buf <- fillReadBuffer fd True (haIsStream handle_) buf hGetcBuffered fd ref new_buf BlockBuffering _ -> do - new_buf <- fillReadBuffer fd False buf + new_buf <- fillReadBuffer fd False (haIsStream handle_) buf hGetcBuffered fd ref new_buf NoBuffering -> do -- make use of the minimal buffer we already have let raw = bufBuf buf r <- throwErrnoIfMinus1RetryMayBlock "hGetChar" - (read_off (fromIntegral fd) raw 0 1) + (read_off (fromIntegral fd) (haIsStream handle_) raw 0 1) (threadWaitRead fd) if r == 0 then ioe_EOF @@ -241,7 +241,7 @@ hGetLineBufferedLoop handle_ ref else writeIORef ref buf{ bufRPtr = off + 1 } return (concat (reverse (xs:xss))) else do - maybe_buf <- maybeFillReadBuffer (haFD handle_) True + maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_) buf{ bufWPtr=0, bufRPtr=0 } case maybe_buf of -- Nothing indicates we caught an EOF, and we may have a @@ -254,9 +254,9 @@ hGetLineBufferedLoop handle_ ref hGetLineBufferedLoop handle_ ref new_buf (xs:xss) -maybeFillReadBuffer fd is_line buf +maybeFillReadBuffer fd is_line is_stream buf = catch - (do buf <- fillReadBuffer fd is_line buf + (do buf <- fillReadBuffer fd is_line is_stream buf return (Just buf) ) (\e -> do if isEOFError e @@ -351,7 +351,7 @@ lazyRead' h handle_ = do -- make use of the minimal buffer we already have let raw = bufBuf buf r <- throwErrnoIfMinus1RetryMayBlock "lazyRead" - (read_off (fromIntegral fd) raw 0 1) + (read_off (fromIntegral fd) (haIsStream handle_) raw 0 1) (threadWaitRead fd) if r == 0 then do handle_ <- hClose_help handle_ @@ -367,7 +367,7 @@ lazyRead' h handle_ = do -- is_line==True, which tells it to "just read what there is". lazyReadBuffered h handle_ fd ref buf = do catch - (do buf <- fillReadBuffer fd True{-is_line-} buf + (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf lazyReadHaveBuffer h handle_ fd ref buf ) -- all I/O errors are discarded. Additionally, we close the handle. @@ -422,7 +422,7 @@ hPutcBuffered handle_ is_line c = do let new_buf = buf{ bufWPtr = w' } if bufferFull new_buf || is_line && c == '\n' then do - flushed_buf <- flushWriteBuffer (haFD handle_) new_buf + flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf writeIORef ref flushed_buf else do writeIORef ref new_buf @@ -598,7 +598,7 @@ commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release return (newEmptyBuffer raw WriteBuffer sz) -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd old_buf + else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf let this_buf = Buffer{ bufBuf=raw, bufState=WriteBuffer, @@ -616,7 +616,7 @@ commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release -- otherwise, we have to flush the new data too, -- and start with a fresh buffer else do - flushWriteBuffer fd this_buf + flushWriteBuffer fd (haIsStream handle_) this_buf writeIORef ref flushed_buf -- if the sizes were different, then allocate -- a new buffer of the correct size. diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index 0a8f8c2..ef862df 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelIOBase.lhs,v 1.44 2001/11/14 11:39:29 simonmar Exp $ +% $Id: PrelIOBase.lhs,v 1.45 2001/11/26 20:04:00 sof Exp $ % % (c) The University of Glasgow, 1994-2001 % @@ -152,6 +152,7 @@ data Handle__ haFD :: !FD, -- file descriptor haType :: HandleType, -- type (read/write/append etc.) haIsBin :: Bool, -- binary mode? + haIsStream :: Bool, -- is this a stream handle? haBufferMode :: BufferMode, -- buffer contains read/write data? haFilePath :: FilePath, -- file name, possibly haBuffer :: !(IORef Buffer), -- the current buffer diff --git a/ghc/lib/std/cbits/HsStd.h b/ghc/lib/std/cbits/HsStd.h index 5c9e932..8957189 100644 --- a/ghc/lib/std/cbits/HsStd.h +++ b/ghc/lib/std/cbits/HsStd.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: HsStd.h,v 1.4 2001/08/17 11:06:58 simonmar Exp $ + * $Id: HsStd.h,v 1.5 2001/11/26 20:04:00 sof Exp $ * * Definitions for package `std' which are visible in Haskell land. * @@ -56,6 +56,9 @@ #ifdef HAVE_SYS_TIMES_H #include #endif +#ifdef HAVE_WINSOCK_H +#include +#endif #if !defined(mingw32_TARGET_OS) && !defined(irix_TARGET_OS) # if defined(HAVE_SYS_RESOURCE_H) diff --git a/ghc/lib/std/cbits/PrelIOUtils.c b/ghc/lib/std/cbits/PrelIOUtils.c index 109c555..8f7b8c6 100644 --- a/ghc/lib/std/cbits/PrelIOUtils.c +++ b/ghc/lib/std/cbits/PrelIOUtils.c @@ -65,14 +65,25 @@ HsInt prel_setmode(HsInt fd, HsBool toBin) #endif } -HsInt prel_PrelHandle_write(HsInt fd, HsAddr ptr, HsInt off, int sz) +HsInt prel_PrelHandle_write(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz) { +#ifdef _WIN32 + if (isSock) { + return send(fd,ptr + off, sz, 0); + } +#endif return write(fd,ptr + off, sz); } -HsInt prel_PrelHandle_read(HsInt fd, HsAddr ptr, HsInt off, int sz) +HsInt prel_PrelHandle_read(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz) { +#ifdef _WIN32 + if (isSock) { + return recv(fd,ptr + off, sz, 0); + } +#endif return read(fd,ptr + off, sz); + } void *prel_PrelIO_memcpy(char *dst, HsInt dst_off, const char *src, size_t sz) diff --git a/ghc/lib/std/cbits/PrelIOUtils.h b/ghc/lib/std/cbits/PrelIOUtils.h index 72d42e2..8dd19c1 100644 --- a/ghc/lib/std/cbits/PrelIOUtils.h +++ b/ghc/lib/std/cbits/PrelIOUtils.h @@ -17,8 +17,8 @@ extern HsInt prel_o_binary(); extern HsInt prel_setmode(HsInt fd, HsBool isBin); -extern HsInt prel_PrelHandle_write(HsInt fd, HsAddr ptr, HsInt off, int sz); -extern HsInt prel_PrelHandle_read(HsInt fd, HsAddr ptr, HsInt off, int sz); +extern HsInt prel_PrelHandle_write(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz); +extern HsInt prel_PrelHandle_read(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz); extern void* prel_PrelIO_memcpy(char *dst, HsInt dst_off, const char *src, size_t sz); -- 1.7.10.4