+% ------------------------------------------------------------------------------
+% $Id: PrelHandle.lhs,v 1.67 2001/02/22 13:17:58 simonpj Exp $
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-2000
%
\section[PrelHandle]{Module @PrelHandle@}
import PrelArr
import PrelBase
-import PrelAddr ( Addr, nullAddr )
-import PrelByteArr ( ByteArray(..), MutableByteArray(..) )
+import PrelPtr
+import PrelByteArr ( ByteArray(..) )
import PrelRead ( Read )
-import PrelList ( span )
+import PrelList ( break )
import PrelIOBase
-import PrelException
import PrelMaybe ( Maybe(..) )
+import PrelException
import PrelEnum
-import PrelNum ( toBig, Integer(..), Num(..) )
+import PrelNum ( toBig, Integer(..), Num(..), int2Integer )
import PrelShow
-import PrelAddr ( Addr, nullAddr )
import PrelReal ( toInteger )
import PrelPack ( packString )
-#ifndef __PARALLEL_HASKELL__
-import PrelWeak ( addForeignFinalizer )
-#endif
import PrelConc
#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( makeForeignObj, mkForeignObj )
+import PrelForeign ( newForeignPtr, mkForeignPtr, addForeignPtrFinalizer )
#endif
#endif /* ndef(__HUGS__) */
#endif
#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT ForeignObj
+#define FILE_OBJECT (ForeignPtr ())
#else
-#define FILE_OBJECT Addr
+#define FILE_OBJECT (Ptr ())
#endif
\end{code}
+\begin{code}
+mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
+mkBuffer__ fo sz_in_bytes = do
+ chunk <-
+ case sz_in_bytes of
+ 0 -> return nullPtr -- this has the effect of overwriting the pointer to the old buffer.
+ _ -> do
+ chunk <- malloc sz_in_bytes
+ if chunk == nullPtr
+ then ioException (IOError Nothing ResourceExhausted
+ "mkBuffer__" "not enough virtual memory" Nothing)
+ 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'
nullFile__ :: FILE_OBJECT
nullFile__ =
#ifndef __PARALLEL_HASKELL__
- unsafePerformIO (makeForeignObj nullAddr (return ()))
+ unsafePerformIO (newForeignPtr nullPtr (return ()))
#else
- nullAddr
+ nullPtr
#endif
haFilePath__ = "closed file",
haBuffers__ = []
}
-
-mkErrorHandle__ :: IOError -> Handle__
-mkErrorHandle__ ioe =
- Handle__ { haFO__ = nullFile__,
- haType__ = (ErrorHandle ioe),
- haBufferMode__ = NoBuffering,
- haFilePath__ = "error handle",
- haBuffers__ = []
- }
\end{code}
%*********************************************************
foreign import "libHS_cbits" "freeFileObject" unsafe
freeFileObject :: FILE_OBJECT -> IO ()
foreign import "free" unsafe
- free :: Addr -> IO ()
+ free :: Ptr a -> IO ()
\end{code}
%*********************************************************
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
+ fo <- mkForeignPtr fo
-- I know this is deprecated, but I couldn't bring myself
- -- to move fixIO into the prelude just so I could use makeForeignObj.
- -- --SDM
+ -- to move fixIO into the prelude just so I could use
+ -- newForeignPtr. --SDM
#endif
#ifdef __HUGS__
hdl <- newHandle (Handle__ fo WriteHandle bm "stdout" [])
#ifndef __PARALLEL_HASKELL__
- addForeignFinalizer fo (stdHandleFinalizer hdl)
+ addForeignPtrFinalizer fo (stdHandleFinalizer hdl)
#endif
return hdl
- _ -> do ioError <- constructError "stdout"
- newHandle (mkErrorHandle__ ioError)
+ _ -> constructErrorAndFail "stdout"
)
stdin = unsafePerformIO (do
(1::Int){-readable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
+ fo <- mkForeignPtr fo
#endif
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
-- that anything buffered on stdout is flushed prior to reading from
-- stdin.
#ifndef __PARALLEL_HASKELL__
- addForeignFinalizer fo (stdHandleFinalizer hdl)
+ addForeignPtrFinalizer fo (stdHandleFinalizer hdl)
#endif
hConnectTerms stdout hdl
return hdl
- _ -> do ioError <- constructError "stdin"
- newHandle (mkErrorHandle__ ioError)
+ _ -> constructErrorAndFail "stdin"
)
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
+ fo <- mkForeignPtr fo
#endif
hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr" [])
-- when stderr and stdout are both connected to a terminal, ensure
-- that anything buffered on stdout is flushed prior to writing to
-- stderr.
#ifndef __PARALLEL_HASKELL__
- addForeignFinalizer fo (stdHandleFinalizer hdl)
+ addForeignPtrFinalizer fo (stdHandleFinalizer hdl)
#endif
hConnectTo stdout hdl
return hdl
- _ -> do ioError <- constructError "stderr"
- newHandle (mkErrorHandle__ ioError)
+ _ -> constructErrorAndFail "stderr"
)
\end{code}
fo <- primOpenFile (packString f)
(file_mode::Int)
(binary::Int) -- ConcHask: SAFE, won't block
- if fo /= nullAddr then do
+ if fo /= nullPtr then do
#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
+ fo <- mkForeignPtr fo
#endif
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
hdl <- newHandle (Handle__ fo htype bm f [])
#ifndef __PARALLEL_HASKELL__
- addForeignFinalizer fo (handleFinalizer hdl)
+ addForeignPtrFinalizer fo (handleFinalizer hdl)
#endif
return hdl
else do
hClose handle =
withHandle__ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> return handle_
_ -> do
rc <- closeFile (haFO__ handle_)
(1::Int){-flush if you can-} -- ConcHask: SAFE, won't block
{- We explicitly close a file object so that we can be told
if there were any errors. Note that after @hClose@
- has been performed, the ForeignObj embedded in the Handle
+ has been performed, the ForeignPtr embedded in the Handle
is still lying around in the heap, so care is taken
- to avoid closing the file object when the ForeignObj
+ to avoid closing the file object when the ForeignPtr
is finalized. (we overwrite the file ptr in the underlying
FileObject with a NULL as part of closeFile())
-}
-- 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.
+ Nothing)
_ ->
withHandle__ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hSetBuffering" handle
_ -> do
{- Note:
wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
posn <- getFilePosn (haFO__ handle_) -- ConcHask: SAFE, won't block
if posn /= -1 then do
- return (mkHandlePosn handle (fromInt posn))
+ return (mkHandlePosn handle (int2Integer posn))
else
constructErrorAndFail "hGetPosn"
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
\begin{code}
-- in one go, read file into an externally allocated buffer.
-slurpFile :: FilePath -> IO (Addr, Int)
+slurpFile :: FilePath -> IO (Ptr (), Int)
slurpFile fname = do
handle <- openFile fname ReadMode
sz <- hFileSize handle
ioError (userError "slurpFile: file too big")
else do
let sz_i = fromInteger sz
- chunk <- allocMemory__ sz_i
- if chunk == nullAddr
+ chunk <- malloc sz_i
+ if chunk == nullPtr
then do
hClose handle
constructErrorAndFail "slurpFile"
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) =
- case iot of
- EOF -> "end of file"
- _ -> str
+ioeGetHandle (IOException (IOError h _ _ _ _)) = h
+ioeGetHandle (UserError _) = Nothing
+ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
-ioeGetFileName (IOError _ _ _ str) =
- case span (/=':') str of
- (_,[]) -> Nothing
- (fs,_) -> Just fs
+ioeGetErrorString (IOException (IOError _ iot _ str _)) =
+ case iot of
+ EOF -> "end of file"
+ _ -> str
+ioeGetErrorString (UserError str) = str
+ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
+ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
+ioeGetFileName (UserError _) = Nothing
+ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
\end{code}
'Top-level' IO actions want to catch exceptions (e.g., forkIO and
return ()
foreign import ccall "addrOf_ErrorHdrHook" unsafe
- addrOf_ErrorHdrHook :: Addr
+ addrOf_ErrorHdrHook :: Ptr ()
foreign import ccall "writeErrString__" unsafe
- writeErrString :: Addr -> ByteArray Int -> Int -> IO ()
+ writeErrString :: Ptr () -> ByteArray Int -> Int -> IO ()
-- SUP: Are the hooks allowed to re-enter Haskell land? If yes, remove the unsafe below.
foreign import ccall "stackOverflow" unsafe
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 =
- IOError (Just handle) IllegalOperation fun
- ("handle is not open for reading")
+ IOError (Just handle) IllegalOperation fun
+ "handle is not open for reading" Nothing
wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantWriteableHandle fun handle act =
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
+ ReadHandle -> ioException not_writeable_error
_ -> act
where
not_writeable_error =
- IOError (Just handle) IllegalOperation fun
- ("handle is not open for writing")
+ IOError (Just handle) IllegalOperation fun
+ "handle is not open for writing" Nothing
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 = ioException (IOError (Just h) IllegalOperation fun
+ "handle is closed" Nothing)
\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" "filePutc" unsafe
filePutc :: FILE_OBJECT -> Char -> IO Int{-ret code-}
foreign import "libHS_cbits" "write_" unsafe
- write_ :: FILE_OBJECT -> Addr -> Int -> IO Int{-ret code-}
+ write_ :: FILE_OBJECT -> Ptr () -> Int -> IO Int{-ret code-}
foreign import "libHS_cbits" "getBufStart" unsafe
- getBufStart :: FILE_OBJECT -> Int -> IO Addr
+ getBufStart :: FILE_OBJECT -> Int -> IO (Ptr ())
foreign import "libHS_cbits" "getWriteableBuf" unsafe
- getWriteableBuf :: FILE_OBJECT -> IO Addr
+ getWriteableBuf :: FILE_OBJECT -> IO (Ptr ())
foreign import "libHS_cbits" "getBuf" unsafe
- getBuf :: FILE_OBJECT -> IO Addr
+ getBuf :: FILE_OBJECT -> IO (Ptr ())
foreign import "libHS_cbits" "getBufWPtr" unsafe
getBufWPtr :: FILE_OBJECT -> IO Int
foreign import "libHS_cbits" "setBufWPtr" 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 -> Int -> IO Int{-ret code-}
+ readChunk :: FILE_OBJECT -> Ptr a -> Int -> Int -> IO Int{-ret code-}
foreign import "libHS_cbits" "getFileFd" unsafe
getFileFd :: FILE_OBJECT -> IO Int{-fd-}
#ifdef __HUGS__
foreign import "libHS_cbits" "getLock" unsafe
getLock :: Int{-Fd-} -> Int{-exclusive-} -> IO Int{-return code-}
foreign import "libHS_cbits" "openStdFile" unsafe
- openStdFile :: Int{-fd-} -> Int{-Readable?-} -> IO Addr{-file obj-}
+ openStdFile :: Int{-fd-}
+ -> Int{-Readable?-}
+ -> IO (Ptr ()){-file object-}
foreign import "libHS_cbits" "openFile" unsafe
primOpenFile :: ByteArray Int{-CString-}
-> Int{-How-}
-> Int{-Binary-}
- -> IO Addr {-file obj-}
+ -> IO (Ptr ()){-file object-}
foreign import "libHS_cbits" "const_BUFSIZ" unsafe
const_BUFSIZ :: Int
foreign import "libHS_cbits" "setBinaryMode__" unsafe
setBinaryMode :: FILE_OBJECT -> Int -> IO Int
\end{code}
-
-
projects / ghc-hetmet.git / blobdiff