[project @ 2005-01-28 23:33:57 by krasimir]

- The output from uncaught exceptions handler is redirected to RTS's errorBelch.
- The output from Debug.Trace is redirected to RTS's debugBelch
- Usually errorBelch and debugBelch messages go to stderr except for
Windows GUI applications. For GUI applications the Debug.Trace output is
redirected to debug console and the exceptions message is displayed in message box.

diff --git a/Control/Exception.hs b/Control/Exception.hs
index 05157d1..83f37cb 100644 (file)
--- a/Control/Exception.hs
+++ b/Control/Exception.hs
@@ -117,7 +117,7 @@ import GHC.Base             ( assert )
 import GHC.Exception   as ExceptionBase hiding (catch)
 import GHC.Conc                ( throwTo, ThreadId )
 import Data.IORef      ( IORef, newIORef, readIORef, writeIORef )
-import Foreign.C.String ( CString, withCStringLen )
+import Foreign.C.String ( CString, withCString )
 import System.IO       ( stdout, hFlush )
 #endif
 
@@ -510,10 +510,11 @@ uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
                Deadlock    -> "no threads to run:  infinite loop or deadlock?"
                ErrorCall s -> s
                other       -> showsPrec 0 other "\n"
-         withCStringLen ("Fail: "++msg) $ \(cstr,len) -> writeErrString cstr len
-         
-foreign import ccall unsafe "writeErrString__"
-       writeErrString :: CString -> Int -> IO ()
+         withCString "%s" $ \cfmt ->
+          withCString msg $ \cmsg ->
+            errorBelch cfmt cmsg
+
+foreign import ccall unsafe errorBelch :: CString -> CString -> IO ()
 
 setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO ()
 setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler

diff --git a/Debug/Trace.hs b/Debug/Trace.hs
index c287a4d..7c9295f 100644 (file)
--- a/Debug/Trace.hs
+++ b/Debug/Trace.hs
@@ -14,81 +14,44 @@
 
 module Debug.Trace (
        -- * Tracing
-       
-       -- ** Tracers
-       -- | The tracer is a function that monitors the trace messages.
-       fileTracer,       -- :: Handle -> String -> IO ()
-#ifdef mingw32_HOST_OS
-       winDebugTracer,   -- :: String -> IO ()
-#endif
-       addTracer,        -- :: String -> (String -> IO ()) -> IO ()
-       removeTracer,     -- :: String -> IO ()
-       
-       -- ** Messages
        putTraceMsg,      -- :: String -> IO ()
        trace             -- :: String -> a -> a
   ) where
 
 import Prelude
-import Data.IORef
 import System.IO.Unsafe
-import System.IO
 
+#ifdef __GLASGOW_HASKELL__
 #ifdef mingw32_HOST_OS
 import Foreign.C.String
 #endif
-
-{-# NOINLINE tracers #-}
-tracers :: IORef [(String, String -> IO ())]
-tracers = unsafePerformIO (newIORef [("defaultTracer", fileTracer stderr)])
-
--- | A tracer function that outputs the message to a file
-fileTracer :: Handle     -- ^ file handle
-           -> String     -- ^ trace message
-           -> IO ()
-fileTracer handle msg = do
-   hPutStr handle msg
-   hPutChar handle '\n'
-
-#ifdef mingw32_HOST_OS
--- | A tracer function that outputs the message to the debuger (Windows only)
-winDebugTracer :: String  -- ^ trace message
-               -> IO ()
-winDebugTracer msg = do
-   withCString (msg++"\n") outputDebugString
-
-foreign import ccall unsafe "OutputDebugStringA"
-  outputDebugString :: CString -> IO ()
 #endif
 
--- | Registering a new tracer
-addTracer :: String             -- ^ the tracer name
-          -> (String -> IO ())  -- ^ tracer
-          -> IO ()
-addTracer name tracer = do
-       ts <- readIORef tracers
-       writeIORef tracers ((name,tracer):filter (\(n,l) -> n /= name) ts)
-
--- | Removing the tracer with the given name
-removeTracer :: String -> IO ()
-removeTracer name = do
-       ts <- readIORef tracers
-       writeIORef tracers (filter (\(n,l) -> n /= name) ts)
-
 -- | 'putTraceMsg' function outputs the trace message from IO monad.
+-- Usually the output stream is 'stderr' but if the function is called
+-- from Windows GUI application then the output will be directed to the Windows
+-- debug console.
 putTraceMsg :: String -> IO ()
 putTraceMsg msg = do
-       ts <- readIORef tracers
-       mapM_ (\(n,l) -> l msg) ts
+#ifndef __GLASGOW_HASKELL__
+    hPutStr handle msg
+    hPutChar handle '\n'
+#else
+    withCString "%s\n" $ \cfmt ->
+     withCString msg  $ \cmsg ->
+      debugBelch cfmt cmsg
+
+foreign import ccall unsafe debugBelch :: CString -> CString -> IO ()
+#endif
 
 {-# NOINLINE trace #-}
 {-|
-When called, 'trace' outputs the string in its first argument using the
-installed tracers, before returning the second argument as its result.
-The 'trace' function is not referentially transparent, and should only
-be used for debugging, or for monitoring execution. Some
-implementations of 'trace' may decorate the string that\'s output to
-indicate that you\'re tracing.
+When called, 'trace' outputs the string in its first argument, before 
+returning the second argument as its result. The 'trace' function is not 
+referentially transparent, and should only be used for debugging, or for 
+monitoring execution. Some implementations of 'trace' may decorate the string 
+that\'s output to indicate that you\'re tracing. The function is implemented on
+top of 'putTraceMsg'.
 -}
 trace :: String -> a -> a
 trace string expr = unsafePerformIO $ do

diff --git a/cbits/writeError.c b/cbits/writeError.c
deleted file mode 100644 (file)
index a5cd700..0000000
--- a/cbits/writeError.c
+++ /dev/null
@@ -1,42 +0,0 @@
-/*
- * (c) The University of Glasgow 2002
- *
- * $Id: writeError.c,v 1.6 2004/02/12 21:23:49 krasimir Exp $
- *
- * hPutStr Runtime Support
- */
-
-/*
-Writing out error messages. This is done outside Haskell
-(i.e., no use of the IO implementation is made), since it
-might be in an unstable state (e.g., hClose stderr >> error "foo")
-
-(A secondary reason is that ``error'' is used by the IO
-implementation in one or two places.)
-
-*/
-
-#include "Rts.h"
-#include "RtsUtils.h"
-#include "HsBase.h"
-
-void
-writeErrString__(HsAddr msg, HsInt len)
-{
-  int count = 0;
-  char* p  = (char*)msg;
-  char  nl = '\n';
-
-#ifndef DLLized
-  resetNonBlockingFd(2);
-#endif
-
-  while ( (count = write(2,p,len)) < len) {
-     if (errno != EINTR ) {
-        return;
-     }
-     len -= count;
-     p   += count;
-  }
-  write(2, &nl, 1);
-}

diff --git a/include/HsBase.h b/include/HsBase.h
index e8b7ae3..0ea5027 100644 (file)
--- a/include/HsBase.h
+++ b/include/HsBase.h
@@ -135,9 +135,6 @@
 /* in inputReady.c */
 int inputReady(int fd, int msecs, int isSock);
 
-/* in writeError.c */
-void writeErrString__(HsAddr msg, HsInt len);
-
 /* in Signals.c */
 extern HsInt nocldstop;