From b9bd8aedf924bd9396c2634792f5c472b36c3bf0 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Fri, 15 Jan 1999 17:54:23 +0000
Subject: [PATCH] [project @ 1999-01-15 17:54:20 by sof] Re-integrated mod.
that seems to have been dropped on the floor when new-rts moved back onto the
main trunk. Here's the commit msg. that was originally used:
Extend hConnectTo to also allow output handles to be connected, i.e.,
h1 <- openFile "foo" WriteMode
h2 <- openFile "bar" WriteMode
hConnectTo h1 h2
will cause h1's buffer to be flushed when h2's buffer overflows
(and it is just about to be flushed.) The implementation is currently
not as lazy as that, it flushes h1's buffer regardless of whether a
write to h2 causes h2's buffer to overflow or not.
This is used to connect 'stderr' and 'stdout', i.e., output on
'stderr' will now cause 'stdout' output to (first) be flushed.
---
ghc/lib/std/IO.lhs | 2 ++
ghc/lib/std/PrelHandle.lhs | 50 +++++++++++++++++++++++++++++------
ghc/lib/std/cbits/flushFile.c | 20 +++++++++++++-
ghc/lib/std/cbits/stgio.h | 3 ++-
4 files changed, 65 insertions(+), 10 deletions(-)
diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs
index 1b458cbefec4..6670ff317221 100644
--- a/ghc/lib/std/IO.lhs
+++ b/ghc/lib/std/IO.lhs
@@ -358,6 +358,7 @@ hPutChar :: Handle -> Char -> IO ()
hPutChar handle c =
wantWriteableHandle "hPutChar" handle $ \ handle_ -> do
let fo = haFO__ handle_
+ flushConnectedBuf fo
rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block.
writeHandle handle handle_
if rc == 0
@@ -374,6 +375,7 @@ hPutStr :: Handle -> String -> IO ()
hPutStr handle str =
wantWriteableHandle "hPutStr" handle $ \ handle_ -> do
let fo = haFO__ handle_
+ flushConnectedBuf fo
case haBufferMode__ handle_ of
LineBuffering -> do
buf <- CCALL(getWriteableBuf) fo
diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index ec3c89601769..139594d2313a 100644
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/ghc/lib/std/PrelHandle.lhs
@@ -258,7 +258,13 @@ stderr = unsafePerformIO (do
fo <- makeForeignObj fo
addForeignFinaliser fo (freeStdFileObject fo)
#endif
- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
+ 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.
+ hConnectTo stdout hdl
+ return hdl
+
_ -> do ioError <- constructError "stderr"
newHandle (mkErrorHandle__ ioError)
)
@@ -905,12 +911,20 @@ hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
hConnectHdl_ hW hR is_tty =
- wantWriteableHandle "hConnectTo" hW $ \ hW_ -> do
- wantReadableHandle "hConnectTo" hR $ \ hR_ -> do
+ wantRWHandle "hConnectTo" hW $ \ hW_ -> do
+ wantRWHandle "hConnectTo" hR $ \ hR_ -> do
CCALL(setConnectedTo) (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
writeHandle hR hR_
writeHandle hW hW_
+#ifndef __PARALLEL_HASKELL__
+#define FILE_OBJECT ForeignObj
+#else
+#define FILE_OBJECT Addr
+#endif
+
+flushConnectedBuf :: FILE_OBJECT -> IO ()
+flushConnectedBuf fo = CCALL(flushConnectedBuf) fo
\end{code}
As an extension, we also allow characters to be pushed back.
@@ -1124,6 +1138,25 @@ wantWriteableHandle fun handle act =
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 -> do
+ writeHandle handle handle_
+ ioError theError
+ ClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle fun handle
+ SemiClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle fun handle
+ _ -> act handle_
+ where
+ not_rw_error =
+ IOError (Just handle) IllegalOperation fun
+ ("handle is not open for reading or writing")
+
wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantSeekableHandle fun handle act =
withHandle handle $ \ handle_ -> do
@@ -1246,11 +1279,12 @@ foreign import ccall "libHS_cbits.so" "getWriteableBuf" unsafe prim_getWri
foreign import ccall "libHS_cbits.so" "getBufWPtr" unsafe prim_getBufWPtr :: FILE_OBJ -> IO Int
foreign import ccall "libHS_cbits.so" "setBufWPtr" unsafe prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
foreign import ccall "libHS_cbits.so" "closeFile" unsafe prim_closeFile :: FILE_OBJ -> Flush -> IO RC
-foreign import ccall "libHS_cbits.so" "fileEOF" unsafe prim_fileEOF :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "setBuffering" unsafe prim_setBuffering :: FILE_OBJ -> Int -> IO RC
-foreign import ccall "libHS_cbits.so" "flushFile" unsafe prim_flushFile :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "getBufferMode" unsafe prim_getBufferMode :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "seekFile_int64" unsafe prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
+foreign import ccall "libHS_cbits.so" "fileEOF" unsafe prim_fileEOF :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "setBuffering" unsafe prim_setBuffering :: FILE_OBJ -> Int -> IO RC
+foreign import ccall "libHS_cbits.so" "flushFile" unsafe prim_flushFile :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "flushConnectedBuf" unsafe prim_flushConnectedBuf :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "getBufferMode" unsafe prim_getBufferMode :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "seekFile_int64" unsafe prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
foreign import ccall "libHS_cbits.so" "seekFileP" unsafe prim_seekFileP :: FILE_OBJ -> IO RC
foreign import ccall "libHS_cbits.so" "setTerminalEcho" unsafe prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
foreign import ccall "libHS_cbits.so" "getTerminalEcho" unsafe prim_getTerminalEcho :: FILE_OBJ -> IO RC
diff --git a/ghc/lib/std/cbits/flushFile.c b/ghc/lib/std/cbits/flushFile.c
index 7390b27ec2ec..d556d5ae1b54 100644
--- a/ghc/lib/std/cbits/flushFile.c
+++ b/ghc/lib/std/cbits/flushFile.c
@@ -1,7 +1,7 @@
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: flushFile.c,v 1.3 1998/12/02 13:27:32 simonm Exp $
+ * $Id: flushFile.c,v 1.4 1999/01/15 17:54:23 sof Exp $
*
* hFlush Runtime Support
*/
@@ -78,3 +78,21 @@ StgForeignPtr ptr;
fo->bufWPtr=0;
return 0;
}
+
+void
+flushConnectedBuf(ptr)
+StgForeignPtr ptr;
+{
+ StgInt rc;
+ IOFileObject* fo = (IOFileObject*)ptr;
+
+ /* if the stream is connected to an output stream, flush it. */
+ if ( fo->connectedTo != NULL && fo->connectedTo->fd != -1 &&
+ (fo->connectedTo->flags & FILEOBJ_WRITE) ) {
+ rc = flushBuffer((StgForeignPtr)fo->connectedTo);
+ }
+ /* Willfully ignore the return code for now. */
+ return;
+}
+
+
diff --git a/ghc/lib/std/cbits/stgio.h b/ghc/lib/std/cbits/stgio.h
index 8115b5ec6400..68a097974fee 100644
--- a/ghc/lib/std/cbits/stgio.h
+++ b/ghc/lib/std/cbits/stgio.h
@@ -1,7 +1,7 @@
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: stgio.h,v 1.8 1998/12/02 13:27:58 simonm Exp $
+ * $Id: stgio.h,v 1.9 1999/01/15 17:54:23 sof Exp $
*
* Helper code for GHC's IO subsystem.
*/
@@ -117,6 +117,7 @@ StgInt fileSize_int64 (StgForeignPtr, StgByteArray);
StgInt flushFile (StgForeignPtr);
StgInt flushBuffer (StgForeignPtr);
StgInt flushReadBuffer (StgForeignPtr);
+void flushConnectedBuf (StgForeignPtr);
/* freeFile.c */
void freeStdFile (StgForeignPtr);
--
GitLab