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