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 compiler bug.  See:\n    http://www.haskell.org/ghc/reportabug\n");
 139      fflush(stderr);
 140   }
 141
 142   abort();
 143   // stg_exit(EXIT_INTERNAL_ERROR);
 144 }
 145
 146 void
 147 rtsErrorMsgFn(char *s, va_list ap)
 148 {
 149 #if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
 150   if (isGUIApp())
 151   {
 152      char buf[BUFSIZE];
 153      int r;
 154
 155          r = vsnprintf(buf, BUFSIZE, s, ap);
 156          if (r > 0 && r < BUFSIZE) {
 157                 MessageBox(NULL /* hWnd */,
 158               buf,
 159               prog_name,
 160               MB_OK | MB_ICONERROR | MB_TASKMODAL
 161               );
 162      }
 163   }
 164   else
 165 #endif
 166   {
 167      /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 168      if (prog_argv != NULL && prog_name != NULL) {
 169        fprintf(stderr, "%s: ", prog_name);
 170      }
 171      vfprintf(stderr, s, ap);
 172      fprintf(stderr, "\n");
 173   }
 174 }
 175
 176 void
 177 rtsDebugMsgFn(char *s, va_list ap)
 178 {
 179 #if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
 180   if (isGUIApp())
 181   {
 182      char buf[BUFSIZE];
 183          int r;
 184
 185          r = vsnprintf(buf, BUFSIZE, s, ap);
 186          if (r > 0 && r < BUFSIZE) {
 187        OutputDebugString(buf);
 188      }
 189   }
 190   else
 191 #endif
 192   {
 193      /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 194      vfprintf(stderr, s, ap);
 195      fflush(stderr);
 196   }
 197 }