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