Fix #2197 (properly this time)
[ghc.git] / rts / RtsUtils.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
11 #include "Rts.h"
12 #include "RtsAPI.h"
13 #include "RtsFlags.h"
14 #include "RtsUtils.h"
15 #include "Ticky.h"
16 #include "Schedule.h"
17
18 #ifdef HAVE_TIME_H
19 #include <time.h>
20 #endif
21
22 /* HACK: On Mac OS X 10.4 (at least), time.h doesn't declare ctime_r with
23 * _POSIX_C_SOURCE. If this is the case, we declare it ourselves.
24 */
25 #if HAVE_CTIME_R && !HAVE_DECL_CTIME_R
26 extern char *ctime_r(const time_t *, char *);
27 #endif
28
29 #ifdef HAVE_FCNTL_H
30 #include <fcntl.h>
31 #endif
32
33 #ifdef HAVE_GETTIMEOFDAY
34 #include <sys/time.h>
35 #endif
36
37 #include <stdlib.h>
38 #include <string.h>
39 #include <stdarg.h>
40 #include <stdio.h>
41
42 #ifdef HAVE_SIGNAL_H
43 #include <signal.h>
44 #endif
45
46 #if defined(THREADED_RTS) && defined(openbsd_HOST_OS) && defined(HAVE_PTHREAD_H)
47 #include <pthread.h>
48 #endif
49
50
51 #if defined(_WIN32)
52 #include <windows.h>
53 #endif
54
55 /* -----------------------------------------------------------------------------
56 Debugging allocator
57 -------------------------------------------------------------------------- */
58
59 #if defined(DEBUG)
60
61 typedef struct Allocated_ {
62 void *addr;
63 size_t len;
64 struct Allocated_ *next;
65 } Allocated;
66
67 static Allocated *allocs = NULL;
68
69 #ifdef THREADED_RTS
70 static Mutex allocator_mutex;
71 #endif
72
73 void
74 initAllocator(void)
75 {
76 Allocated *a;
77 size_t alloc_size;
78
79 #ifdef THREADED_RTS
80 initMutex(&allocator_mutex);
81 #endif
82 alloc_size = sizeof(Allocated);
83 if ((a = (Allocated *) malloc(alloc_size)) == NULL) {
84 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
85 MallocFailHook((W_) alloc_size, "initialising debugging allocator");
86 stg_exit(EXIT_INTERNAL_ERROR);
87 }
88 a->addr = NULL;
89 a->len = 0;
90 a->next = NULL;
91 allocs = a;
92 }
93
94 void
95 shutdownAllocator(void)
96 {
97 Allocated *prev, *a;
98
99 if (allocs == NULL) {
100 barf("Allocator shutdown requested, but not initialised!");
101 }
102
103 #ifdef THREADED_RTS
104 closeMutex(&allocator_mutex);
105 #endif
106
107 prev = allocs;
108 while (1) {
109 a = prev->next;
110 free(prev);
111 if (a == NULL) return;
112 IF_DEBUG(sanity,
113 debugBelch("Warning: %p still allocated at shutdown\n",
114 a->addr);)
115 prev = a;
116 }
117 }
118
119 static void addAllocation(void *addr, size_t len) {
120 Allocated *a;
121 size_t alloc_size;
122
123 if (allocs != NULL) {
124 alloc_size = sizeof(Allocated);
125 if ((a = (Allocated *) malloc(alloc_size)) == NULL) {
126 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
127 MallocFailHook((W_) alloc_size,
128 "creating info for debugging allocator");
129 stg_exit(EXIT_INTERNAL_ERROR);
130 }
131 a->addr = addr;
132 a->len = len;
133 ACQUIRE_LOCK(&allocator_mutex);
134 a->next = allocs->next;
135 allocs->next = a;
136 RELEASE_LOCK(&allocator_mutex);
137 }
138 else {
139 /* This doesn't actually help as we haven't looked at the flags
140 * at the time that it matters (while running constructors) */
141 IF_DEBUG(sanity,
142 debugBelch("Ignoring allocation %p %zd as allocs is NULL\n",
143 addr, len);)
144 }
145 }
146
147 static void removeAllocation(void *addr, int overwrite_with_aa) {
148 Allocated *prev, *a;
149
150 if (addr == NULL) {
151 barf("Freeing NULL!");
152 }
153
154 if (allocs != NULL) {
155 ACQUIRE_LOCK(&allocator_mutex);
156 prev = allocs;
157 a = prev->next;
158 while (a != NULL) {
159 if (a->addr == addr) {
160 prev->next = a->next;
161 if (overwrite_with_aa) {
162 memset(addr, 0xaa, a->len);
163 }
164 free(a);
165 RELEASE_LOCK(&allocator_mutex);
166 return;
167 }
168 prev = a;
169 a = a->next;
170 }
171 /* We would like to barf here, but we can't as conc021
172 * allocates some stuff in a constructor which then gets freed
173 * during hs_exit */
174 /* barf("Freeing non-allocated memory at %p", addr); */
175 IF_DEBUG(sanity,
176 debugBelch("Warning: Freeing non-allocated memory at %p\n",
177 addr);)
178 RELEASE_LOCK(&allocator_mutex);
179 }
180 else {
181 IF_DEBUG(sanity,
182 debugBelch("Ignoring free of %p as allocs is NULL\n",
183 addr);)
184 }
185 }
186 #endif
187
188 /* -----------------------------------------------------------------------------
189 Result-checking malloc wrappers.
190 -------------------------------------------------------------------------- */
191
192 void *
193 stgMallocBytes (int n, char *msg)
194 {
195 char *space;
196 size_t n2;
197
198 n2 = (size_t) n;
199 if ((space = (char *) malloc(n2)) == NULL) {
200 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
201 MallocFailHook((W_) n, msg); /*msg*/
202 stg_exit(EXIT_INTERNAL_ERROR);
203 }
204 #if defined(DEBUG)
205 addAllocation(space, n2);
206 #endif
207 return space;
208 }
209
210 void *
211 stgReallocBytes (void *p, int n, char *msg)
212 {
213 char *space;
214 size_t n2;
215
216 n2 = (size_t) n;
217 if ((space = (char *) realloc(p, (size_t) n2)) == NULL) {
218 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
219 MallocFailHook((W_) n, msg); /*msg*/
220 stg_exit(EXIT_INTERNAL_ERROR);
221 }
222 #if defined(DEBUG)
223 removeAllocation(p, 0);
224 addAllocation(space, n2);
225 #endif
226 return space;
227 }
228
229 void *
230 stgCallocBytes (int n, int m, char *msg)
231 {
232 char *space;
233
234 if ((space = (char *) calloc((size_t) n, (size_t) m)) == NULL) {
235 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
236 MallocFailHook((W_) n*m, msg); /*msg*/
237 stg_exit(EXIT_INTERNAL_ERROR);
238 }
239 #if defined(DEBUG)
240 addAllocation(space, (size_t) n * (size_t) m);
241 #endif
242 return space;
243 }
244
245 /* To simplify changing the underlying allocator used
246 * by stgMallocBytes(), provide stgFree() as well.
247 */
248 void
249 stgFree(void* p)
250 {
251 #if defined(DEBUG)
252 removeAllocation(p, 1);
253 #endif
254 free(p);
255 }
256
257 /* -----------------------------------------------------------------------------
258 Stack overflow
259
260 Not sure if this belongs here.
261 -------------------------------------------------------------------------- */
262
263 void
264 stackOverflow(void)
265 {
266 StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
267
268 #if defined(TICKY_TICKY)
269 if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
270 #endif
271 }
272
273 void
274 heapOverflow(void)
275 {
276 if (!heap_overflow)
277 {
278 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
279 OutOfHeapHook(0/*unknown request size*/,
280 RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
281
282 heap_overflow = rtsTrue;
283 }
284 }
285
286 /* -----------------------------------------------------------------------------
287 Out-of-line strlen.
288
289 Used in addr2Integer because the C compiler on x86 chokes on
290 strlen, trying to inline it with not enough registers available.
291 -------------------------------------------------------------------------- */
292
293 nat stg_strlen(char *s)
294 {
295 char *p = s;
296
297 while (*p) p++;
298 return p-s;
299 }
300
301
302 /* -----------------------------------------------------------------------------
303 genSym stuff, used by GHC itself for its splitting unique supply.
304
305 ToDo: put this somewhere sensible.
306 ------------------------------------------------------------------------- */
307
308 static HsInt __GenSymCounter = 0;
309
310 HsInt
311 genSymZh(void)
312 {
313 return(__GenSymCounter++);
314 }
315 HsInt
316 resetGenSymZh(void) /* it's your funeral */
317 {
318 __GenSymCounter=0;
319 return(__GenSymCounter);
320 }
321
322 /* -----------------------------------------------------------------------------
323 Get the current time as a string. Used in profiling reports.
324 -------------------------------------------------------------------------- */
325
326 char *
327 time_str(void)
328 {
329 static time_t now = 0;
330 static char nowstr[26];
331
332 if (now == 0) {
333 time(&now);
334 #if HAVE_CTIME_R
335 ctime_r(&now, nowstr);
336 #else
337 strcpy(nowstr, ctime(&now));
338 #endif
339 memmove(nowstr+16,nowstr+19,7);
340 nowstr[21] = '\0'; // removes the \n
341 }
342 return nowstr;
343 }
344
345 /* -----------------------------------------------------------------------------
346 * Reset a file handle to blocking mode. We do this for the standard
347 * file descriptors before exiting, because the shell doesn't always
348 * clean up for us.
349 * -------------------------------------------------------------------------- */
350
351 #if !defined(mingw32_HOST_OS)
352 void
353 resetNonBlockingFd(int fd)
354 {
355 long fd_flags;
356
357 /* clear the non-blocking flag on this file descriptor */
358 fd_flags = fcntl(fd, F_GETFL);
359 if (fd_flags & O_NONBLOCK) {
360 fcntl(fd, F_SETFL, fd_flags & ~O_NONBLOCK);
361 }
362 }
363
364 void
365 setNonBlockingFd(int fd)
366 {
367 long fd_flags;
368
369 /* clear the non-blocking flag on this file descriptor */
370 fd_flags = fcntl(fd, F_GETFL);
371 if (!(fd_flags & O_NONBLOCK)) {
372 fcntl(fd, F_SETFL, fd_flags | O_NONBLOCK);
373 }
374 }
375 #else
376 /* Stub defns -- async / non-blocking IO is not done
377 * via O_NONBLOCK and select() under Win32.
378 */
379 void resetNonBlockingFd(int fd STG_UNUSED) {}
380 void setNonBlockingFd(int fd STG_UNUSED) {}
381 #endif
382
383 /* -----------------------------------------------------------------------------
384 Print large numbers, with punctuation.
385 -------------------------------------------------------------------------- */
386
387 char *
388 ullong_format_string(ullong x, char *s, rtsBool with_commas)
389 {
390 if (x < (ullong)1000)
391 sprintf(s, "%lu", (lnat)x);
392 else if (x < (ullong)1000000)
393 sprintf(s, (with_commas) ? "%lu,%3.3lu" : "%lu%3.3lu",
394 (lnat)((x)/(ullong)1000),
395 (lnat)((x)%(ullong)1000));
396 else if (x < (ullong)1000000000)
397 sprintf(s, (with_commas) ? "%lu,%3.3lu,%3.3lu" : "%lu%3.3lu%3.3lu",
398 (lnat)((x)/(ullong)1000000),
399 (lnat)((x)/(ullong)1000%(ullong)1000),
400 (lnat)((x)%(ullong)1000));
401 else
402 sprintf(s, (with_commas) ? "%lu,%3.3lu,%3.3lu,%3.3lu" : "%lu%3.3lu%3.3lu%3.3lu",
403 (lnat)((x)/(ullong)1000000000),
404 (lnat)((x)/(ullong)1000000%(ullong)1000),
405 (lnat)((x)/(ullong)1000%(ullong)1000),
406 (lnat)((x)%(ullong)1000));
407 return s;
408 }
409
410
411 // Can be used as a breakpoint to set on every heap check failure.
412 #ifdef DEBUG
413 void
414 heapCheckFail( void )
415 {
416 }
417 #endif
418
419 /*
420 * It seems that pthreads and signals interact oddly in OpenBSD & FreeBSD
421 * pthreads (and possibly others). When linking with -lpthreads, we
422 * have to use pthread_kill to send blockable signals. So use that
423 * when we have a threaded rts. So System.Posix.Signals will call
424 * genericRaise(), rather than raise(3).
425 */
426 int genericRaise(int sig) {
427 #if defined(THREADED_RTS) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS))
428 return pthread_kill(pthread_self(), sig);
429 #else
430 return raise(sig);
431 #endif
432 }
433
434 static void mkRtsInfoPair(char *key, char *val) {
435 /* XXX should check for "s, \s etc in key and val */
436 printf(" ,(\"%s\", \"%s\")\n", key, val);
437 }
438
439 /* This little bit of magic allows us to say TOSTRING(SYM) and get
440 * "5" if SYM is 5 */
441 #define TOSTRING2(x) #x
442 #define TOSTRING(x) TOSTRING2(x)
443
444 void printRtsInfo(void) {
445 /* The first entry is just a hack to make it easy to get the
446 * commas right */
447 printf(" [(\"GHC RTS\", \"YES\")\n");
448 mkRtsInfoPair("GHC version", ProjectVersion);
449 mkRtsInfoPair("RTS way", RtsWay);
450 mkRtsInfoPair("Host platform", HostPlatform);
451 mkRtsInfoPair("Host architecture", HostArch);
452 mkRtsInfoPair("Host OS", HostOS);
453 mkRtsInfoPair("Host vendor", HostVendor);
454 mkRtsInfoPair("Build platform", BuildPlatform);
455 mkRtsInfoPair("Build architecture", BuildArch);
456 mkRtsInfoPair("Build OS", BuildOS);
457 mkRtsInfoPair("Build vendor", BuildVendor);
458 mkRtsInfoPair("Target platform", TargetPlatform);
459 mkRtsInfoPair("Target architecture", TargetArch);
460 mkRtsInfoPair("Target OS", TargetOS);
461 mkRtsInfoPair("Target vendor", TargetVendor);
462 mkRtsInfoPair("Word size", TOSTRING(WORD_SIZE_IN_BITS));
463 mkRtsInfoPair("Compiler unregisterised", GhcUnregisterised);
464 mkRtsInfoPair("Tables next to code", GhcEnableTablesNextToCode);
465 printf(" ]\n");
466 }
467
468 // Provides a way for Haskell programs to tell whether they're being
469 // profiled or not. GHCi uses it (see #2197).
470 int rts_isProfiled(void)
471 {
472 #ifdef PROFILING
473 return 1;
474 #else
475 return 0;
476 #endif
477 }