improve panic messages a bit, with the GHC version and platform

[ghc-hetmet.git] / ghc / rts / RtsMessages.c

diff --git a/ghc/rts/RtsMessages.c b/ghc/rts/RtsMessages.c
index 08df965..1242d88 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, ...)
@@ -42,6 +46,12 @@ vbarf(char *s, va_list ap)
   stg_exit(EXIT_INTERNAL_ERROR); // just in case fatalInternalErrorFn() returns
 }
 
+void 
+_assertFail(char *filename, unsigned int linenum)
+{
+    barf("ASSERTION FAILED: file %s, line %u\n", filename, linenum);
+}
+
 void
 errorBelch(char *s, ...)
 {
@@ -76,38 +86,116 @@ 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()
 {
-  /* 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);
-  stg_exit(EXIT_INTERNAL_ERROR);
+  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
+
+#define xstr(s) str(s)
+#define str(s) #s
 
 void
-stdioErrorMsgFn(char *s, va_list ap)
+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: ", prog_name);
-  } 
-  vfprintf(stderr, s, ap);
-  fprintf(stderr, "\n");
+#if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
+  if (isGUIApp())
+  {
+     char title[BUFSIZE], message[BUFSIZE];
+
+     snprintf(title,   BUFSIZE, "%s: internal error", prog_name);
+     vsnprintf(message, BUFSIZE, s, ap);
+
+     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, "    (GHC version %s for %s)\n", ProjectVersion, xstr(HostPlatform_TYPE));
+     fprintf(stderr, "    Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n");
+     fflush(stderr);
+  }
+
+  abort();
+  // stg_exit(EXIT_INTERNAL_ERROR);
 }
 
 void
-stdioDebugMsgFn(char *s, va_list ap)
+rtsErrorMsgFn(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) {
+               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
+rtsDebugMsgFn(char *s, va_list ap)
+{
+#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);
+  }
+}