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     barf("ASSERTION FAILED: file %s, line %u\n", filename, linenum);
  53 }
  54
  55 void
  56 errorBelch(char *s, ...)
  57 {
  58   va_list ap;
  59   va_start(ap,s);
  60   (*errorMsgFn)(s,ap);
  61   va_end(ap);
  62 }
  63
  64 void
  65 verrorBelch(char *s, va_list ap)
  66 {
  67   (*errorMsgFn)(s,ap);
  68 }
  69
  70 void
  71 debugBelch(char *s, ...)
  72 {
  73   va_list ap;
  74   va_start(ap,s);
  75   (*debugMsgFn)(s,ap);
  76   va_end(ap);
  77 }
  78
  79 void
  80 vdebugBelch(char *s, va_list ap)
  81 {
  82   (*debugMsgFn)(s,ap);
  83 }
  84
  85 /* -----------------------------------------------------------------------------
  86    stdio versions of the message functions
  87    -------------------------------------------------------------------------- */
  88
  89 #define BUFSIZE 512
  90
  91 #if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
  92 static int
  93 isGUIApp()
  94 {
  95   PIMAGE_DOS_HEADER pDOSHeader;
  96   PIMAGE_NT_HEADERS pPEHeader;
  97
  98   pDOSHeader = (PIMAGE_DOS_HEADER) GetModuleHandleA(NULL);
  99   if (pDOSHeader->e_magic != IMAGE_DOS_SIGNATURE)
 100     return 0;
 101
 102   pPEHeader = (PIMAGE_NT_HEADERS) ((char *)pDOSHeader + pDOSHeader->e_lfanew);
 103   if (pPEHeader->Signature != IMAGE_NT_SIGNATURE)
 104     return 0;
 105
 106   return (pPEHeader->OptionalHeader.Subsystem == IMAGE_SUBSYSTEM_WINDOWS_GUI);
 107 }
 108 #endif
 109
 110 void
 111 rtsFatalInternalErrorFn(char *s, va_list ap)
 112 {
 113 #if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
 114   if (isGUIApp())
 115   {
 116      char title[BUFSIZE], message[BUFSIZE];
 117      int r;
 118
 119          r = vsnprintf(title,   BUFSIZE, "%s: internal error", prog_name);
 120          if (r > 0 && r < BUFSIZE) {
 121                  strcpy(title, "internal error");
 122      }
 123
 124          r = vsnprintf(message, BUFSIZE, s, ap);
 125          if (r > 0 && r < BUFSIZE) {
 126            MessageBox(NULL /* hWnd */,
 127          message,
 128          title,
 129          MB_OK | MB_ICONERROR | MB_TASKMODAL
 130          );
 131      };
 132   }
 133   else
 134 #endif
 135   {
 136      /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 137      if (prog_argv != NULL && prog_name != NULL) {
 138        fprintf(stderr, "%s: internal error: ", prog_name);
 139      } else {
 140        fprintf(stderr, "internal error: ");
 141      }
 142      vfprintf(stderr, s, ap);
 143      fprintf(stderr, "\n");
 144      fprintf(stderr, "    Please report this as a bug to glasgow-haskell-bugs@haskell.org,\n    or http://www.sourceforge.net/projects/ghc/\n");
 145      fflush(stderr);
 146   }
 147
 148   stg_exit(EXIT_INTERNAL_ERROR);
 149 }
 150
 151 void
 152 rtsErrorMsgFn(char *s, va_list ap)
 153 {
 154 #if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
 155   if (isGUIApp())
 156   {
 157      char buf[BUFSIZE];
 158      int r;
 159
 160          r = vsnprintf(buf, BUFSIZE, s, ap);
 161          if (r > 0 && r < BUFSIZE) {
 162                 MessageBox(NULL /* hWnd */,
 163               buf,
 164               prog_name,
 165               MB_OK | MB_ICONERROR | MB_TASKMODAL
 166               );
 167      }
 168   }
 169   else
 170 #endif
 171   {
 172      /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 173      if (prog_argv != NULL && prog_name != NULL) {
 174        fprintf(stderr, "%s: ", prog_name);
 175      }
 176      vfprintf(stderr, s, ap);
 177      fprintf(stderr, "\n");
 178   }
 179 }
 180
 181 void
 182 rtsDebugMsgFn(char *s, va_list ap)
 183 {
 184 #if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
 185   if (isGUIApp())
 186   {
 187      char buf[BUFSIZE];
 188          int r;
 189
 190          r = vsnprintf(buf, BUFSIZE, s, ap);
 191          if (r > 0 && r < BUFSIZE) {
 192        OutputDebugString(buf);
 193      }
 194   }
 195   else
 196 #endif
 197   {
 198      /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 199      vfprintf(stderr, s, ap);
 200      fflush(stderr);
 201   }
 202 }