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