ghc/rts/RtsUtils.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: RtsUtils.c,v 1.32 2003/03/25 17:58:49 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 /* To simplify changing the underlying allocator used
 134  * by stgMallocBytes(), provide stgFree() as well.
 135  */
 136 void
 137 stgFree(void* p)
 138 {
 139   free(p);
 140 }
 141
 142 void
 143 _stgAssert (char *filename, unsigned int linenum)
 144 {
 145   fflush(stdout);
 146   fprintf(stderr, "ASSERTION FAILED: file %s, line %u\n", filename, linenum);
 147   fflush(stderr);
 148   abort();
 149 }
 150
 151 /* -----------------------------------------------------------------------------
 152    Stack overflow
 153
 154    Not sure if this belongs here.
 155    -------------------------------------------------------------------------- */
 156
 157 void
 158 stackOverflow(void)
 159 {
 160   StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
 161
 162 #if defined(TICKY_TICKY)
 163   if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 164 #endif
 165 }
 166
 167 void
 168 heapOverflow(void)
 169 {
 170   /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 171   OutOfHeapHook(0/*unknown request size*/,
 172                 RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
 173
 174 #if defined(TICKY_TICKY)
 175   if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 176 #endif
 177
 178   stg_exit(EXIT_HEAPOVERFLOW);
 179 }
 180
 181 /* -----------------------------------------------------------------------------
 182    Out-of-line strlen.
 183
 184    Used in addr2Integer because the C compiler on x86 chokes on
 185    strlen, trying to inline it with not enough registers available.
 186    -------------------------------------------------------------------------- */
 187
 188 nat stg_strlen(char *s)
 189 {
 190    char *p = s;
 191
 192    while (*p) p++;
 193    return p-s;
 194 }
 195
 196
 197 /* -----------------------------------------------------------------------------
 198    genSym stuff, used by GHC itself for its splitting unique supply.
 199
 200    ToDo: put this somewhere sensible.
 201    -------------------------------------------------------------------------  */
 202
 203 static I_ __GenSymCounter = 0;
 204
 205 I_
 206 genSymZh(void)
 207 {
 208     return(__GenSymCounter++);
 209 }
 210 I_
 211 resetGenSymZh(void) /* it's your funeral */
 212 {
 213     __GenSymCounter=0;
 214     return(__GenSymCounter);
 215 }
 216
 217 /* -----------------------------------------------------------------------------
 218    Get the current time as a string.  Used in profiling reports.
 219    -------------------------------------------------------------------------- */
 220
 221 #if defined(PROFILING) || defined(DEBUG) || defined(PAR) || defined(GRAN)
 222 char *
 223 time_str(void)
 224 {
 225     static time_t now = 0;
 226     static char nowstr[26];
 227
 228     if (now == 0) {
 229         time(&now);
 230         strcpy(nowstr, ctime(&now));
 231         strcpy(nowstr+16,nowstr+19);
 232         nowstr[21] = '\0';
 233     }
 234     return nowstr;
 235 }
 236 #endif
 237
 238 /* -----------------------------------------------------------------------------
 239  * Reset a file handle to blocking mode.  We do this for the standard
 240  * file descriptors before exiting, because the shell doesn't always
 241  * clean up for us.
 242  * -------------------------------------------------------------------------- */
 243
 244 #if !defined(mingw32_TARGET_OS)
 245 void
 246 resetNonBlockingFd(int fd)
 247 {
 248   long fd_flags;
 249
 250   /* clear the non-blocking flag on this file descriptor */
 251   fd_flags = fcntl(fd, F_GETFL);
 252   if (fd_flags & O_NONBLOCK) {
 253     fcntl(fd, F_SETFL, fd_flags & ~O_NONBLOCK);
 254   }
 255 }
 256
 257 void
 258 setNonBlockingFd(int fd)
 259 {
 260   long fd_flags;
 261
 262   /* clear the non-blocking flag on this file descriptor */
 263   fd_flags = fcntl(fd, F_GETFL);
 264   fcntl(fd, F_SETFL, fd_flags | O_NONBLOCK);
 265 }
 266 #else
 267 /* Don't support non-blocking FDs (yet) on mingw */
 268 void resetNonBlockingFd(int fd STG_UNUSED) {}
 269 void setNonBlockingFd(int fd STG_UNUSED) {}
 270 #endif
 271
 272 #ifdef PAR
 273 static ullong startTime = 0;
 274
 275 /* used in a parallel setup */
 276 ullong
 277 msTime(void)
 278 {
 279 # if defined(HAVE_GETCLOCK) && !defined(alpha_TARGET_ARCH) && !defined(hppa1_1_TARGET_ARCH)
 280     struct timespec tv;
 281
 282     if (getclock(TIMEOFDAY, &tv) != 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_nsec / LL(1000000) - startTime;
 288 # elif HAVE_GETTIMEOFDAY && !defined(alpha_TARGET_ARCH)
 289     struct timeval tv;
 290
 291     if (gettimeofday(&tv, NULL) != 0) {
 292         fflush(stdout);
 293         fprintf(stderr, "Clock failed\n");
 294         stg_exit(EXIT_FAILURE);
 295     }
 296     return tv.tv_sec * LL(1000) + tv.tv_usec / LL(1000) - startTime;
 297 # else
 298     time_t t;
 299     if ((t = time(NULL)) == (time_t) -1) {
 300         fflush(stdout);
 301         fprintf(stderr, "Clock failed\n");
 302         stg_exit(EXIT_FAILURE);
 303     }
 304     return t * LL(1000) - startTime;
 305 # endif
 306 }
 307 #endif /* PAR */
 308
 309 /* -----------------------------------------------------------------------------
 310    Print large numbers, with punctuation.
 311    -------------------------------------------------------------------------- */
 312
 313 char *
 314 ullong_format_string(ullong x, char *s, rtsBool with_commas)
 315 {
 316     if (x < (ullong)1000)
 317         sprintf(s, "%lu", (lnat)x);
 318     else if (x < (ullong)1000000)
 319         sprintf(s, (with_commas) ? "%lu,%3.3lu" : "%lu%3.3lu",
 320                 (lnat)((x)/(ullong)1000),
 321                 (lnat)((x)%(ullong)1000));
 322     else if (x < (ullong)1000000000)
 323         sprintf(s, (with_commas) ? "%lu,%3.3lu,%3.3lu" :  "%lu%3.3lu%3.3lu",
 324                 (lnat)((x)/(ullong)1000000),
 325                 (lnat)((x)/(ullong)1000%(ullong)1000),
 326                 (lnat)((x)%(ullong)1000));
 327     else
 328         sprintf(s, (with_commas) ? "%lu,%3.3lu,%3.3lu,%3.3lu" : "%lu%3.3lu%3.3lu%3.3lu",
 329                 (lnat)((x)/(ullong)1000000000),
 330                 (lnat)((x)/(ullong)1000000%(ullong)1000),
 331                 (lnat)((x)/(ullong)1000%(ullong)1000),
 332                 (lnat)((x)%(ullong)1000));
 333     return s;
 334 }
 335
 336
 337 // Can be used as a breakpoint to set on every heap check failure.
 338 #ifdef DEBUG
 339 void
 340 heapCheckFail( void )
 341 {
 342 }
 343 #endif
 344