[project @ 2005-01-28 23:33:51 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/ghc/includes/RtsMessages.h b/ghc/includes/RtsMessages.h
index 8206bb9..40baaa0 100644 (file)
--- a/ghc/includes/RtsMessages.h
+++ b/ghc/includes/RtsMessages.h
@@ -26,7 +26,7 @@
  * barf() invokes (*fatalInternalErrorFn)().  This function is not
  * expected to return.
  */
-extern void barf(char *s, ...) 
+extern void barf(char *s, ...)
    GNUC3_ATTRIBUTE(__noreturn__);
 
 extern void vbarf(char *s, va_list ap)
@@ -66,8 +66,8 @@ extern RtsMsgFunction *errorMsgFn;
 
 /* Default stdio implementation of the message hooks: */
 
-extern RtsMsgFunction stdioFatalInternalErrorFn;
-extern RtsMsgFunction stdioDebugMsgFn;
-extern RtsMsgFunction stdioErrorMsgFn;
+extern RtsMsgFunction rtsFatalInternalErrorFn;
+extern RtsMsgFunction rtsDebugMsgFn;
+extern RtsMsgFunction rtsErrorMsgFn;
 
 #endif // RTSMESSAGES_H

diff --git a/ghc/rts/Linker.c b/ghc/rts/Linker.c
index 09a30a4..f507e47 100644 (file)
--- a/ghc/rts/Linker.c
+++ b/ghc/rts/Linker.c
@@ -391,6 +391,8 @@ typedef struct _RtsSymbolVal {
       SymX(andIntegerzh_fast)                  \
       SymX(atomicallyzh_fast)                  \
       SymX(barf)                               \
+      SymX(debugBelch)                         \
+      SymX(errorBelch)                         \
       SymX(blockAsyncExceptionszh_fast)                \
       SymX(catchzh_fast)                       \
       SymX(catchRetryzh_fast)                  \

diff --git a/ghc/rts/RtsMessages.c b/ghc/rts/RtsMessages.c
index 08df965..60173c1 100644 (file)
--- a/ghc/rts/RtsMessages.c
+++ b/ghc/rts/RtsMessages.c
@@ -11,6 +11,10 @@
 
 #include <stdio.h>
 
+#ifdef HAVE_WINDOWS_H
+#include <windows.h>
+#endif
+
 /* -----------------------------------------------------------------------------
    General message generation functions
 
@@ -21,9 +25,9 @@
    -------------------------------------------------------------------------- */
 
 // Default to the stdio implementation of these hooks.
-RtsMsgFunction *fatalInternalErrorFn = stdioFatalInternalErrorFn;
-RtsMsgFunction *debugMsgFn           = stdioDebugMsgFn;
-RtsMsgFunction *errorMsgFn           = stdioErrorMsgFn;
+RtsMsgFunction *fatalInternalErrorFn = rtsFatalInternalErrorFn;
+RtsMsgFunction *debugMsgFn           = rtsDebugMsgFn;
+RtsMsgFunction *errorMsgFn           = rtsErrorMsgFn;
 
 void
 barf(char *s, ...)
@@ -76,38 +80,117 @@ vdebugBelch(char *s, va_list ap)
    stdio versions of the message functions
    -------------------------------------------------------------------------- */
 
-void 
-stdioFatalInternalErrorFn(char *s, va_list ap)
+#define BUFSIZE 512
+
+#if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
+static int
+isGUIApp()
+{
+  PIMAGE_DOS_HEADER pDOSHeader;
+  PIMAGE_NT_HEADERS pPEHeader;
+
+  pDOSHeader = (PIMAGE_DOS_HEADER) GetModuleHandleA(NULL);
+  if (pDOSHeader->e_magic != IMAGE_DOS_SIGNATURE)
+    return 0;
+
+  pPEHeader = (PIMAGE_NT_HEADERS) ((char *)pDOSHeader + pDOSHeader->e_lfanew);
+  if (pPEHeader->Signature != IMAGE_NT_SIGNATURE)
+    return 0;
+
+  return (pPEHeader->OptionalHeader.Subsystem == IMAGE_SUBSYSTEM_WINDOWS_GUI);
+}
+#endif
+
+void
+rtsFatalInternalErrorFn(char *s, va_list ap)
 {
-  /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
-  if (prog_argv != NULL && prog_name != NULL) {
-    fprintf(stderr, "%s: internal error: ", prog_name);
-  } else {
-    fprintf(stderr, "internal error: ");
+#if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
+  if (isGUIApp())
+  {
+     char title[BUFSIZE], message[BUFSIZE];
+     int r;
+
+        r = vsnprintf(title,   BUFSIZE, "%s: internal error", prog_name);
+        if (r > 0 && r < BUFSIZE) {
+                strcpy(title, "internal error");
+     }
+
+        r = vsnprintf(message, BUFSIZE, s, ap);
+        if (r > 0 && r < BUFSIZE) {
+          MessageBox(NULL /* hWnd */,
+         message,
+         title,
+         MB_OK | MB_ICONERROR | MB_TASKMODAL
+         );
+     };
+  }
+  else
+#endif
+  {
+     /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
+     if (prog_argv != NULL && prog_name != NULL) {
+       fprintf(stderr, "%s: internal error: ", prog_name);
+     } else {
+       fprintf(stderr, "internal error: ");
+     }
+     vfprintf(stderr, s, ap);
+     fprintf(stderr, "\n");
+     fprintf(stderr, "    Please report this as a bug to glasgow-haskell-bugs@haskell.org,\n    or http://www.sourceforge.net/projects/ghc/\n");
+     fflush(stderr);
   }
-  vfprintf(stderr, s, ap);
-  fprintf(stderr, "\n");
-  fprintf(stderr, "    Please report this as a bug to glasgow-haskell-bugs@haskell.org,\n    or http://www.sourceforge.net/projects/ghc/\n");
-  fflush(stderr);
+
   stg_exit(EXIT_INTERNAL_ERROR);
 }
 
 void
-stdioErrorMsgFn(char *s, va_list ap)
+rtsErrorMsgFn(char *s, va_list ap)
 {
-  /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
-  if (prog_argv != NULL && prog_name != NULL) {
-    fprintf(stderr, "%s: ", prog_name);
-  } 
-  vfprintf(stderr, s, ap);
-  fprintf(stderr, "\n");
+#if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
+  if (isGUIApp())
+  {
+     char buf[BUFSIZE];
+     int r;
+
+        r = vsnprintf(buf, BUFSIZE, s, ap);
+        if (r > 0 && r < BUFSIZE) {
+               MessageBox(NULL /* hWnd */,
+              buf,
+              prog_name,
+              MB_OK | MB_ICONERROR | MB_TASKMODAL
+              );
+     }
+  }
+  else
+#endif
+  {
+     /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
+     if (prog_argv != NULL && prog_name != NULL) {
+       fprintf(stderr, "%s: ", prog_name);
+     }
+     vfprintf(stderr, s, ap);
+     fprintf(stderr, "\n");
+  }
 }
 
 void
-stdioDebugMsgFn(char *s, va_list ap)
+rtsDebugMsgFn(char *s, va_list ap)
 {
-  /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
-  vfprintf(stderr, s, ap);
-  fflush(stderr);
+#if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
+  if (isGUIApp())
+  {
+     char buf[BUFSIZE];
+        int r;
+
+        r = vsnprintf(buf, BUFSIZE, s, ap);
+        if (r > 0 && r < BUFSIZE) {
+       OutputDebugString(buf);
+     }
+  }
+  else
+#endif
+  {
+     /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
+     vfprintf(stderr, s, ap);
+     fflush(stderr);
+  }
 }
-