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