+% ------------------------------------------------------------------------------
+% $Id: PrelHandle.lhs,v 1.63 2000/11/07 10:42:56 simonmar Exp $
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-2000
%
\section[PrelHandle]{Module @PrelHandle@}
which are supported for them.
\begin{code}
-{-# OPTIONS -fcompiling-prelude -fno-implicit-prelude -#include "cbits/stgio.h" #-}
+{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
#include "cbits/stgerror.h"
#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
import PrelArr
import PrelBase
import PrelAddr ( Addr, nullAddr )
-import PrelByteArr ( ByteArray(..), MutableByteArray(..) )
+import PrelByteArr ( ByteArray(..) )
import PrelRead ( Read )
import PrelList ( span )
import PrelIOBase
-import PrelException
import PrelMaybe ( Maybe(..) )
+import PrelException
import PrelEnum
import PrelNum ( toBig, Integer(..), Num(..) )
import PrelShow
#endif
\end{code}
+\begin{code}
+mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
+mkBuffer__ fo sz_in_bytes = do
+ chunk <-
+ case sz_in_bytes of
+ 0 -> return nullAddr -- this has the effect of overwriting the pointer to the old buffer.
+ _ -> do
+ chunk <- malloc sz_in_bytes
+ if chunk == nullAddr
+ then ioException (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
+ else return chunk
+ setBuf fo chunk sz_in_bytes
+\end{code}
+
%*********************************************************
%* *
\subsection{Types @Handle@, @Handle__@}
withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
{-# INLINE withHandle #-}
withHandle (Handle h) act =
- blockAsyncExceptions $ do
+ block $ do
h_ <- takeMVar h
(h',v) <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
putMVar h h'
withHandle_ :: Handle -> (Handle__ -> IO a) -> IO a
{-# INLINE withHandle_ #-}
withHandle_ (Handle h) act =
- blockAsyncExceptions $ do
+ block $ do
h_ <- takeMVar h
v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
putMVar h h_
withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO ()
{-# INLINE withHandle__ #-}
withHandle__ (Handle h) act =
- blockAsyncExceptions $ do
+ block $ do
h_ <- takeMVar h
h' <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
putMVar h h'
haFilePath__ = "closed file",
haBuffers__ = []
}
-
-mkErrorHandle__ :: IOError -> Handle__
-mkErrorHandle__ ioe =
- Handle__ { haFO__ = nullFile__,
- haType__ = (ErrorHandle ioe),
- haBufferMode__ = NoBuffering,
- haFilePath__ = "error handle",
- haBuffers__ = []
- }
\end{code}
%*********************************************************
#endif
return hdl
- _ -> do ioError <- constructError "stdout"
- newHandle (mkErrorHandle__ ioError)
+ _ -> constructErrorAndFail "stdout"
)
stdin = unsafePerformIO (do
#endif
hConnectTerms stdout hdl
return hdl
- _ -> do ioError <- constructError "stdin"
- newHandle (mkErrorHandle__ ioError)
+ _ -> constructErrorAndFail "stdin"
)
hConnectTo stdout hdl
return hdl
- _ -> do ioError <- constructError "stderr"
- newHandle (mkErrorHandle__ ioError)
+ _ -> constructErrorAndFail "stderr"
)
\end{code}
hClose handle =
withHandle__ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> return handle_
_ -> do
rc <- closeFile (haFO__ handle_)
-- associated with this handle.
else do freeBuffers (haBuffers__ handle_)
return (handle_{ haType__ = ClosedHandle,
- haFO__ = nullFile__,
haBuffers__ = [] })
\end{code}
hFileSize handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hFileSize" handle
SemiClosedHandle -> ioe_closedHandle "hFileSize" handle
#ifdef __HUGS__
hSetBuffering handle mode =
case mode of
BlockBuffering (Just n)
- | n <= 0 -> ioError
+ | n <= 0 -> ioException
(IOError (Just handle)
InvalidArgument
"hSetBuffering"
- ("illegal buffer size " ++ showsPrec 9 n [])) -- 9 => should be parens'ified.
+ ("illegal buffer size " ++ showsPrec 9 n []))
+ -- 9 => should be parens'ified.
_ ->
withHandle__ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hSetBuffering" handle
_ -> do
{- Note:
hIsOpen handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> return False
SemiClosedHandle -> return False
_ -> return True
hIsClosed handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> return True
_ -> return False
hIsReadable handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hIsReadable" handle
SemiClosedHandle -> ioe_closedHandle "hIsReadable" handle
htype -> return (isReadable htype)
hIsWritable handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hIsWritable" handle
SemiClosedHandle -> ioe_closedHandle "hIsWritable" handle
htype -> return (isWritable htype)
hGetBuffering handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hGetBuffering" handle
_ ->
{-
hIsSeekable handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hIsSeekable" handle
SemiClosedHandle -> ioe_closedHandle "hIsSeekable" handle
AppendHandle -> return False
else
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hSetEcho" handle
_ -> do
rc <- setTerminalEcho (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block
else
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hGetEcho" handle
_ -> do
rc <- getTerminalEcho (haFO__ handle_) -- ConcHask: SAFE, won't block
hIsTerminalDevice handle = do
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hIsTerminalDevice" handle
_ -> do
rc <- isTerminalDevice (haFO__ handle_) -- ConcHask: SAFE, won't block
ioError (userError "slurpFile: file too big")
else do
let sz_i = fromInteger sz
- chunk <- allocMemory__ sz_i
+ chunk <- malloc sz_i
if chunk == nullAddr
then do
hClose handle
getHandleFd handle =
withHandle_ handle $ \ handle_ -> do
case (haType__ handle_) of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "getHandleFd" handle
_ -> do
fd <- getFileFd (haFO__ handle_)
ioeGetErrorString :: IOError -> String
ioeGetHandle :: IOError -> Maybe Handle
-ioeGetHandle (IOError h _ _ _) = h
-ioeGetErrorString (IOError _ iot _ str) =
+ioeGetHandle (IOException (IOError h _ _ _)) = h
+ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
+
+ioeGetErrorString (IOException (IOError _ iot _ str)) =
case iot of
EOF -> "end of file"
_ -> str
+ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
-ioeGetFileName (IOError _ _ _ str) =
+ioeGetFileName (IOException (IOError _ _ _ str)) =
case span (/=':') str of
(_,[]) -> Nothing
(fs,_) -> Just fs
-
+ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
\end{code}
'Top-level' IO actions want to catch exceptions (e.g., forkIO and
else
return ()
-foreign label "ErrorHdrHook"
+foreign import ccall "addrOf_ErrorHdrHook" unsafe
addrOf_ErrorHdrHook :: Addr
foreign import ccall "writeErrString__" unsafe
writeErrString :: Addr -> ByteArray Int -> Int -> IO ()
-foreign import ccall "stackOverflow"
+-- SUP: Are the hooks allowed to re-enter Haskell land? If yes, remove the unsafe below.
+foreign import ccall "stackOverflow" unsafe
callStackOverflowHook :: IO ()
-foreign import ccall "stg_exit"
+foreign import ccall "stg_exit" unsafe
stg_exit :: Int -> IO ()
\end{code}
wantReadableHandle fun handle act =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
- AppendHandle -> ioError not_readable_error
- WriteHandle -> ioError not_readable_error
+ AppendHandle -> ioException not_readable_error
+ WriteHandle -> ioException not_readable_error
_ -> act handle_
where
not_readable_error =
checkWriteableHandle fun handle handle_ act
= case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
ReadHandle -> ioError not_writeable_error
_ -> act
where
not_writeable_error =
- IOError (Just handle) IllegalOperation fun
- ("handle is not open for writing")
+ IOException (IOError (Just handle) IllegalOperation fun
+ ("handle is not open for writing"))
wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantRWHandle fun handle act =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
_ -> act handle_
wantSeekableHandle fun handle act =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
_ -> act handle_
- where
- not_seekable_error =
- IOError (Just handle)
- IllegalOperation fun
- ("handle is not seekable")
-
\end{code}
Internal function for creating an @IOError@ representing the
\begin{code}
ioe_closedHandle :: String -> Handle -> IO a
-ioe_closedHandle fun h = ioError (IOError (Just h) IllegalOperation fun "handle is closed")
+ioe_closedHandle fun h = ioError (IOException (IOError (Just h) IllegalOperation fun
+ "handle is closed"))
\end{code}
Internal helper functions for Concurrent Haskell implementation
_ -> do
return rc
-data MayBlock
+data MayBlock a
= BlockRead Int
| BlockWrite Int
- | NoBlock Int
+ | NoBlock a
mayBlockRead :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int
mayBlockRead fname handle fn = do
mayBlockRead fname handle fn
NoBlock c -> return c
+mayBlockRead' :: String -> Handle
+ -> (FILE_OBJECT -> IO Int)
+ -> (FILE_OBJECT -> Int -> IO a)
+ -> IO a
+mayBlockRead' fname handle fn io = 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 do a <- io fo rc
+ return (NoBlock a)
+ else constructErrorAndFail fname
+ case r of
+ BlockRead fd -> do
+ threadWaitRead fd
+ mayBlockRead' fname handle fn io
+ BlockWrite fd -> do
+ threadWaitWrite fd
+ mayBlockRead' fname handle fn io
+ NoBlock c -> return c
+
mayBlockWrite :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int
mayBlockWrite fname handle fn = do
r <- wantWriteableHandle fname handle $ \ handle_ -> do
foreign import "libHS_cbits" "const_BUFSIZ" unsafe
const_BUFSIZ :: Int
-foreign import "libHS_cbits" "setBinaryMode__"
+foreign import "libHS_cbits" "setBinaryMode__" unsafe
setBinaryMode :: FILE_OBJECT -> Int -> IO Int
\end{code}
projects / ghc-hetmet.git / blobdiff