ghc/rts/RtsUtils.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: RtsUtils.c,v 1.3 1999/01/21 10:31:49 simonm Exp $
   3  *
   4  * General utility functions used in the RTS.
   5  *
   6  * ---------------------------------------------------------------------------*/
   7
   8 #include "Rts.h"
   9 #include "RtsAPI.h"
  10 #include "RtsFlags.h"
  11 #include "Hooks.h"
  12 #include "Main.h"
  13 #include "RtsUtils.h"
  14 #include "Ticky.h"
  15
  16 #ifdef HAVE_TIME_H
  17 #include <time.h>
  18 #endif
  19
  20 #include <stdarg.h>
  21
  22 /* variable-argument error function. */
  23
  24 void barf(char *s, ...)
  25 {
  26   va_list ap;
  27   va_start(ap,s);
  28   fflush(stdout);
  29   if (prog_argv != NULL && prog_argv[0] != NULL) {
  30     fprintf(stderr, "%s: fatal error: ", prog_argv[0]);
  31   } else {
  32     fprintf(stderr, "fatal error: ");
  33   }
  34   vfprintf(stderr, s, ap);
  35   fprintf(stderr, "\n");
  36   stg_exit(EXIT_FAILURE);
  37 }
  38
  39 void belch(char *s, ...)
  40 {
  41   va_list ap;
  42   va_start(ap,s);
  43   fflush(stdout);
  44   vfprintf(stderr, s, ap);
  45   fprintf(stderr, "\n");
  46 }
  47
  48 /* result-checking malloc wrappers. */
  49
  50 void *
  51 stgMallocBytes (int n, char *msg)
  52 {
  53     char *space;
  54
  55     if ((space = (char *) malloc((size_t) n)) == NULL) {
  56         fflush(stdout);
  57         MallocFailHook((W_) n, msg); /*msg*/
  58         stg_exit(EXIT_FAILURE);
  59     }
  60     return space;
  61 }
  62
  63 void *
  64 stgReallocBytes (void *p, int n, char *msg)
  65 {
  66     char *space;
  67
  68     if ((space = (char *) realloc(p, (size_t) n)) == NULL) {
  69         fflush(stdout);
  70         MallocFailHook((W_) n, msg); /*msg*/
  71         exit(EXIT_FAILURE);
  72     }
  73     return space;
  74 }
  75
  76 void *
  77 stgMallocWords (int n, char *msg)
  78 {
  79   return(stgMallocBytes(n * sizeof(W_), msg));
  80 }
  81
  82 void *
  83 stgReallocWords (void *p, int n, char *msg)
  84 {
  85   return(stgReallocBytes(p, n * sizeof(W_), msg));
  86 }
  87
  88 void
  89 _stgAssert (char *filename, nat linenum)
  90 {
  91   fflush(stdout);
  92   fprintf(stderr, "ASSERTION FAILED: file %s, line %u\n", filename, linenum);
  93   abort();
  94 }
  95
  96 StgStablePtr errorHandler = -1; /* -1 indicates no handler installed */
  97
  98 void
  99 raiseError( StgStablePtr handler STG_UNUSED )
 100 {
 101   shutdownHaskell();
 102   stg_exit(EXIT_FAILURE);
 103 }
 104
 105 /* -----------------------------------------------------------------------------
 106    Stack overflow
 107
 108    Not sure if this belongs here.
 109    -------------------------------------------------------------------------- */
 110
 111 void
 112 stackOverflow(nat max_stack_size)
 113 {
 114     fflush(stdout);
 115     StackOverflowHook(max_stack_size * sizeof(W_)); /*msg*/
 116
 117 #if defined(TICKY_TICKY)
 118     if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 119 #endif
 120
 121     stg_exit(EXIT_FAILURE);
 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 }