Index: PrelIOBase.lhs =================================================================== RCS file: /home/cvs/root/fptools/ghc/lib/std/PrelIOBase.lhs,v retrieving revision 1.43 retrieving revision 1.44 diff -c -r1.43 -r1.44 *** PrelIOBase.lhs 2001/10/11 22:27:04 1.43 --- PrelIOBase.lhs 2001/11/14 11:39:29 1.44 *************** *** 1,5 **** % ------------------------------------------------------------------------------ ! % $Id: PrelIOBase.lhs,v 1.43 2001/10/11 22:27:04 sof Exp $ % % (c) The University of Glasgow, 1994-2001 % --- 1,5 ---- % ------------------------------------------------------------------------------ ! % $Id: PrelIOBase.lhs,v 1.44 2001/11/14 11:39:29 simonmar Exp $ % % (c) The University of Glasgow, 1994-2001 % *************** *** 149,161 **** data Handle__ = Handle__ { ! haFD :: !FD, ! haType :: HandleType, ! haIsBin :: Bool, ! haBufferMode :: BufferMode, ! haFilePath :: FilePath, ! haBuffer :: !(IORef Buffer), ! haBuffers :: !(IORef BufferList) } -- --------------------------------------------------------------------------- --- 149,163 ---- data Handle__ = Handle__ { ! 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. } -- --------------------------------------------------------------------------- *************** *** 233,243 **** | 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 --- 235,243 ---- *************** *** 331,343 **** 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 ! showHandle p h = let -- (Big) SIGH: unfolded defn of takeMVar to avoid -- an (oh-so) unfortunate module loop with PrelConc. --- 331,342 ---- WriteHandle -> showString "writable" AppendHandle -> showString "writable (append)" ReadWriteHandle -> showString "read-writable" instance Show Handle where ! showsPrec p (FileHandle h) = showHandle p h False ! showsPrec p (DuplexHandle _ h) = showHandle p h True ! showHandle p h duplex = let -- (Big) SIGH: unfolded defn of takeMVar to avoid -- an (oh-so) unfortunate module loop with PrelConc. *************** *** 346,359 **** case takeMVar# h# s# of { (# s2# , r #) -> case putMVar# h# r s2# of { s3# -> (# s3#, r #) }}}) in showChar '{' . showHdl (haType hdl_) (showString "loc=" . showString (haFilePath hdl_) . showChar ',' . ! showString "type=" . showsPrec p (haType hdl_) . 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 --- 345,362 ---- 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=" . 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 Index: PrelHandle.hs =================================================================== RCS file: /home/cvs/root/fptools/ghc/lib/std/PrelHandle.hs,v retrieving revision 1.2 retrieving revision 1.3 diff -c -r1.2 -r1.3 *** PrelHandle.hs 2001/11/07 19:36:11 1.2 --- PrelHandle.hs 2001/11/14 11:39:29 1.3 *************** *** 4,10 **** #undef DEBUG -- ----------------------------------------------------------------------------- ! -- $Id: PrelHandle.hs,v 1.2 2001/11/07 19:36:11 sof Exp $ -- -- (c) The University of Glasgow, 1994-2001 -- --- 4,10 ---- #undef DEBUG -- ----------------------------------------------------------------------------- ! -- $Id: PrelHandle.hs,v 1.3 2001/11/14 11:39:29 simonmar Exp $ -- -- (c) The University of Glasgow, 1994-2001 -- *************** *** 292,305 **** -- 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) stdHandleFinalizer :: MVar Handle__ -> IO () stdHandleFinalizer m = do --- 292,300 ---- -- 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 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 *************** *** 493,508 **** -- 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 = "", ! haBuffer = buf, ! haBuffers = spares ! }) stdout :: Handle stdout = unsafePerformIO $ do --- 488,494 ---- -- ToDo: acquire lock setNonBlockingFD fd_stdin (buf, bmode) <- getBuffer fd_stdin ReadBuffer ! mkStdHandle fd_stdin "" ReadHandle buf bmode stdout :: Handle stdout = unsafePerformIO $ do *************** *** 511,526 **** -- 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 = "", ! haBuffer = buf, ! haBuffers = spares ! }) stderr :: Handle stderr = unsafePerformIO $ do --- 497,503 ---- -- some shells don't recover properly. -- setNonBlockingFD fd_stdout (buf, bmode) <- getBuffer fd_stdout WriteBuffer ! mkStdHandle fd_stdout "" WriteHandle buf bmode stderr :: Handle stderr = unsafePerformIO $ do *************** *** 528,544 **** -- 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 = "", ! haBuffer = buffer, ! haBuffers = spares ! }) -- --------------------------------------------------------------------------- -- Opening and Closing Files --- 505,512 ---- -- We don't set non-blocking mode on stdout or sterr, because -- some shells don't recover properly. -- setNonBlockingFD fd_stderr ! buf <- mkUnBuffer ! mkStdHandle fd_stderr "" WriteHandle buf NoBuffering -- --------------------------------------------------------------------------- -- Opening and Closing Files *************** *** 690,695 **** --- 658,678 ---- 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) *************** *** 701,707 **** haBufferMode = bmode, haFilePath = filepath, haBuffer = buf, ! haBuffers = spares }) mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle --- 684,691 ---- haBufferMode = bmode, haFilePath = filepath, haBuffer = buf, ! haBuffers = spares, ! haOtherSide = Nothing }) mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle *************** *** 715,721 **** haBufferMode = w_bmode, haFilePath = filepath, haBuffer = w_buf, ! haBuffers = w_spares } write_side <- newMVar w_handle_ --- 699,706 ---- haBufferMode = w_bmode, haFilePath = filepath, haBuffer = w_buf, ! haBuffers = w_spares, ! haOtherSide = Nothing } write_side <- newMVar w_handle_ *************** *** 723,738 **** r_spares <- newIORef BufferListNil let r_handle_ = Handle__ { haFD = fd, ! haType = ReadSideHandle write_side, haIsBin = binary, haBufferMode = r_bmode, haFilePath = filepath, haBuffer = r_buf, ! haBuffers = r_spares } read_side <- newMVar r_handle_ ! addMVarFinalizer write_side (handleFinalizer write_side) return (DuplexHandle read_side write_side) --- 708,724 ---- r_spares <- newIORef BufferListNil let r_handle_ = Handle__ { haFD = fd, ! haType = ReadHandle, haIsBin = binary, haBufferMode = r_bmode, haFilePath = filepath, haBuffer = r_buf, ! haBuffers = r_spares, ! haOtherSide = Just write_side } read_side <- newMVar r_handle_ ! addMVarFinalizer read_side (handleFinalizer read_side) return (DuplexHandle read_side write_side) *************** *** 751,772 **** 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 m = withHandle__' "hClose" h m $ hClose_help hClose_help handle_ = case haType handle_ of ClosedHandle -> return handle_ _ -> do let fd = fromIntegral (haFD handle_) flushWriteBufferOnly handle_ ! throwErrnoIfMinus1Retry_ "hClose" (c_close fd) -- free the spare buffers writeIORef (haBuffers handle_) BufferListNil --- 737,763 ---- hClose :: Handle -> IO () hClose h@(FileHandle m) = hClose' h m ! 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_ ! ! -- 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