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
 118      snprintf(title,   BUFSIZE, "%s: internal error", prog_name);
 119      vsnprintf(message, BUFSIZE, s, ap);
 120
 121      MessageBox(NULL /* hWnd */,
 122                 message,
 123                 title,
 124                 MB_OK | MB_ICONERROR | MB_TASKMODAL
 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 }