ghc/rts/RtsUtils.c

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