which are supported for them.
\begin{code}
-{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
+{-# OPTIONS -fcompiling-prelude -fno-implicit-prelude -#include "cbits/stgio.h" #-}
#include "cbits/stgerror.h"
#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
module PrelHandle where
+import PrelArr
import PrelBase
import PrelAddr ( Addr, nullAddr )
-import PrelArr ( newVar, readVar, writeVar, ByteArray(..) )
+import PrelByteArr ( ByteArray(..), MutableByteArray(..) )
import PrelRead ( Read )
import PrelList ( span )
import PrelIOBase
import PrelException
import PrelMaybe ( Maybe(..) )
import PrelEnum
-import PrelNum
+import PrelNum ( toBig, Integer(..), Num(..) )
import PrelShow
import PrelAddr ( Addr, nullAddr )
-import PrelNum ( toInteger, toBig )
+import PrelReal ( toInteger )
import PrelPack ( packString )
+#ifndef __PARALLEL_HASKELL__
import PrelWeak ( addForeignFinalizer )
-import Ix
+#endif
-#ifdef __CONCURRENT_HASKELL__
import PrelConc
-#endif
#ifndef __PARALLEL_HASKELL__
import PrelForeign ( makeForeignObj )
\begin{code}
{-# INLINE newHandle #-}
-{-# 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}
%*********************************************************
but we might want to revisit this in the future --SDM ].
\begin{code}
-#ifdef __CONCURRENT_HASKELL__
withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
+{-# INLINE withHandle #-}
withHandle (Handle h) act = do
h_ <- takeMVar h
(h',v) <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
return v
withHandle_ :: Handle -> (Handle__ -> IO a) -> IO a
+{-# INLINE withHandle_ #-}
withHandle_ (Handle h) act = do
h_ <- takeMVar h
v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
return v
withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO ()
+{-# INLINE withHandle__ #-}
withHandle__ (Handle h) act = do
h_ <- takeMVar h
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
%*********************************************************
%* *
-\subsection[EOF]{Detecting the End of Input}
+\subsection[FileSize]{Detecting the size of a file}
%* *
%*********************************************************
#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
\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
isWritable _ = False
-#ifndef __PARALLEL_HASKELL__
-getBMode__ :: ForeignObj -> IO (BufferMode, Int)
-#else
-getBMode__ :: Addr -> IO (BufferMode, Int)
-#endif
+getBMode__ :: FILE_OBJECT -> IO (BufferMode, Int)
getBMode__ fo = do
rc <- getBufferMode fo -- ConcHask: SAFE, won't block
case (rc::Int) of
wantRWHandle "hConnectTo" hW $ \ hW_ ->
wantRWHandle "hConnectTo" hR $ \ hR_ -> do
setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
-
-#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT ForeignObj
-#else
-#define FILE_OBJECT Addr
-#endif
-
\end{code}
As an extension, we also allow characters to be pushed back.
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)
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
| 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
\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}
of IO:
\begin{code}
-#ifndef __PARALLEL_HASKELL__
-mayBlock :: ForeignObj -> IO Int -> IO Int
-#else
-mayBlock :: Addr -> IO Int -> IO Int
-#endif
-
+mayBlock :: FILE_OBJECT -> IO Int -> IO Int
mayBlock fo act = do
rc <- act
case rc of
mayBlock fo act -- output possible
_ -> do
return rc
+
+data MayBlock
+ = BlockRead Int
+ | BlockWrite Int
+ | NoBlock Int
+
+mayBlockRead :: String -> Handle -> (FILE_OBJECT -> 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 -> (FILE_OBJECT -> 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:
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-}
projects / ghc-hetmet.git / blobdiff