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 showStgWord64(StgWord64 x, char *s, rtsBool with_commas)
 334 {
 335     if (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
 344                            ",%03" FMT_Word64
 345                            ",%03" 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
 351                            ",%03" FMT_Word64
 352                            ",%03" FMT_Word64
 353                            ",%03" 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
 360                            ",%03" FMT_Word64
 361                            ",%03" FMT_Word64
 362                            ",%03" FMT_Word64
 363                            ",%03" 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
 371                            ",%03" FMT_Word64
 372                            ",%03" FMT_Word64
 373                            ",%03" FMT_Word64
 374                            ",%03" FMT_Word64
 375                            ",%03" 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));
 382         else
 383                 sprintf(s, "%"    FMT_Word64
 384                            ",%03" FMT_Word64
 385                            ",%03" FMT_Word64
 386                            ",%03" FMT_Word64
 387                            ",%03" FMT_Word64
 388                            ",%03" FMT_Word64
 389                            ",%03" 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));
 397     }
 398     else {
 399         sprintf(s, "%" FMT_Word64, x);
 400     }
 401     return s;
 402 }
 403
 404
 405 // Can be used as a breakpoint to set on every heap check failure.
 406 #ifdef DEBUG
 407 void
 408 heapCheckFail( void )
 409 {
 410 }
 411 #endif
 412
 413 /*
 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).
 419  */
 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);
 423 #else
 424         return raise(sig);
 425 #endif
 426 }
 427
 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);
 431 }
 432
 433 /* This little bit of magic allows us to say TOSTRING(SYM) and get
 434  * "5" if SYM is 5 */
 435 #define TOSTRING2(x) #x
 436 #define TOSTRING(x)  TOSTRING2(x)
 437
 438 void printRtsInfo(void) {
 439     /* The first entry is just a hack to make it easy to get the
 440      * commas right */
 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);
 459     printf(" ]\n");
 460 }
 461
 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)
 465 {
 466 #ifdef PROFILING
 467     return 1;
 468 #else
 469     return 0;
 470 #endif
 471 }