1 /* -----------------------------------------------------------------------------
3 * (c) The GHC Team, 1998-2004
5 * General utility functions used in the RTS.
7 * ---------------------------------------------------------------------------*/
9 #include "PosixSource.h"
21 /* HACK: On Mac OS X 10.4 (at least), time.h doesn't declare ctime_r with
22 * _POSIX_C_SOURCE. If this is the case, we declare it ourselves.
24 #if HAVE_CTIME_R && !HAVE_DECL_CTIME_R
25 extern char *ctime_r(const time_t *, char *);
32 #ifdef HAVE_GETTIMEOFDAY
45 #if defined(THREADED_RTS) && defined(openbsd_HOST_OS) && defined(HAVE_PTHREAD_H)
54 /* -----------------------------------------------------------------------------
56 -------------------------------------------------------------------------- */
60 typedef struct Allocated_ {
63 struct Allocated_ *next;
66 static Allocated *allocs = NULL;
69 static Mutex allocator_mutex;
79 initMutex(&allocator_mutex);
81 alloc_size = sizeof(Allocated);
82 if ((a = (Allocated *) malloc(alloc_size)) == NULL) {
83 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
84 MallocFailHook((W_) alloc_size, "initialising debugging allocator");
85 stg_exit(EXIT_INTERNAL_ERROR);
94 shutdownAllocator(void)
99 barf("Allocator shutdown requested, but not initialised!");
103 closeMutex(&allocator_mutex);
110 if (a == NULL) return;
112 debugBelch("Warning: %ld bytes at %p still allocated at shutdown\n",
113 (long)a->len, a->addr);)
118 static void addAllocation(void *addr, size_t len) {
122 if (allocs != NULL) {
123 alloc_size = sizeof(Allocated);
124 if ((a = (Allocated *) malloc(alloc_size)) == NULL) {
125 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
126 MallocFailHook((W_) alloc_size,
127 "creating info for debugging allocator");
128 stg_exit(EXIT_INTERNAL_ERROR);
132 ACQUIRE_LOCK(&allocator_mutex);
133 a->next = allocs->next;
135 RELEASE_LOCK(&allocator_mutex);
138 /* This doesn't actually help as we haven't looked at the flags
139 * at the time that it matters (while running constructors) */
141 debugBelch("Ignoring allocation %p %d as allocs is NULL\n",
146 static void removeAllocation(void *addr, int overwrite_with_aa) {
150 barf("Freeing NULL!");
153 if (allocs != NULL) {
154 ACQUIRE_LOCK(&allocator_mutex);
158 if (a->addr == addr) {
159 prev->next = a->next;
160 if (overwrite_with_aa) {
161 memset(addr, 0xaa, a->len);
164 RELEASE_LOCK(&allocator_mutex);
170 /* We would like to barf here, but we can't as conc021
171 * allocates some stuff in a constructor which then gets freed
173 /* barf("Freeing non-allocated memory at %p", addr); */
175 debugBelch("Warning: Freeing non-allocated memory at %p\n",
177 RELEASE_LOCK(&allocator_mutex);
181 debugBelch("Ignoring free of %p as allocs is NULL\n",
187 /* -----------------------------------------------------------------------------
188 Result-checking malloc wrappers.
189 -------------------------------------------------------------------------- */
192 stgMallocBytes (int n, char *msg)
198 if ((space = (char *) malloc(n2)) == NULL) {
199 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
200 MallocFailHook((W_) n, msg); /*msg*/
201 stg_exit(EXIT_INTERNAL_ERROR);
204 addAllocation(space, n2);
210 stgReallocBytes (void *p, int n, char *msg)
216 if ((space = (char *) realloc(p, (size_t) n2)) == NULL) {
217 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
218 MallocFailHook((W_) n, msg); /*msg*/
219 stg_exit(EXIT_INTERNAL_ERROR);
222 removeAllocation(p, 0);
223 addAllocation(space, n2);
229 stgCallocBytes (int n, int m, char *msg)
233 if ((space = (char *) calloc((size_t) n, (size_t) m)) == NULL) {
234 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
235 MallocFailHook((W_) n*m, msg); /*msg*/
236 stg_exit(EXIT_INTERNAL_ERROR);
239 addAllocation(space, (size_t) n * (size_t) m);
244 /* To simplify changing the underlying allocator used
245 * by stgMallocBytes(), provide stgFree() as well.
251 removeAllocation(p, 1);
256 /* -----------------------------------------------------------------------------
259 Not sure if this belongs here.
260 -------------------------------------------------------------------------- */
265 StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
267 #if defined(TICKY_TICKY)
268 if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
277 /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
278 OutOfHeapHook(0/*unknown request size*/,
279 RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
281 heap_overflow = rtsTrue;
285 /* -----------------------------------------------------------------------------
286 genSym stuff, used by GHC itself for its splitting unique supply.
288 ToDo: put this somewhere sensible.
289 ------------------------------------------------------------------------- */
291 static HsInt __GenSymCounter = 0;
296 return(__GenSymCounter++);
299 resetGenSymZh(void) /* it's your funeral */
302 return(__GenSymCounter);
305 /* -----------------------------------------------------------------------------
306 Get the current time as a string. Used in profiling reports.
307 -------------------------------------------------------------------------- */
312 static time_t now = 0;
313 static char nowstr[26];
318 ctime_r(&now, nowstr);
320 strcpy(nowstr, ctime(&now));
322 memmove(nowstr+16,nowstr+19,7);
323 nowstr[21] = '\0'; // removes the \n
328 /* -----------------------------------------------------------------------------
329 Print large numbers, with punctuation.
330 -------------------------------------------------------------------------- */
333 showStgWord64(StgWord64 x, char *s, rtsBool with_commas)
336 if (x < (StgWord64)1e3)
337 sprintf(s, "%" FMT_Word64, (StgWord64)x);
338 else if (x < (StgWord64)1e6)
339 sprintf(s, "%" FMT_Word64 ",%03" FMT_Word64,
340 (StgWord64)(x / 1000),
341 (StgWord64)(x % 1000));
342 else if (x < (StgWord64)1e9)
343 sprintf(s, "%" FMT_Word64
346 (StgWord64)(x / 1e6),
347 (StgWord64)((x / 1000) % 1000),
348 (StgWord64)(x % 1000));
349 else if (x < (StgWord64)1e12)
350 sprintf(s, "%" FMT_Word64
354 (StgWord64)(x / (StgWord64)1e9),
355 (StgWord64)((x / (StgWord64)1e6) % 1000),
356 (StgWord64)((x / (StgWord64)1e3) % 1000),
357 (StgWord64)(x % 1000));
358 else if (x < (StgWord64)1e15)
359 sprintf(s, "%" FMT_Word64
364 (StgWord64)(x / (StgWord64)1e12),
365 (StgWord64)((x / (StgWord64)1e9) % 1000),
366 (StgWord64)((x / (StgWord64)1e6) % 1000),
367 (StgWord64)((x / (StgWord64)1e3) % 1000),
368 (StgWord64)(x % 1000));
369 else if (x < (StgWord64)1e18)
370 sprintf(s, "%" FMT_Word64
376 (StgWord64)(x / (StgWord64)1e15),
377 (StgWord64)((x / (StgWord64)1e12) % 1000),
378 (StgWord64)((x / (StgWord64)1e9) % 1000),
379 (StgWord64)((x / (StgWord64)1e6) % 1000),
380 (StgWord64)((x / (StgWord64)1e3) % 1000),
381 (StgWord64)(x % 1000));
383 sprintf(s, "%" FMT_Word64
390 (StgWord64)(x / (StgWord64)1e18),
391 (StgWord64)((x / (StgWord64)1e15) % 1000),
392 (StgWord64)((x / (StgWord64)1e12) % 1000),
393 (StgWord64)((x / (StgWord64)1e9) % 1000),
394 (StgWord64)((x / (StgWord64)1e6) % 1000),
395 (StgWord64)((x / (StgWord64)1e3) % 1000),
396 (StgWord64)(x % 1000));
399 sprintf(s, "%" FMT_Word64, x);
405 // Can be used as a breakpoint to set on every heap check failure.
408 heapCheckFail( void )
414 * It seems that pthreads and signals interact oddly in OpenBSD & FreeBSD
415 * pthreads (and possibly others). When linking with -lpthreads, we
416 * have to use pthread_kill to send blockable signals. So use that
417 * when we have a threaded rts. So System.Posix.Signals will call
418 * genericRaise(), rather than raise(3).
420 int genericRaise(int sig) {
421 #if defined(THREADED_RTS) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS))
422 return pthread_kill(pthread_self(), sig);
428 static void mkRtsInfoPair(char *key, char *val) {
429 /* XXX should check for "s, \s etc in key and val */
430 printf(" ,(\"%s\", \"%s\")\n", key, val);
433 /* This little bit of magic allows us to say TOSTRING(SYM) and get
435 #define TOSTRING2(x) #x
436 #define TOSTRING(x) TOSTRING2(x)
438 void printRtsInfo(void) {
439 /* The first entry is just a hack to make it easy to get the
441 printf(" [(\"GHC RTS\", \"YES\")\n");
442 mkRtsInfoPair("GHC version", ProjectVersion);
443 mkRtsInfoPair("RTS way", RtsWay);
444 mkRtsInfoPair("Host platform", HostPlatform);
445 mkRtsInfoPair("Host architecture", HostArch);
446 mkRtsInfoPair("Host OS", HostOS);
447 mkRtsInfoPair("Host vendor", HostVendor);
448 mkRtsInfoPair("Build platform", BuildPlatform);
449 mkRtsInfoPair("Build architecture", BuildArch);
450 mkRtsInfoPair("Build OS", BuildOS);
451 mkRtsInfoPair("Build vendor", BuildVendor);
452 mkRtsInfoPair("Target platform", TargetPlatform);
453 mkRtsInfoPair("Target architecture", TargetArch);
454 mkRtsInfoPair("Target OS", TargetOS);
455 mkRtsInfoPair("Target vendor", TargetVendor);
456 mkRtsInfoPair("Word size", TOSTRING(WORD_SIZE_IN_BITS));
457 mkRtsInfoPair("Compiler unregisterised", GhcUnregisterised);
458 mkRtsInfoPair("Tables next to code", GhcEnableTablesNextToCode);
462 // Provides a way for Haskell programs to tell whether they're being
463 // profiled or not. GHCi uses it (see #2197).
464 int rts_isProfiled(void)