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