ghc/rts/RtsUtils.c

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