1 /* -----------------------------------------------------------------------------
3 * (c) The GHC Team, 1998-2004
5 * General utility functions used in the RTS.
7 * ---------------------------------------------------------------------------*/
9 #include "PosixSource.h"
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.
25 #if HAVE_CTIME_R && !HAVE_DECL_CTIME_R
26 extern char *ctime_r(const time_t *, char *);
33 #ifdef HAVE_GETTIMEOFDAY
46 #if defined(THREADED_RTS) && defined(openbsd_HOST_OS) && defined(HAVE_PTHREAD_H)
55 /* -----------------------------------------------------------------------------
57 -------------------------------------------------------------------------- */
61 typedef struct Allocated_ {
64 struct Allocated_ *next;
67 static Allocated *allocs = NULL;
70 static Mutex allocator_mutex;
80 initMutex(&allocator_mutex);
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);
95 shutdownAllocator(void)
100 barf("Allocator shutdown requested, but not initialised!");
104 closeMutex(&allocator_mutex);
111 if (a == NULL) return;
113 debugBelch("Warning: %p still allocated at shutdown\n",
119 static void addAllocation(void *addr, size_t len) {
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);
133 ACQUIRE_LOCK(&allocator_mutex);
134 a->next = allocs->next;
136 RELEASE_LOCK(&allocator_mutex);
139 /* This doesn't actually help as we haven't looked at the flags
140 * at the time that it matters (while running constructors) */
142 debugBelch("Ignoring allocation %p %zd as allocs is NULL\n",
147 static void removeAllocation(void *addr, int overwrite_with_aa) {
151 barf("Freeing NULL!");
154 if (allocs != NULL) {
155 ACQUIRE_LOCK(&allocator_mutex);
159 if (a->addr == addr) {
160 prev->next = a->next;
161 if (overwrite_with_aa) {
162 memset(addr, 0xaa, a->len);
165 RELEASE_LOCK(&allocator_mutex);
171 /* We would like to barf here, but we can't as conc021
172 * allocates some stuff in a constructor which then gets freed
174 /* barf("Freeing non-allocated memory at %p", addr); */
176 debugBelch("Warning: Freeing non-allocated memory at %p\n",
178 RELEASE_LOCK(&allocator_mutex);
182 debugBelch("Ignoring free of %p as allocs is NULL\n",
188 /* -----------------------------------------------------------------------------
189 Result-checking malloc wrappers.
190 -------------------------------------------------------------------------- */
193 stgMallocBytes (int n, char *msg)
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);
205 addAllocation(space, n2);
211 stgReallocBytes (void *p, int n, char *msg)
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);
223 removeAllocation(p, 0);
224 addAllocation(space, n2);
230 stgCallocBytes (int n, int m, char *msg)
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);
240 addAllocation(space, (size_t) n * (size_t) m);
245 /* To simplify changing the underlying allocator used
246 * by stgMallocBytes(), provide stgFree() as well.
252 removeAllocation(p, 1);
257 /* -----------------------------------------------------------------------------
260 Not sure if this belongs here.
261 -------------------------------------------------------------------------- */
266 StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
268 #if defined(TICKY_TICKY)
269 if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
278 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
279 OutOfHeapHook(0/*unknown request size*/,
280 RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
282 heap_overflow = rtsTrue;
286 /* -----------------------------------------------------------------------------
289 Used in addr2Integer because the C compiler on x86 chokes on
290 strlen, trying to inline it with not enough registers available.
291 -------------------------------------------------------------------------- */
293 nat stg_strlen(char *s)
302 /* -----------------------------------------------------------------------------
303 genSym stuff, used by GHC itself for its splitting unique supply.
305 ToDo: put this somewhere sensible.
306 ------------------------------------------------------------------------- */
308 static HsInt __GenSymCounter = 0;
313 return(__GenSymCounter++);
316 resetGenSymZh(void) /* it's your funeral */
319 return(__GenSymCounter);
322 /* -----------------------------------------------------------------------------
323 Get the current time as a string. Used in profiling reports.
324 -------------------------------------------------------------------------- */
329 static time_t now = 0;
330 static char nowstr[26];
335 ctime_r(&now, nowstr);
337 strcpy(nowstr, ctime(&now));
339 memmove(nowstr+16,nowstr+19,7);
340 nowstr[21] = '\0'; // removes the \n
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
349 * -------------------------------------------------------------------------- */
351 #if !defined(mingw32_HOST_OS)
353 resetNonBlockingFd(int fd)
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);
365 setNonBlockingFd(int fd)
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);
376 /* Stub defns -- async / non-blocking IO is not done
377 * via O_NONBLOCK and select() under Win32.
379 void resetNonBlockingFd(int fd STG_UNUSED) {}
380 void setNonBlockingFd(int fd STG_UNUSED) {}
384 static ullong startTime = 0;
386 /* used in a parallel setup */
390 # if defined(HAVE_GETCLOCK) && !defined(alpha_HOST_ARCH) && !defined(hppa1_1_HOST_ARCH)
393 if (getclock(TIMEOFDAY, &tv) != 0) {
395 fprintf(stderr, "Clock failed\n");
396 stg_exit(EXIT_FAILURE);
398 return tv.tv_sec * LL(1000) + tv.tv_nsec / LL(1000000) - startTime;
399 # elif HAVE_GETTIMEOFDAY && !defined(alpha_HOST_ARCH)
402 if (gettimeofday(&tv, NULL) != 0) {
404 fprintf(stderr, "Clock failed\n");
405 stg_exit(EXIT_FAILURE);
407 return tv.tv_sec * LL(1000) + tv.tv_usec / LL(1000) - startTime;
410 if ((t = time(NULL)) == (time_t) -1) {
412 fprintf(stderr, "Clock failed\n");
413 stg_exit(EXIT_FAILURE);
415 return t * LL(1000) - startTime;
420 /* -----------------------------------------------------------------------------
421 Print large numbers, with punctuation.
422 -------------------------------------------------------------------------- */
425 ullong_format_string(ullong x, char *s, rtsBool with_commas)
427 if (x < (ullong)1000)
428 sprintf(s, "%lu", (lnat)x);
429 else if (x < (ullong)1000000)
430 sprintf(s, (with_commas) ? "%lu,%3.3lu" : "%lu%3.3lu",
431 (lnat)((x)/(ullong)1000),
432 (lnat)((x)%(ullong)1000));
433 else if (x < (ullong)1000000000)
434 sprintf(s, (with_commas) ? "%lu,%3.3lu,%3.3lu" : "%lu%3.3lu%3.3lu",
435 (lnat)((x)/(ullong)1000000),
436 (lnat)((x)/(ullong)1000%(ullong)1000),
437 (lnat)((x)%(ullong)1000));
439 sprintf(s, (with_commas) ? "%lu,%3.3lu,%3.3lu,%3.3lu" : "%lu%3.3lu%3.3lu%3.3lu",
440 (lnat)((x)/(ullong)1000000000),
441 (lnat)((x)/(ullong)1000000%(ullong)1000),
442 (lnat)((x)/(ullong)1000%(ullong)1000),
443 (lnat)((x)%(ullong)1000));
448 // Can be used as a breakpoint to set on every heap check failure.
451 heapCheckFail( void )
457 * It seems that pthreads and signals interact oddly in OpenBSD & FreeBSD
458 * pthreads (and possibly others). When linking with -lpthreads, we
459 * have to use pthread_kill to send blockable signals. So use that
460 * when we have a threaded rts. So System.Posix.Signals will call
461 * genericRaise(), rather than raise(3).
463 int genericRaise(int sig) {
464 #if defined(THREADED_RTS) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS))
465 return pthread_kill(pthread_self(), sig);
471 static void mkRtsInfoPair(char *key, char *val) {
472 /* XXX should check for "s, \s etc in key and val */
473 printf(" ,(\"%s\", \"%s\")\n", key, val);
476 /* This little bit of magic allows us to say TOSTRING(SYM) and get
478 #define TOSTRING2(x) #x
479 #define TOSTRING(x) TOSTRING2(x)
481 void printRtsInfo(void) {
482 /* The first entry is just a hack to make it easy to get the
484 printf(" [(\"GHC RTS\", \"Yes\")\n");
485 mkRtsInfoPair("GHC version", ProjectVersion);
486 mkRtsInfoPair("RTS way", RtsWay);
487 mkRtsInfoPair("Host platform", HostPlatform);
488 mkRtsInfoPair("Host architecture", HostArch);
489 mkRtsInfoPair("Host OS", HostOS);
490 mkRtsInfoPair("Host vendor", HostVendor);
491 mkRtsInfoPair("Build platform", BuildPlatform);
492 mkRtsInfoPair("Build architecture", BuildArch);
493 mkRtsInfoPair("Build OS", BuildOS);
494 mkRtsInfoPair("Build vendor", BuildVendor);
495 mkRtsInfoPair("Target platform", TargetPlatform);
496 mkRtsInfoPair("Target architecture", TargetArch);
497 mkRtsInfoPair("Target OS", TargetOS);
498 mkRtsInfoPair("Target vendor", TargetVendor);
499 mkRtsInfoPair("Word size", TOSTRING(WORD_SIZE_IN_BITS));
500 mkRtsInfoPair("Compiler unregisterised", GhcUnregisterised);
501 mkRtsInfoPair("Tables next to code", GhcEnableTablesNextToCode);