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