ghc/rts/RtsMessages.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1998-2004
   4  *
   5  * General utility functions used in the RTS.
   6  *
   7  * ---------------------------------------------------------------------------*/
   8
   9 #include "PosixSource.h"
  10 #include "Rts.h"
  11
  12 #include <stdio.h>
  13
  14 #ifdef HAVE_WINDOWS_H
  15 #include <windows.h>
  16 #endif
  17
  18 /* -----------------------------------------------------------------------------
  19    General message generation functions
  20
  21    All messages should go through here.  We can't guarantee that
  22    stdout/stderr will be available - e.g. in a Windows program there
  23    is no console for generating messages, so they have to either go to
  24    to the debug console, or pop up message boxes.
  25    -------------------------------------------------------------------------- */
  26
  27 // Default to the stdio implementation of these hooks.
  28 RtsMsgFunction *fatalInternalErrorFn = rtsFatalInternalErrorFn;
  29 RtsMsgFunction *debugMsgFn           = rtsDebugMsgFn;
  30 RtsMsgFunction *errorMsgFn           = rtsErrorMsgFn;
  31
  32 void
  33 barf(char *s, ...)
  34 {
  35   va_list ap;
  36   va_start(ap,s);
  37   (*fatalInternalErrorFn)(s,ap);
  38   stg_exit(EXIT_INTERNAL_ERROR); // just in case fatalInternalErrorFn() returns
  39   va_end(ap);
  40 }
  41
  42 void
  43 vbarf(char *s, va_list ap)
  44 {
  45   (*fatalInternalErrorFn)(s,ap);
  46   stg_exit(EXIT_INTERNAL_ERROR); // just in case fatalInternalErrorFn() returns
  47 }
  48
  49 void
  50 _assertFail(char *filename, unsigned int linenum)
  51 {
  52     internalErrorBelch("ASSERTION FAILED: file %s, line %u\n", filename, linenum);
  53     abort();
  54 }
  55
  56 internalErrorBelch(char *s, ...)
  57 {
  58   va_list ap;
  59   va_start(ap,s);
  60   (*fatalInternalErrorFn)(s,ap);
  61   va_end(ap);
  62 }
  63
  64 void
  65 errorBelch(char *s, ...)
  66 {
  67   va_list ap;
  68   va_start(ap,s);
  69   (*errorMsgFn)(s,ap);
  70   va_end(ap);
  71 }
  72
  73 void
  74 verrorBelch(char *s, va_list ap)
  75 {
  76   (*errorMsgFn)(s,ap);
  77 }
  78
  79 void
  80 debugBelch(char *s, ...)
  81 {
  82   va_list ap;
  83   va_start(ap,s);
  84   (*debugMsgFn)(s,ap);
  85   va_end(ap);
  86 }
  87
  88 void
  89 vdebugBelch(char *s, va_list ap)
  90 {
  91   (*debugMsgFn)(s,ap);
  92 }
  93
  94 /* -----------------------------------------------------------------------------
  95    stdio versions of the message functions
  96    -------------------------------------------------------------------------- */
  97
  98 #define BUFSIZE 512
  99
 100 #if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
 101 static int
 102 isGUIApp()
 103 {
 104   PIMAGE_DOS_HEADER pDOSHeader;
 105   PIMAGE_NT_HEADERS pPEHeader;
 106
 107   pDOSHeader = (PIMAGE_DOS_HEADER) GetModuleHandleA(NULL);
 108   if (pDOSHeader->e_magic != IMAGE_DOS_SIGNATURE)
 109     return 0;
 110
 111   pPEHeader = (PIMAGE_NT_HEADERS) ((char *)pDOSHeader + pDOSHeader->e_lfanew);
 112   if (pPEHeader->Signature != IMAGE_NT_SIGNATURE)
 113     return 0;
 114
 115   return (pPEHeader->OptionalHeader.Subsystem == IMAGE_SUBSYSTEM_WINDOWS_GUI);
 116 }
 117 #endif
 118
 119 void
 120 rtsFatalInternalErrorFn(char *s, va_list ap)
 121 {
 122 #if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
 123   if (isGUIApp())
 124   {
 125      char title[BUFSIZE], message[BUFSIZE];
 126      int r;
 127
 128          r = vsnprintf(title,   BUFSIZE, "%s: internal error", prog_name);
 129          if (r > 0 && r < BUFSIZE) {
 130                  strcpy(title, "internal error");
 131      }
 132
 133          r = vsnprintf(message, BUFSIZE, s, ap);
 134          if (r > 0 && r < BUFSIZE) {
 135            MessageBox(NULL /* hWnd */,
 136          message,
 137          title,
 138          MB_OK | MB_ICONERROR | MB_TASKMODAL
 139          );
 140      };
 141   }
 142   else
 143 #endif
 144   {
 145      /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 146      if (prog_argv != NULL && prog_name != NULL) {
 147        fprintf(stderr, "%s: internal error: ", prog_name);
 148      } else {
 149        fprintf(stderr, "internal error: ");
 150      }
 151      vfprintf(stderr, s, ap);
 152      fprintf(stderr, "\n");
 153      fprintf(stderr, "    Please report this as a bug to glasgow-haskell-bugs@haskell.org,\n    or http://www.sourceforge.net/projects/ghc/\n");
 154      fflush(stderr);
 155   }
 156
 157   stg_exit(EXIT_INTERNAL_ERROR);
 158 }
 159
 160 void
 161 rtsErrorMsgFn(char *s, va_list ap)
 162 {
 163 #if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
 164   if (isGUIApp())
 165   {
 166      char buf[BUFSIZE];
 167      int r;
 168
 169          r = vsnprintf(buf, BUFSIZE, s, ap);
 170          if (r > 0 && r < BUFSIZE) {
 171                 MessageBox(NULL /* hWnd */,
 172               buf,
 173               prog_name,
 174               MB_OK | MB_ICONERROR | MB_TASKMODAL
 175               );
 176      }
 177   }
 178   else
 179 #endif
 180   {
 181      /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 182      if (prog_argv != NULL && prog_name != NULL) {
 183        fprintf(stderr, "%s: ", prog_name);
 184      }
 185      vfprintf(stderr, s, ap);
 186      fprintf(stderr, "\n");
 187   }
 188 }
 189
 190 void
 191 rtsDebugMsgFn(char *s, va_list ap)
 192 {
 193 #if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
 194   if (isGUIApp())
 195   {
 196      char buf[BUFSIZE];
 197          int r;
 198
 199          r = vsnprintf(buf, BUFSIZE, s, ap);
 200          if (r > 0 && r < BUFSIZE) {
 201        OutputDebugString(buf);
 202      }
 203   }
 204   else
 205 #endif
 206   {
 207      /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 208      vfprintf(stderr, s, ap);
 209      fflush(stderr);
 210   }
 211 }