diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index 5c8c9fb0b126a224229a386c67df9da768fb056f..4c40d943d1cd59120c2915658f77ba46c03ca163 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -329,6 +329,7 @@ hPutChar :: Handle -> Char -> IO () hPutChar handle c = do handle_ <- wantWriteableHandle "hPutChar" handle let fo = haFO__ handle_ + flushConnectedHandle fo rc <- mayBlock fo (_ccall_ filePutc fo c) -- ConcHask: UNSAFE, may block. writeHandle handle handle_ if rc == 0 @@ -345,6 +346,7 @@ hPutStr :: Handle -> String -> IO () hPutStr handle str = do handle_ <- wantWriteableHandle "hPutStr" handle let fo = haFO__ handle_ + flushConnectedHandle 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 91ae3df5d751356d57679c1e10592780c912e39d..c1ca8b2c219090861f03e3b5eb104be2c6becb77 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -150,7 +150,12 @@ stderr = unsafePerformIO (do #ifndef __PARALLEL_HASKELL__ fo <- makeForeignObj fo (``&freeStdFileObject''::Addr) #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 on stderr. + -- + hConnectTo stdout hdl + return hdl _ -> do ioError <- constructError "stderr" newHandle (mkErrorHandle__ ioError) ) @@ -774,12 +779,20 @@ hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-} hConnectHdl_ :: Handle -> Handle -> Int -> IO () hConnectHdl_ hW hR is_tty = do - hW_ <- wantWriteableHandle "hConnectTo" hW - hR_ <- wantReadableHandle "hConnectTo" hR + hW_ <- wantRWHandle "hConnectTo" hW + hR_ <- wantRWHandle "hConnectTo" hR _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 + +flushConnectedHandle :: FILE_OBJECT -> IO () +flushConnectedHandle fo = _ccall_ flushConnectedHandle fo \end{code} As an extension, we also allow characters to be pushed back. @@ -985,6 +998,26 @@ wantWriteableHandle fun handle = do IOError (Just handle) IllegalOperation fun ("handle is not open for writing") +-- either R or W. +wantRWHandle :: String -> Handle -> IO Handle__ +wantRWHandle fun handle = do + handle_ <- readHandle handle + case haType__ handle_ of + ErrorHandle ioError -> do + writeHandle handle handle_ + fail ioError + ClosedHandle -> do + writeHandle handle handle_ + ioe_closedHandle fun handle + SemiClosedHandle -> do + writeHandle handle handle_ + ioe_closedHandle fun handle + other -> return handle_ + where + not_readable_error = + IOError (Just handle) IllegalOperation fun + ("handle is not open for reading or writing") + wantSeekableHandle :: String -> Handle -> IO Handle__ wantSeekableHandle fun handle = do handle_ <- readHandle handle diff --git a/ghc/lib/std/cbits/filePutc.lc b/ghc/lib/std/cbits/filePutc.lc index a6ebf3d15593bf1f92ec91196aa053788dc6aadf..cf9ffe1213986923282247e8a75d5d8ef362dc2a 100644 --- a/ghc/lib/std/cbits/filePutc.lc +++ b/ghc/lib/std/cbits/filePutc.lc @@ -49,7 +49,7 @@ StgChar c; fo->flags = (fo->flags & ~FILEOBJ_RW_READ) | FILEOBJ_RW_WRITE; - /* check whether we can just add it to the buffer.. */ + /* check whether we can just add it to the buffer.. */ if ( FILEOBJ_UNBUFFERED(fo) ) { ; } else { diff --git a/ghc/lib/std/cbits/flushFile.lc b/ghc/lib/std/cbits/flushFile.lc index 595dfc01ac6d1e6ff5ee8ec64b84728df1c0471a..6fa7888ff56b694acfd6909c3646a1bd3695a91a 100644 --- a/ghc/lib/std/cbits/flushFile.lc +++ b/ghc/lib/std/cbits/flushFile.lc @@ -80,8 +80,21 @@ StgForeignObj ptr; return 0; } - -\end{code} +void +flushConnectedHandle(ptr) +StgForeignObj ptr; +{ + StgInt rc; + IOFileObject* fo = (IOFileObject*)ptr; + /* if the stream is connected to an output stream, flush it first */ + if ( fo->connectedTo != NULL && fo->connectedTo->fd != -1 && + (fo->connectedTo->flags & FILEOBJ_WRITE) ) { + rc = flushBuffer((StgForeignObj)fo->connectedTo); + } + /* Willfully ignore return code for now */ + return; +} +\end{code} diff --git a/ghc/lib/std/cbits/stgio.h b/ghc/lib/std/cbits/stgio.h index 2bce94b326b38855389e3b71974ba724f41f1baa..2769e808cb0a58962e91d39fce589d1f3c80f6cf 100644 --- a/ghc/lib/std/cbits/stgio.h +++ b/ghc/lib/std/cbits/stgio.h @@ -90,6 +90,7 @@ StgInt fileSize PROTO((StgForeignObj, StgByteArray)); StgInt flushFile PROTO((StgForeignObj)); StgInt flushBuffer PROTO((StgForeignObj)); StgInt flushReadBuffer PROTO((StgForeignObj)); +void flushConnectedHandle PROTO((StgForeignObj)); /* freeFile.lc */ void freeStdFile PROTO((StgForeignObj)); diff --git a/ghc/lib/std/cbits/writeFile.lc b/ghc/lib/std/cbits/writeFile.lc index ca7bac63d44d99a6390ebfae015344cbf98ade37..1cd336e71d276bd1ed0352e8314b0912067c83de 100644 --- a/ghc/lib/std/cbits/writeFile.lc +++ b/ghc/lib/std/cbits/writeFile.lc @@ -76,6 +76,7 @@ StgInt len; if (len == 0 ) return 0; + /* First of all, check if we do need to flush the buffer .. */ /* Note - in the case of line buffering, we do not currently check whether we need to flush buffer due to line terminators in the