[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.

diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs
index 1b458cb..6670ff3 100644 (file)
--- 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 ec3c896..139594d 100644 (file)
--- 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 7390b27..d556d5a 100644 (file)
--- 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 8115b5e..68a0979 100644 (file)
--- 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);