X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelHandle.lhs;h=4222bd51ae3726b92d2c2eb0cbb09354473c6151;hb=716d91c23d0f9a62474098d32eb6237ebe755944;hp=d65c234e858bae8df915db2bfe8e62bd01033299;hpb=1b28d4e1f43185ad8c8e7407c66413e1b358402b;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index d65c234..4222bd5 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -16,8 +16,7 @@ module PrelHandle where import PrelBase import PrelAddr ( Addr, nullAddr ) -import PrelArr ( newVar, readVar, writeVar ) -import PrelByteArr ( ByteArray(..) ) +import PrelByteArr ( ByteArray(..), MutableByteArray(..) ) import PrelRead ( Read ) import PrelList ( span ) import PrelIOBase @@ -34,9 +33,7 @@ import PrelWeak ( addForeignFinalizer ) #endif import Ix -#ifdef __CONCURRENT_HASKELL__ import PrelConc -#endif #ifndef __PARALLEL_HASKELL__ import PrelForeign ( makeForeignObj ) @@ -69,17 +66,9 @@ The @Handle@ and @Handle__@ types are defined in @IOBase@. {-# INLINE withHandle #-} newHandle :: Handle__ -> IO Handle -#if defined(__CONCURRENT_HASKELL__) - -- Use MVars for concurrent Haskell newHandle hc = newMVar hc >>= \ h -> return (Handle h) -#else - --- Use ordinary MutableVars for non-concurrent Haskell -newHandle hc = stToIO (newVar hc >>= \ h -> - return (Handle h)) -#endif \end{code} %********************************************************* @@ -109,7 +98,6 @@ orignal handle is always replaced [ this is the case at the moment, but we might want to revisit this in the future --SDM ]. \begin{code} -#ifdef __CONCURRENT_HASKELL__ withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a withHandle (Handle h) act = do h_ <- takeMVar h @@ -130,17 +118,6 @@ withHandle__ (Handle h) act = do h' <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) putMVar h h' return () - -#else - -- of questionable value to install this exception - -- handler, but let's do it in the non-concurrent - -- case too, for now. -withHandle (Handle h) act = do - h_ <- stToIO (readVar h) - v <- catchException (act h_) (\ ex -> stToIO (writeVar h h_) >> throw ex) - return v - -#endif \end{code} nullFile__ is only used for closed handles, plugging it in as a null @@ -388,7 +365,7 @@ sent to the operating system are flushed as for $flush$. %********************************************************* %* * -\subsection[EOF]{Detecting the End of Input} +\subsection[FileSize]{Detecting the size of a file} %* * %********************************************************* @@ -430,6 +407,13 @@ hFileSize handle = #endif \end{code} +%********************************************************* +%* * +\subsection[EOF]{Detecting the End of Input} +%* * +%********************************************************* + + For a readable handle {\em hdl}, @hIsEOF hdl@ returns @True@ if no further input can be taken from @hdl@ or for a physical file, if the current I/O position is equal to the length of @@ -437,10 +421,8 @@ the file. Otherwise, it returns @False@. \begin{code} hIsEOF :: Handle -> IO Bool -hIsEOF handle = - wantReadableHandle "hIsEOF" handle $ \ handle_ -> do - let fo = haFO__ handle_ - rc <- mayBlock fo (fileEOF fo) -- ConcHask: UNSAFE, may block +hIsEOF handle = do + rc <- mayBlockRead "hIsEOF" handle fileEOF case rc of 0 -> return False 1 -> return True @@ -890,7 +872,7 @@ slurpFile fname = do else do rc <- withHandle_ handle ( \ handle_ -> do let fo = haFO__ handle_ - mayBlock fo (readChunk fo chunk sz_i) -- ConcHask: UNSAFE, may block. + mayBlock fo (readChunk fo chunk 0 sz_i) -- ConcHask: UNSAFE, may block. ) hClose handle if rc < (0::Int) @@ -898,19 +880,19 @@ slurpFile fname = do else return (chunk, rc) #ifndef __HUGS__ /* Hugs' Prelude doesn't need this */ -hFillBufBA :: Handle -> ByteArray Int -> Int -> IO Int +hFillBufBA :: Handle -> MutableByteArray RealWorld a -> Int -> IO Int hFillBufBA handle buf sz | sz <= 0 = ioError (IOError (Just handle) InvalidArgument "hFillBufBA" ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified. - | otherwise = - wantReadableHandle "hFillBufBA" handle $ \ handle_ -> do - let fo = haFO__ handle_ - rc <- mayBlock fo (readChunkBA fo buf sz) -- ConcHask: UNSAFE, may block. - if rc >= (0::Int) - then return rc - else constructErrorAndFail "hFillBufBA" + | otherwise = hFillBuf' sz 0 + where + hFillBuf' sz len = do + r <- mayBlockRead "hFillBufBA" handle (\fo -> readChunkBA fo buf len sz) + if r >= sz || r == 0 -- r == 0 indicates EOF + then return (len+r) + else hFillBuf' (sz-r) (len+r) #endif hFillBuf :: Handle -> Addr -> Int -> IO Int @@ -918,15 +900,15 @@ hFillBuf handle buf sz | sz <= 0 = ioError (IOError (Just handle) InvalidArgument "hFillBuf" - ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified. - | otherwise = - wantReadableHandle "hFillBuf" handle $ \ handle_ -> do - let fo = haFO__ handle_ - rc <- mayBlock fo (readChunk fo buf sz) -- ConcHask: UNSAFE, may block. - if rc >= 0 - then return rc - else constructErrorAndFail "hFillBuf" - + ("illegal buffer size " ++ showsPrec 9 sz [])) + -- 9 => should be parens'ified. + | otherwise = hFillBuf' sz 0 + where + hFillBuf' sz len = do + r <- mayBlockRead "hFillBuf" handle (\fo -> readChunk fo buf len sz) + if r >= sz || r == 0 -- r == 0 indicates EOF + then return (len+r) + else hFillBuf' (sz-r) (len+r) \end{code} The @hPutBuf hdl buf len@ action writes an already packed sequence of @@ -934,23 +916,35 @@ bytes to the file/channel managed by @hdl@ - non-standard. \begin{code} hPutBuf :: Handle -> Addr -> Int -> IO () -hPutBuf handle buf len = - wantWriteableHandle "hPutBuf" handle $ \ handle_ -> do - let fo = haFO__ handle_ - rc <- mayBlock fo (writeBuf fo buf len) -- ConcHask: UNSAFE, may block. - if rc == (0::Int) - then return () - else constructErrorAndFail "hPutBuf" +hPutBuf handle buf sz + | sz <= 0 = ioError (IOError (Just handle) + InvalidArgument + "hPutBuf" + ("illegal buffer size " ++ showsPrec 9 sz [])) + -- 9 => should be parens'ified. + | otherwise = hPutBuf' sz 0 + where + hPutBuf' sz len = do + r <- mayBlockWrite "hPutBuf" handle (\fo -> writeBuf fo buf len sz) + if r >= sz + then return () + else hPutBuf' (sz-r) (len+r) -- <= sz indicates blocking #ifndef __HUGS__ /* An_ one Hugs doesn't provide */ -hPutBufBA :: Handle -> ByteArray Int -> Int -> IO () -hPutBufBA handle buf len = - wantWriteableHandle "hPutBufBA" handle $ \ handle_ -> do - let fo = haFO__ handle_ - rc <- mayBlock fo (writeBufBA fo buf len) -- ConcHask: UNSAFE, may block. - if rc == (0::Int) - then return () - else constructErrorAndFail "hPutBuf" +hPutBufBA :: Handle -> MutableByteArray RealWorld a -> Int -> IO () +hPutBufBA handle buf sz + | sz <= 0 = ioError (IOError (Just handle) + InvalidArgument + "hPutBufBA" + ("illegal buffer size " ++ showsPrec 9 sz [])) + -- 9 => should be parens'ified. + | otherwise = hPutBuf' sz 0 + where + hPutBuf' sz len = do + r <- mayBlockWrite "hPutBufBA" handle (\fo -> writeBufBA fo buf len sz) + if r >= sz + then return () + else hPutBuf' (sz-r) (len+r) -- <= sz indicates blocking #endif \end{code} @@ -1142,6 +1136,67 @@ mayBlock fo act = do mayBlock fo act -- output possible _ -> do return rc + +data MayBlock + = BlockRead Int + | BlockWrite Int + | NoBlock Int + +mayBlockRead :: String -> Handle -> (ForeignObj -> IO Int) -> IO Int +mayBlockRead fname handle fn = do + r <- wantReadableHandle fname handle $ \ handle_ -> do + let fo = haFO__ handle_ + rc <- fn fo + case rc of + -5 -> do -- (possibly blocking) read + fd <- getFileFd fo + return (BlockRead fd) + -6 -> do -- (possibly blocking) write + fd <- getFileFd fo + return (BlockWrite fd) + -7 -> do -- (possibly blocking) write on connected handle + fd <- getConnFileFd fo + return (BlockWrite fd) + _ -> + if rc >= 0 + then return (NoBlock rc) + else constructErrorAndFail fname + case r of + BlockRead fd -> do + threadWaitRead fd + mayBlockRead fname handle fn + BlockWrite fd -> do + threadWaitWrite fd + mayBlockRead fname handle fn + NoBlock c -> return c + +mayBlockWrite :: String -> Handle -> (ForeignObj -> IO Int) -> IO Int +mayBlockWrite fname handle fn = do + r <- wantWriteableHandle fname handle $ \ handle_ -> do + let fo = haFO__ handle_ + rc <- fn fo + case rc of + -5 -> do -- (possibly blocking) read + fd <- getFileFd fo + return (BlockRead fd) + -6 -> do -- (possibly blocking) write + fd <- getFileFd fo + return (BlockWrite fd) + -7 -> do -- (possibly blocking) write on connected handle + fd <- getConnFileFd fo + return (BlockWrite fd) + _ -> + if rc >= 0 + then return (NoBlock rc) + else constructErrorAndFail fname + case r of + BlockRead fd -> do + threadWaitRead fd + mayBlockWrite fname handle fn + BlockWrite fd -> do + threadWaitWrite fd + mayBlockWrite fname handle fn + NoBlock c -> return c \end{code} Foreign import declarations of helper functions: @@ -1211,14 +1266,14 @@ foreign import "libHS_cbits" "setConnectedTo" unsafe foreign import "libHS_cbits" "ungetChar" unsafe ungetChar :: FILE_OBJECT -> Char -> IO Int{-ret code-} foreign import "libHS_cbits" "readChunk" unsafe - readChunk :: FILE_OBJECT -> Addr -> Int -> IO Int{-ret code-} + readChunk :: FILE_OBJECT -> Addr -> Int -> Int -> IO Int{-ret code-} foreign import "libHS_cbits" "readChunk" unsafe - readChunkBA :: FILE_OBJECT -> ByteArray Int -> Int -> IO Int{-ret code-} + readChunkBA :: FILE_OBJECT -> MutableByteArray s a -> Int -> Int -> IO Int{-ret code-} foreign import "libHS_cbits" "writeBuf" unsafe - writeBuf :: FILE_OBJECT -> Addr -> Int -> IO Int{-ret code-} + writeBuf :: FILE_OBJECT -> Addr -> Int -> Int -> IO Int{-ret code-} #ifndef __HUGS__ foreign import "libHS_cbits" "writeBufBA" unsafe - writeBufBA :: FILE_OBJECT -> ByteArray Int -> Int -> IO Int{-ret code-} + writeBufBA :: FILE_OBJECT -> MutableByteArray s a -> Int -> Int -> IO Int{-ret code-} #endif foreign import "libHS_cbits" "getFileFd" unsafe getFileFd :: FILE_OBJECT -> IO Int{-fd-}