#undef DEBUG
-- -----------------------------------------------------------------------------
--- $Id: PrelHandle.hs,v 1.2 2001/11/07 19:36:11 sof Exp $
+-- $Id: PrelHandle.hs,v 1.3 2001/11/14 11:39:29 simonmar Exp $
--
-- (c) The University of Glasgow, 1994-2001
--
-- For a duplex handle, we arrange that the read side points to the write side
-- (and hence keeps it alive if the read side is alive). This is done by
--- having the haType field of the read side be ReadSideHandle with a pointer
--- to the write side. The finalizer is then placed on the write side, and
--- the handle only gets finalized once, when both sides are no longer
--- required.
-
-addFinalizer :: Handle -> IO ()
-addFinalizer (FileHandle m) = addMVarFinalizer m (handleFinalizer m)
-addFinalizer (DuplexHandle _ w) = addMVarFinalizer w (handleFinalizer w)
+-- having the haOtherSide field of the read side point to the read side.
+-- The finalizer is then placed on the write side, and the handle only gets
+-- finalized once, when both sides are no longer required.
stdHandleFinalizer :: MVar Handle__ -> IO ()
stdHandleFinalizer m = do
-- ToDo: acquire lock
setNonBlockingFD fd_stdin
(buf, bmode) <- getBuffer fd_stdin ReadBuffer
- spares <- newIORef BufferListNil
- newFileHandle stdHandleFinalizer
- (Handle__ { haFD = fd_stdin,
- haType = ReadHandle,
- haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
- haBufferMode = bmode,
- haFilePath = "<stdin>",
- haBuffer = buf,
- haBuffers = spares
- })
+ mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
stdout :: Handle
stdout = unsafePerformIO $ do
-- some shells don't recover properly.
-- setNonBlockingFD fd_stdout
(buf, bmode) <- getBuffer fd_stdout WriteBuffer
- spares <- newIORef BufferListNil
- newFileHandle stdHandleFinalizer
- (Handle__ { haFD = fd_stdout,
- haType = WriteHandle,
- haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
- haBufferMode = bmode,
- haFilePath = "<stdout>",
- haBuffer = buf,
- haBuffers = spares
- })
+ mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
stderr :: Handle
stderr = unsafePerformIO $ do
-- We don't set non-blocking mode on stdout or sterr, because
-- some shells don't recover properly.
-- setNonBlockingFD fd_stderr
- buffer <- mkUnBuffer
- spares <- newIORef BufferListNil
- newFileHandle stdHandleFinalizer
- (Handle__ { haFD = fd_stderr,
- haType = WriteHandle,
- haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
- haBufferMode = NoBuffering,
- haFilePath = "<stderr>",
- haBuffer = buffer,
- haBuffers = spares
- })
+ buf <- mkUnBuffer
+ mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
-- ---------------------------------------------------------------------------
-- Opening and Closing Files
foreign import "unlockFile" unsafe
unlockFile :: CInt -> IO CInt
+mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
+ -> IO Handle
+mkStdHandle fd filepath ha_type buf bmode = do
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd,
+ haType = ha_type,
+ haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
+ haBufferMode = bmode,
+ haFilePath = filepath,
+ haBuffer = buf,
+ haBuffers = spares,
+ haOtherSide = Nothing
+ })
+
mkFileHandle :: FD -> FilePath -> HandleType -> Bool -> IO Handle
mkFileHandle fd filepath ha_type binary = do
(buf, bmode) <- getBuffer fd (initBufferState ha_type)
haBufferMode = bmode,
haFilePath = filepath,
haBuffer = buf,
- haBuffers = spares
+ haBuffers = spares,
+ haOtherSide = Nothing
})
mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle
haBufferMode = w_bmode,
haFilePath = filepath,
haBuffer = w_buf,
- haBuffers = w_spares
+ haBuffers = w_spares,
+ haOtherSide = Nothing
}
write_side <- newMVar w_handle_
r_spares <- newIORef BufferListNil
let r_handle_ =
Handle__ { haFD = fd,
- haType = ReadSideHandle write_side,
+ haType = ReadHandle,
haIsBin = binary,
haBufferMode = r_bmode,
haFilePath = filepath,
haBuffer = r_buf,
- haBuffers = r_spares
+ haBuffers = r_spares,
+ haOtherSide = Just write_side
}
read_side <- newMVar r_handle_
- addMVarFinalizer write_side (handleFinalizer write_side)
+ addMVarFinalizer read_side (handleFinalizer read_side)
return (DuplexHandle read_side write_side)
hClose :: Handle -> IO ()
hClose h@(FileHandle m) = hClose' h m
-hClose h@(DuplexHandle r w) = do
- hClose' h w
- withHandle__' "hClose" h r $ \ handle_ -> do
- return handle_{ haFD = -1,
- haType = ClosedHandle
- }
+hClose h@(DuplexHandle r w) = hClose' h w >> hClose' h r
hClose' h m = withHandle__' "hClose" h m $ hClose_help
+-- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
+-- or an IO error occurs on a lazy stream. The semi-closed Handle is
+-- then closed immediately. We have to be careful with DuplexHandles
+-- though: we have to leave the closing to the finalizer in that case,
+-- because the write side may still be in use.
hClose_help handle_ =
case haType handle_ of
ClosedHandle -> return handle_
_ -> do
let fd = fromIntegral (haFD handle_)
flushWriteBufferOnly handle_
- throwErrnoIfMinus1Retry_ "hClose" (c_close fd)
+
+ -- 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)
+ Just _ -> return ()
-- free the spare buffers
writeIORef (haBuffers handle_) BufferListNil
% ------------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.43 2001/10/11 22:27:04 sof Exp $
+% $Id: PrelIOBase.lhs,v 1.44 2001/11/14 11:39:29 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2001
%
data Handle__
= Handle__ {
- haFD :: !FD,
- haType :: HandleType,
- haIsBin :: Bool,
- haBufferMode :: BufferMode,
- haFilePath :: FilePath,
- haBuffer :: !(IORef Buffer),
- haBuffers :: !(IORef BufferList)
+ haFD :: !FD, -- file descriptor
+ haType :: HandleType, -- type (read/write/append etc.)
+ haIsBin :: Bool, -- binary mode?
+ haBufferMode :: BufferMode, -- buffer contains read/write data?
+ haFilePath :: FilePath, -- file name, possibly
+ haBuffer :: !(IORef Buffer), -- the current buffer
+ haBuffers :: !(IORef BufferList), -- spare buffers
+ haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a
+ -- duplex handle.
}
-- ---------------------------------------------------------------------------
| WriteHandle
| AppendHandle
| ReadWriteHandle
- | ReadSideHandle !(MVar Handle__) -- read side of a duplex handle
isReadableHandleType ReadHandle = True
isReadableHandleType ReadWriteHandle = True
-isReadableHandleType (ReadSideHandle _) = True
isReadableHandleType _ = False
isWritableHandleType AppendHandle = True
WriteHandle -> showString "writable"
AppendHandle -> showString "writable (append)"
ReadWriteHandle -> showString "read-writable"
- ReadSideHandle _ -> showString "read-writable (duplex)"
instance Show Handle where
- showsPrec p (FileHandle h) = showHandle p h
- showsPrec p (DuplexHandle h _) = showHandle p h
+ showsPrec p (FileHandle h) = showHandle p h False
+ showsPrec p (DuplexHandle _ h) = showHandle p h True
-showHandle p h =
+showHandle p h duplex =
let
-- (Big) SIGH: unfolded defn of takeMVar to avoid
-- an (oh-so) unfortunate module loop with PrelConc.
case takeMVar# h# s# of { (# s2# , r #) ->
case putMVar# h# r s2# of { s3# ->
(# s3#, r #) }}})
+
+ showType | duplex = showString "duplex (read-write)"
+ | otherwise = showsPrec p (haType hdl_)
in
showChar '{' .
showHdl (haType hdl_)
(showString "loc=" . showString (haFilePath hdl_) . showChar ',' .
- showString "type=" . showsPrec p (haType hdl_) . showChar ',' .
+ showString "type=" . showType . showChar ',' .
showString "binary=" . showsPrec p (haIsBin hdl_) . showChar ',' .
showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
where
+
showHdl :: HandleType -> ShowS -> ShowS
showHdl ht cont =
case ht of
projects / ghc-hetmet.git / commitdiff