1 /* -----------------------------------------------------------------------------
3 * (c) The GHC Team, 1998-2004
5 * General utility functions used in the RTS.
7 * ---------------------------------------------------------------------------*/
9 #include "PosixSource.h"
25 #ifdef HAVE_GETTIMEOFDAY
38 #if defined(THREADED_RTS) && defined(openbsd_HOST_OS) && defined(HAVE_PTHREAD_H)
47 /* -----------------------------------------------------------------------------
49 -------------------------------------------------------------------------- */
53 typedef struct Allocated_ {
56 struct Allocated_ *next;
59 static Allocated *allocs = NULL;
62 static Mutex allocator_mutex;
72 initMutex(&allocator_mutex);
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);
87 shutdownAllocator(void)
92 barf("Allocator shutdown requested, but not initialised!");
96 closeMutex(&allocator_mutex);
103 if (a == NULL) return;
105 debugBelch("Warning: %p still allocated at shutdown\n",
111 static void addAllocation(void *addr, size_t len) {
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);
125 ACQUIRE_LOCK(&allocator_mutex);
126 a->next = allocs->next;
128 RELEASE_LOCK(&allocator_mutex);
131 /* This doesn't actually help as we haven't looked at the flags
132 * at the time that it matters (while running constructors) */
134 debugBelch("Ignoring allocation %p %zd as allocs is NULL\n",
139 static void removeAllocation(void *addr, int overwrite_with_aa) {
143 barf("Freeing NULL!");
146 if (allocs != NULL) {
147 ACQUIRE_LOCK(&allocator_mutex);
151 if (a->addr == addr) {
152 prev->next = a->next;
153 if (overwrite_with_aa) {
154 memset(addr, 0xaa, a->len);
157 RELEASE_LOCK(&allocator_mutex);
163 /* We would like to barf here, but we can't as conc021
164 * allocates some stuff in a constructor which then gets freed
166 /* barf("Freeing non-allocated memory at %p", addr); */
168 debugBelch("Warning: Freeing non-allocated memory at %p\n",
170 RELEASE_LOCK(&allocator_mutex);
174 debugBelch("Ignoring free of %p as allocs is NULL\n",
180 /* -----------------------------------------------------------------------------
181 Result-checking malloc wrappers.
182 -------------------------------------------------------------------------- */
185 stgMallocBytes (int n, char *msg)
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);
197 addAllocation(space, n2);
203 stgReallocBytes (void *p, int n, char *msg)
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);
215 removeAllocation(p, 0);
216 addAllocation(space, n2);
222 stgCallocBytes (int n, int m, char *msg)
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);
232 addAllocation(space, (size_t) n * (size_t) m);
237 /* To simplify changing the underlying allocator used
238 * by stgMallocBytes(), provide stgFree() as well.
244 removeAllocation(p, 1);
249 /* -----------------------------------------------------------------------------
252 Not sure if this belongs here.
253 -------------------------------------------------------------------------- */
258 StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
260 #if defined(TICKY_TICKY)
261 if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
268 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
269 OutOfHeapHook(0/*unknown request size*/,
270 RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
272 #if defined(TICKY_TICKY)
273 if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
276 stg_exit(EXIT_HEAPOVERFLOW);
279 /* -----------------------------------------------------------------------------
282 Used in addr2Integer because the C compiler on x86 chokes on
283 strlen, trying to inline it with not enough registers available.
284 -------------------------------------------------------------------------- */
286 nat stg_strlen(char *s)
295 /* -----------------------------------------------------------------------------
296 genSym stuff, used by GHC itself for its splitting unique supply.
298 ToDo: put this somewhere sensible.
299 ------------------------------------------------------------------------- */
301 static HsInt __GenSymCounter = 0;
306 return(__GenSymCounter++);
309 resetGenSymZh(void) /* it's your funeral */
312 return(__GenSymCounter);
315 /* -----------------------------------------------------------------------------
316 Get the current time as a string. Used in profiling reports.
317 -------------------------------------------------------------------------- */
322 static time_t now = 0;
323 static char nowstr[26];
328 ctime_r(&now, nowstr);
330 strcpy(nowstr, ctime(&now));
332 memmove(nowstr+16,nowstr+19,7);
333 nowstr[21] = '\0'; // removes the \n
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
342 * -------------------------------------------------------------------------- */
344 #if !defined(mingw32_HOST_OS)
346 resetNonBlockingFd(int fd)
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);
358 setNonBlockingFd(int fd)
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);
369 /* Stub defns -- async / non-blocking IO is not done
370 * via O_NONBLOCK and select() under Win32.
372 void resetNonBlockingFd(int fd STG_UNUSED) {}
373 void setNonBlockingFd(int fd STG_UNUSED) {}
377 static ullong startTime = 0;
379 /* used in a parallel setup */
383 # if defined(HAVE_GETCLOCK) && !defined(alpha_HOST_ARCH) && !defined(hppa1_1_HOST_ARCH)
386 if (getclock(TIMEOFDAY, &tv) != 0) {
388 fprintf(stderr, "Clock failed\n");
389 stg_exit(EXIT_FAILURE);
391 return tv.tv_sec * LL(1000) + tv.tv_nsec / LL(1000000) - startTime;
392 # elif HAVE_GETTIMEOFDAY && !defined(alpha_HOST_ARCH)
395 if (gettimeofday(&tv, NULL) != 0) {
397 fprintf(stderr, "Clock failed\n");
398 stg_exit(EXIT_FAILURE);
400 return tv.tv_sec * LL(1000) + tv.tv_usec / LL(1000) - startTime;
403 if ((t = time(NULL)) == (time_t) -1) {
405 fprintf(stderr, "Clock failed\n");
406 stg_exit(EXIT_FAILURE);
408 return t * LL(1000) - startTime;
413 /* -----------------------------------------------------------------------------
414 Print large numbers, with punctuation.
415 -------------------------------------------------------------------------- */
418 ullong_format_string(ullong x, char *s, rtsBool with_commas)
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));
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));
441 // Can be used as a breakpoint to set on every heap check failure.
444 heapCheckFail( void )
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).
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);
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);
469 void printRtsInfo(void) {
470 /* The first entry is just a hack to make it easy to get the
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);