ghc/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 /* gettimeofday isn't POSIX */
  10 /* #include "PosixSource.h" */
  11
  12 #include "Rts.h"
  13 #include "RtsTypes.h"
  14 #include "RtsAPI.h"
  15 #include "RtsFlags.h"
  16 #include "Hooks.h"
  17 #include "RtsUtils.h"
  18 #include "Ticky.h"
  19
  20 #ifdef HAVE_TIME_H
  21 #include <time.h>
  22 #endif
  23
  24 #ifdef HAVE_FCNTL_H
  25 #include <fcntl.h>
  26 #endif
  27
  28 #ifdef HAVE_GETTIMEOFDAY
  29 #include <sys/time.h>
  30 #endif
  31
  32 #include <stdlib.h>
  33 #include <string.h>
  34 #include <stdarg.h>
  35 #include <stdio.h>
  36
  37 /* -----------------------------------------------------------------------------
  38    General message generation functions
  39
  40    All messages should go through here.  We can't guarantee that
  41    stdout/stderr will be available - e.g. in a Windows program there
  42    is no console for generating messages, so they have to either go to
  43    to the debug console, or pop up message boxes.
  44    -------------------------------------------------------------------------- */
  45
  46 RtsMsgFunction *fatalInternalMsgFn = stdioFatalInternalMsgFn;
  47 RtsMsgFunction *debugMsgFn         = stdioDebugMsgFn;
  48 RtsMsgFunction *errorMsgFn         = stdioErrorMsgFn;
  49
  50 void
  51 barf(char *s, ...)
  52 {
  53   va_list ap;
  54   va_start(ap,s);
  55   (*fatalInternalMsgFn)(s,ap);
  56   stg_exit(EXIT_INTERNAL_ERROR);
  57   va_end(ap);
  58 }
  59
  60 void
  61 errorBelch(char *s, ...)
  62 {
  63   va_list ap;
  64   va_start(ap,s);
  65   (*errorMsgFn)(s,ap);
  66   va_end(ap);
  67 }
  68
  69 void
  70 debugBelch(char *s, ...)
  71 {
  72   va_list ap;
  73   va_start(ap,s);
  74   (*debugMsgFn)(s,ap);
  75   va_end(ap);
  76 }
  77
  78 void
  79 vdebugBelch(char *s, va_list ap)
  80 {
  81   (*debugMsgFn)(s,ap);
  82 }
  83
  84 /* -----------------------------------------------------------------------------
  85    stdio versions of the message functions
  86    -------------------------------------------------------------------------- */
  87
  88 void
  89 stdioFatalInternalMsgFn(char *s, va_list ap)
  90 {
  91   /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
  92   if (prog_argv != NULL && prog_name != NULL) {
  93     fprintf(stderr, "%s: internal error: ", prog_name);
  94   } else {
  95     fprintf(stderr, "internal error: ");
  96   }
  97   vfprintf(stderr, s, ap);
  98   fprintf(stderr, "\n");
  99   fprintf(stderr, "    Please report this as a bug to glasgow-haskell-bugs@haskell.org,\n    or http://www.sourceforge.net/projects/ghc/\n");
 100   fflush(stderr);
 101 }
 102
 103 void
 104 stdioErrorMsgFn(char *s, va_list ap)
 105 {
 106   /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 107   if (prog_argv != NULL && prog_name != NULL) {
 108     fprintf(stderr, "%s: ", prog_name);
 109   }
 110   vfprintf(stderr, s, ap);
 111   fprintf(stderr, "\n");
 112 }
 113
 114 void
 115 stdioDebugMsgFn(char *s, va_list ap)
 116 {
 117   /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 118   vfprintf(stderr, s, ap);
 119   fflush(stderr);
 120 }
 121
 122 /* -----------------------------------------------------------------------------
 123    Result-checking malloc wrappers.
 124    -------------------------------------------------------------------------- */
 125
 126 void *
 127 stgMallocBytes (int n, char *msg)
 128 {
 129     char *space;
 130
 131     if ((space = (char *) malloc((size_t) n)) == NULL) {
 132       /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 133       MallocFailHook((W_) n, msg); /*msg*/
 134       stg_exit(EXIT_INTERNAL_ERROR);
 135     }
 136     return space;
 137 }
 138
 139 void *
 140 stgReallocBytes (void *p, int n, char *msg)
 141 {
 142     char *space;
 143
 144     if ((space = (char *) realloc(p, (size_t) n)) == NULL) {
 145       /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 146       MallocFailHook((W_) n, msg); /*msg*/
 147       stg_exit(EXIT_INTERNAL_ERROR);
 148     }
 149     return space;
 150 }
 151
 152 void *
 153 stgCallocBytes (int n, int m, char *msg)
 154 {
 155   int   i;
 156   int   sz = n * m;
 157   char* p  = stgMallocBytes(sz, msg);
 158   for (i = 0; i < sz; i++) p[i] = 0;
 159   return p;
 160 }
 161
 162 /* To simplify changing the underlying allocator used
 163  * by stgMallocBytes(), provide stgFree() as well.
 164  */
 165 void
 166 stgFree(void* p)
 167 {
 168   free(p);
 169 }
 170
 171 void
 172 _stgAssert (char *filename, unsigned int linenum)
 173 {
 174   fflush(stdout);
 175   fprintf(stderr, "ASSERTION FAILED: file %s, line %u\n", filename, linenum);
 176   fflush(stderr);
 177   abort();
 178 }
 179
 180 /* -----------------------------------------------------------------------------
 181    Stack overflow
 182
 183    Not sure if this belongs here.
 184    -------------------------------------------------------------------------- */
 185
 186 void
 187 stackOverflow(void)
 188 {
 189   StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
 190
 191 #if defined(TICKY_TICKY)
 192   if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 193 #endif
 194 }
 195
 196 void
 197 heapOverflow(void)
 198 {
 199   /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 200   OutOfHeapHook(0/*unknown request size*/,
 201                 RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
 202
 203 #if defined(TICKY_TICKY)
 204   if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 205 #endif
 206
 207   stg_exit(EXIT_HEAPOVERFLOW);
 208 }
 209
 210 /* -----------------------------------------------------------------------------
 211    Out-of-line strlen.
 212
 213    Used in addr2Integer because the C compiler on x86 chokes on
 214    strlen, trying to inline it with not enough registers available.
 215    -------------------------------------------------------------------------- */
 216
 217 nat stg_strlen(char *s)
 218 {
 219    char *p = s;
 220
 221    while (*p) p++;
 222    return p-s;
 223 }
 224
 225
 226 /* -----------------------------------------------------------------------------
 227    genSym stuff, used by GHC itself for its splitting unique supply.
 228
 229    ToDo: put this somewhere sensible.
 230    -------------------------------------------------------------------------  */
 231
 232 static I_ __GenSymCounter = 0;
 233
 234 I_
 235 genSymZh(void)
 236 {
 237     return(__GenSymCounter++);
 238 }
 239 I_
 240 resetGenSymZh(void) /* it's your funeral */
 241 {
 242     __GenSymCounter=0;
 243     return(__GenSymCounter);
 244 }
 245
 246 /* -----------------------------------------------------------------------------
 247    Get the current time as a string.  Used in profiling reports.
 248    -------------------------------------------------------------------------- */
 249
 250 #if defined(PROFILING) || defined(DEBUG) || defined(PAR) || defined(GRAN)
 251 char *
 252 time_str(void)
 253 {
 254     static time_t now = 0;
 255     static char nowstr[26];
 256
 257     if (now == 0) {
 258         time(&now);
 259         strcpy(nowstr, ctime(&now));
 260         strcpy(nowstr+16,nowstr+19);
 261         nowstr[21] = '\0';
 262     }
 263     return nowstr;
 264 }
 265 #endif
 266
 267 /* -----------------------------------------------------------------------------
 268  * Reset a file handle to blocking mode.  We do this for the standard
 269  * file descriptors before exiting, because the shell doesn't always
 270  * clean up for us.
 271  * -------------------------------------------------------------------------- */
 272
 273 #if !defined(mingw32_TARGET_OS)
 274 void
 275 resetNonBlockingFd(int fd)
 276 {
 277   long fd_flags;
 278
 279   /* clear the non-blocking flag on this file descriptor */
 280   fd_flags = fcntl(fd, F_GETFL);
 281   if (fd_flags & O_NONBLOCK) {
 282     fcntl(fd, F_SETFL, fd_flags & ~O_NONBLOCK);
 283   }
 284 }
 285
 286 void
 287 setNonBlockingFd(int fd)
 288 {
 289   long fd_flags;
 290
 291   /* clear the non-blocking flag on this file descriptor */
 292   fd_flags = fcntl(fd, F_GETFL);
 293   if (!(fd_flags & O_NONBLOCK)) {
 294     fcntl(fd, F_SETFL, fd_flags | O_NONBLOCK);
 295   }
 296 }
 297 #else
 298 /* Stub defns -- async / non-blocking IO is not done
 299  * via O_NONBLOCK and select() under Win32.
 300  */
 301 void resetNonBlockingFd(int fd STG_UNUSED) {}
 302 void setNonBlockingFd(int fd STG_UNUSED) {}
 303 #endif
 304
 305 #ifdef PAR
 306 static ullong startTime = 0;
 307
 308 /* used in a parallel setup */
 309 ullong
 310 msTime(void)
 311 {
 312 # if defined(HAVE_GETCLOCK) && !defined(alpha_TARGET_ARCH) && !defined(hppa1_1_TARGET_ARCH)
 313     struct timespec tv;
 314
 315     if (getclock(TIMEOFDAY, &tv) != 0) {
 316         fflush(stdout);
 317         fprintf(stderr, "Clock failed\n");
 318         stg_exit(EXIT_FAILURE);
 319     }
 320     return tv.tv_sec * LL(1000) + tv.tv_nsec / LL(1000000) - startTime;
 321 # elif HAVE_GETTIMEOFDAY && !defined(alpha_TARGET_ARCH)
 322     struct timeval tv;
 323
 324     if (gettimeofday(&tv, NULL) != 0) {
 325         fflush(stdout);
 326         fprintf(stderr, "Clock failed\n");
 327         stg_exit(EXIT_FAILURE);
 328     }
 329     return tv.tv_sec * LL(1000) + tv.tv_usec / LL(1000) - startTime;
 330 # else
 331     time_t t;
 332     if ((t = time(NULL)) == (time_t) -1) {
 333         fflush(stdout);
 334         fprintf(stderr, "Clock failed\n");
 335         stg_exit(EXIT_FAILURE);
 336     }
 337     return t * LL(1000) - startTime;
 338 # endif
 339 }
 340 #endif /* PAR */
 341
 342 /* -----------------------------------------------------------------------------
 343    Print large numbers, with punctuation.
 344    -------------------------------------------------------------------------- */
 345
 346 char *
 347 ullong_format_string(ullong x, char *s, rtsBool with_commas)
 348 {
 349     if (x < (ullong)1000)
 350         sprintf(s, "%lu", (lnat)x);
 351     else if (x < (ullong)1000000)
 352         sprintf(s, (with_commas) ? "%lu,%3.3lu" : "%lu%3.3lu",
 353                 (lnat)((x)/(ullong)1000),
 354                 (lnat)((x)%(ullong)1000));
 355     else if (x < (ullong)1000000000)
 356         sprintf(s, (with_commas) ? "%lu,%3.3lu,%3.3lu" :  "%lu%3.3lu%3.3lu",
 357                 (lnat)((x)/(ullong)1000000),
 358                 (lnat)((x)/(ullong)1000%(ullong)1000),
 359                 (lnat)((x)%(ullong)1000));
 360     else
 361         sprintf(s, (with_commas) ? "%lu,%3.3lu,%3.3lu,%3.3lu" : "%lu%3.3lu%3.3lu%3.3lu",
 362                 (lnat)((x)/(ullong)1000000000),
 363                 (lnat)((x)/(ullong)1000000%(ullong)1000),
 364                 (lnat)((x)/(ullong)1000%(ullong)1000),
 365                 (lnat)((x)%(ullong)1000));
 366     return s;
 367 }
 368
 369
 370 // Can be used as a breakpoint to set on every heap check failure.
 371 #ifdef DEBUG
 372 void
 373 heapCheckFail( void )
 374 {
 375 }
 376 #endif
 377