ghc/rts/RtsUtils.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: RtsUtils.c,v 1.8 1999/03/17 13:19:23 simonm Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * General utility functions used in the RTS.
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11 #include "RtsAPI.h"
  12 #include "RtsFlags.h"
  13 #include "Hooks.h"
  14 #include "Main.h"
  15 #include "RtsUtils.h"
  16 #include "Ticky.h"
  17
  18 #ifdef HAVE_TIME_H
  19 #include <time.h>
  20 #endif
  21
  22 #include <stdarg.h>
  23
  24 /* variable-argument error function. */
  25
  26 void barf(char *s, ...)
  27 {
  28   va_list ap;
  29   va_start(ap,s);
  30   fflush(stdout);
  31   if (prog_argv != NULL && prog_argv[0] != NULL) {
  32     fprintf(stderr, "%s: fatal error: ", prog_argv[0]);
  33   } else {
  34     fprintf(stderr, "fatal error: ");
  35   }
  36   vfprintf(stderr, s, ap);
  37   fprintf(stderr, "\n");
  38   fflush(stderr);
  39   stg_exit(EXIT_FAILURE);
  40 }
  41
  42 void belch(char *s, ...)
  43 {
  44   va_list ap;
  45   va_start(ap,s);
  46   fflush(stdout);
  47   vfprintf(stderr, s, ap);
  48   fprintf(stderr, "\n");
  49 }
  50
  51 /* result-checking malloc wrappers. */
  52
  53 void *
  54 stgMallocBytes (int n, char *msg)
  55 {
  56     char *space;
  57
  58     if ((space = (char *) malloc((size_t) n)) == NULL) {
  59         fflush(stdout);
  60         MallocFailHook((W_) n, msg); /*msg*/
  61         stg_exit(EXIT_FAILURE);
  62     }
  63     return space;
  64 }
  65
  66 void *
  67 stgReallocBytes (void *p, int n, char *msg)
  68 {
  69     char *space;
  70
  71     if ((space = (char *) realloc(p, (size_t) n)) == NULL) {
  72         fflush(stdout);
  73         MallocFailHook((W_) n, msg); /*msg*/
  74         exit(EXIT_FAILURE);
  75     }
  76     return space;
  77 }
  78
  79 void *
  80 stgMallocWords (int n, char *msg)
  81 {
  82   return(stgMallocBytes(n * sizeof(W_), msg));
  83 }
  84
  85 void *
  86 stgReallocWords (void *p, int n, char *msg)
  87 {
  88   return(stgReallocBytes(p, n * sizeof(W_), msg));
  89 }
  90
  91 void
  92 _stgAssert (char *filename, nat linenum)
  93 {
  94   fflush(stdout);
  95   fprintf(stderr, "ASSERTION FAILED: file %s, line %u\n", filename, linenum);
  96   abort();
  97 }
  98
  99 StgStablePtr errorHandler = -1; /* -1 indicates no handler installed */
 100
 101 void
 102 raiseError( StgStablePtr handler STG_UNUSED )
 103 {
 104   shutdownHaskell();
 105   stg_exit(EXIT_FAILURE);
 106 }
 107
 108 /* -----------------------------------------------------------------------------
 109    Stack overflow
 110
 111    Not sure if this belongs here.
 112    -------------------------------------------------------------------------- */
 113
 114 void
 115 stackOverflow(void)
 116 {
 117     StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
 118
 119 #if defined(TICKY_TICKY)
 120     if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 121 #endif
 122 }
 123
 124 void
 125 heapOverflow(void)
 126 {
 127     fflush(stdout);
 128     OutOfHeapHook(0/*unknown request size*/,
 129                   RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
 130
 131 #if defined(TICKY_TICKY)
 132     if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 133 #endif
 134
 135     stg_exit(EXIT_FAILURE);
 136 }
 137
 138 /* -----------------------------------------------------------------------------
 139    Out-of-line strlen.
 140
 141    Used in addr2Integer because the C compiler on x86 chokes on
 142    strlen, trying to inline it with not enough registers available.
 143    -------------------------------------------------------------------------- */
 144
 145 nat stg_strlen(char *s)
 146 {
 147    char *p = s;
 148
 149    while (*p) p++;
 150    return p-s;
 151 }
 152
 153
 154 /* -----------------------------------------------------------------------------
 155    genSym stuff, used by GHC itself for its splitting unique supply.
 156
 157    ToDo: put this somewhere sensible.
 158    -------------------------------------------------------------------------  */
 159
 160 I_ __GenSymCounter = 0;
 161
 162 I_
 163 genSymZh(void)
 164 {
 165     return(__GenSymCounter++);
 166 }
 167 I_
 168 resetGenSymZh(void) /* it's your funeral */
 169 {
 170     __GenSymCounter=0;
 171     return(__GenSymCounter);
 172 }
 173
 174 /* -----------------------------------------------------------------------------
 175    Get the current time as a string.  Used in profiling reports.
 176    -------------------------------------------------------------------------- */
 177
 178 #if defined(PROFILING) || defined(DEBUG)
 179 char *
 180 time_str(void)
 181 {
 182     static time_t now = 0;
 183     static char nowstr[26];
 184
 185     if (now == 0) {
 186         time(&now);
 187         strcpy(nowstr, ctime(&now));
 188         strcpy(nowstr+16,nowstr+19);
 189         nowstr[21] = '\0';
 190     }
 191     return nowstr;
 192 }
 193 #endif
 194
 195 /* -----------------------------------------------------------------------------
 196    Print large numbers, with punctuation.
 197    -------------------------------------------------------------------------- */
 198
 199 char *
 200 ullong_format_string(ullong x, char *s, rtsBool with_commas)
 201 {
 202     if (x < (ullong)1000)
 203         sprintf(s, "%d", (nat)x);
 204     else if (x < (ullong)1000000)
 205         sprintf(s, (with_commas) ? "%ld,%3.3ld" : "%ld%3.3ld",
 206                 (nat)((x)/(ullong)1000),
 207                 (nat)((x)%(ullong)1000));
 208     else if (x < (ullong)1000000000)
 209         sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld" :  "%ld%3.3ld%3.3ld",
 210                 (nat)((x)/(ullong)1000000),
 211                 (nat)((x)/(ullong)1000%(ullong)1000),
 212                 (nat)((x)%(ullong)1000));
 213     else
 214         sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld,%3.3ld" : "%ld%3.3ld%3.3ld%3.3ld",
 215                 (nat)((x)/(ullong)1000000000),
 216                 (nat)((x)/(ullong)1000000%(ullong)1000),
 217                 (nat)((x)/(ullong)1000%(ullong)1000),
 218                 (nat)((x)%(ullong)1000));
 219     return s;
 220 }