Use message-passing to implement throwTo in the RTS
[ghc-hetmet.git] / 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 "eventlog/EventLog.h"
13
14 #include <stdio.h>
15 #include <string.h>
16 #include <errno.h>
17
18 #ifdef HAVE_WINDOWS_H
19 #include <windows.h>
20 #endif
21
22 /* -----------------------------------------------------------------------------
23    General message generation functions
24
25    All messages should go through here.  We can't guarantee that
26    stdout/stderr will be available - e.g. in a Windows program there
27    is no console for generating messages, so they have to either go to
28    to the debug console, or pop up message boxes.
29    -------------------------------------------------------------------------- */
30
31 // Default to the stdio implementation of these hooks.
32 RtsMsgFunction *fatalInternalErrorFn = rtsFatalInternalErrorFn;
33 RtsMsgFunction *debugMsgFn           = rtsDebugMsgFn;
34 RtsMsgFunction *errorMsgFn           = rtsErrorMsgFn;
35 RtsMsgFunction *sysErrorMsgFn        = rtsSysErrorMsgFn;
36
37 void
38 barf(const char*s, ...)
39 {
40   va_list ap;
41   va_start(ap,s);
42   (*fatalInternalErrorFn)(s,ap);
43   stg_exit(EXIT_INTERNAL_ERROR); // just in case fatalInternalErrorFn() returns
44   va_end(ap);
45 }
46
47 void
48 vbarf(const char*s, va_list ap)
49 {
50   (*fatalInternalErrorFn)(s,ap);
51   stg_exit(EXIT_INTERNAL_ERROR); // just in case fatalInternalErrorFn() returns
52 }
53
54 void 
55 _assertFail(const char*filename, unsigned int linenum)
56 {
57     barf("ASSERTION FAILED: file %s, line %u\n", filename, linenum);
58 }
59
60 void
61 errorBelch(const char*s, ...)
62 {
63   va_list ap;
64   va_start(ap,s);
65   (*errorMsgFn)(s,ap);
66   va_end(ap);
67 }
68
69 void
70 verrorBelch(const char*s, va_list ap)
71 {
72   (*errorMsgFn)(s,ap);
73 }
74
75 void
76 sysErrorBelch(const char*s, ...)
77 {
78   va_list ap;
79   va_start(ap,s);
80   (*sysErrorMsgFn)(s,ap);
81   va_end(ap);
82 }
83
84 void
85 vsysErrorBelch(const char*s, va_list ap)
86 {
87   (*sysErrorMsgFn)(s,ap);
88 }
89
90 void
91 debugBelch(const char*s, ...)
92 {
93   va_list ap;
94   va_start(ap,s);
95   (*debugMsgFn)(s,ap);
96   va_end(ap);
97 }
98
99 void
100 vdebugBelch(const char*s, va_list ap)
101 {
102   (*debugMsgFn)(s,ap);
103 }
104
105 /* -----------------------------------------------------------------------------
106    stdio versions of the message functions
107    -------------------------------------------------------------------------- */
108
109 #define BUFSIZE 512
110
111 #if defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
112 static int
113 isGUIApp(void)
114 {
115   PIMAGE_DOS_HEADER pDOSHeader;
116   PIMAGE_NT_HEADERS pPEHeader;
117
118   pDOSHeader = (PIMAGE_DOS_HEADER) GetModuleHandleA(NULL);
119   if (pDOSHeader->e_magic != IMAGE_DOS_SIGNATURE)
120     return 0;
121
122   pPEHeader = (PIMAGE_NT_HEADERS) ((char *)pDOSHeader + pDOSHeader->e_lfanew);
123   if (pPEHeader->Signature != IMAGE_NT_SIGNATURE)
124     return 0;
125
126   return (pPEHeader->OptionalHeader.Subsystem == IMAGE_SUBSYSTEM_WINDOWS_GUI);
127 }
128 #endif
129
130 #define xstr(s) str(s)
131 #define str(s) #s
132
133 void GNU_ATTRIBUTE(__noreturn__)
134 rtsFatalInternalErrorFn(const char *s, va_list ap)
135 {
136 #if defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
137   if (isGUIApp())
138   {
139      char title[BUFSIZE], message[BUFSIZE];
140
141      snprintf(title,   BUFSIZE, "%s: internal error", prog_name);
142      vsnprintf(message, BUFSIZE, s, ap);
143
144      MessageBox(NULL /* hWnd */,
145                 message,
146                 title,
147                 MB_OK | MB_ICONERROR | MB_TASKMODAL
148                );
149   }
150   else
151 #endif
152   {
153      /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
154      if (prog_argv != NULL && prog_name != NULL) {
155        fprintf(stderr, "%s: internal error: ", prog_name);
156      } else {
157        fprintf(stderr, "internal error: ");
158      }
159      vfprintf(stderr, s, ap);
160      fprintf(stderr, "\n");
161      fprintf(stderr, "    (GHC version %s for %s)\n", ProjectVersion, xstr(HostPlatform_TYPE));
162      fprintf(stderr, "    Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n");
163      fflush(stderr);
164   }
165
166 #ifdef TRACING
167   if (RtsFlags.TraceFlags.tracing == TRACE_EVENTLOG) endEventLogging();
168 #endif
169
170   abort();
171   // stg_exit(EXIT_INTERNAL_ERROR);
172 }
173
174 void
175 rtsErrorMsgFn(const char *s, va_list ap)
176 {
177 #if defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
178   if (isGUIApp())
179   {
180      char buf[BUFSIZE];
181      int r;
182
183          r = vsnprintf(buf, BUFSIZE, s, ap);
184          if (r > 0 && r < BUFSIZE) {
185                 MessageBox(NULL /* hWnd */,
186               buf,
187               prog_name,
188               MB_OK | MB_ICONERROR | MB_TASKMODAL
189               );
190      }
191   }
192   else
193 #endif
194   {
195      /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
196      if (prog_name != NULL) {
197        fprintf(stderr, "%s: ", prog_name);
198      }
199      vfprintf(stderr, s, ap);
200      fprintf(stderr, "\n");
201   }
202 }
203
204 void
205 rtsSysErrorMsgFn(const char *s, va_list ap)
206 {
207     char *syserr;
208
209 #if defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
210     FormatMessage( 
211         FORMAT_MESSAGE_ALLOCATE_BUFFER | 
212         FORMAT_MESSAGE_FROM_SYSTEM | 
213         FORMAT_MESSAGE_IGNORE_INSERTS,
214         NULL,
215         GetLastError(),
216         MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), // Default language
217         (LPTSTR) &syserr,
218         0,
219         NULL );
220
221     if (isGUIApp())
222     {
223         char buf[BUFSIZE];
224         int r;
225         
226         r = vsnprintf(buf, BUFSIZE, s, ap);
227         if (r > 0 && r < BUFSIZE) {
228             r = vsnprintf(buf+r, BUFSIZE-r, ": %s", syserr);
229             MessageBox(NULL /* hWnd */,
230                        buf,
231                        prog_name,
232                        MB_OK | MB_ICONERROR | MB_TASKMODAL
233                 );
234         }
235     }
236     else
237 #else
238     syserr = strerror(errno);
239     // ToDo: use strerror_r() if available
240 #endif
241     {
242         /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
243         if (prog_argv != NULL && prog_name != NULL) {
244             fprintf(stderr, "%s: ", prog_name);
245         }
246         vfprintf(stderr, s, ap);
247         if (syserr) {
248 #if defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
249             // Win32 error messages have a terminating \n
250             fprintf(stderr, ": %s", syserr);
251 #else
252             fprintf(stderr, ": %s\n", syserr);
253 #endif
254         } else {
255             fprintf(stderr, "\n");
256         }
257     }
258
259 #if defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
260     if (syserr) LocalFree(syserr);
261 #endif
262 }
263
264 void
265 rtsDebugMsgFn(const char *s, va_list ap)
266 {
267 #if defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
268   if (isGUIApp())
269   {
270      char buf[BUFSIZE];
271          int r;
272
273          r = vsnprintf(buf, BUFSIZE, s, ap);
274          if (r > 0 && r < BUFSIZE) {
275        OutputDebugString(buf);
276      }
277   }
278   else
279 #endif
280   {
281      /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
282      vfprintf(stderr, s, ap);
283      fflush(stderr);
284   }
285 }