ghc/rts/RtsUtils.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: RtsUtils.c,v 1.7 1999/03/02 20:05:41 sof 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(nat max_stack_size)
 116 {
 117     fflush(stdout);
 118     StackOverflowHook(max_stack_size * sizeof(W_)); /*msg*/
 119
 120 #if defined(TICKY_TICKY)
 121     if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 122 #endif
 123
 124     stg_exit(EXIT_FAILURE);
 125 }
 126
 127 void
 128 heapOverflow(void)
 129 {
 130     fflush(stdout);
 131     OutOfHeapHook(0/*unknown request size*/,
 132                   RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
 133
 134 #if defined(TICKY_TICKY)
 135     if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 136 #endif
 137
 138     stg_exit(EXIT_FAILURE);
 139 }
 140
 141 /* -----------------------------------------------------------------------------
 142    Out-of-line strlen.
 143
 144    Used in addr2Integer because the C compiler on x86 chokes on
 145    strlen, trying to inline it with not enough registers available.
 146    -------------------------------------------------------------------------- */
 147
 148 nat stg_strlen(char *s)
 149 {
 150    char *p = s;
 151
 152    while (*p) p++;
 153    return p-s;
 154 }
 155
 156
 157 /* -----------------------------------------------------------------------------
 158    genSym stuff, used by GHC itself for its splitting unique supply.
 159
 160    ToDo: put this somewhere sensible.
 161    -------------------------------------------------------------------------  */
 162
 163 I_ __GenSymCounter = 0;
 164
 165 I_
 166 genSymZh(void)
 167 {
 168     return(__GenSymCounter++);
 169 }
 170 I_
 171 resetGenSymZh(void) /* it's your funeral */
 172 {
 173     __GenSymCounter=0;
 174     return(__GenSymCounter);
 175 }
 176
 177 /* -----------------------------------------------------------------------------
 178    Get the current time as a string.  Used in profiling reports.
 179    -------------------------------------------------------------------------- */
 180
 181 #if defined(PROFILING) || defined(DEBUG)
 182 char *
 183 time_str(void)
 184 {
 185     static time_t now = 0;
 186     static char nowstr[26];
 187
 188     if (now == 0) {
 189         time(&now);
 190         strcpy(nowstr, ctime(&now));
 191         strcpy(nowstr+16,nowstr+19);
 192         nowstr[21] = '\0';
 193     }
 194     return nowstr;
 195 }
 196 #endif
 197
 198 /* -----------------------------------------------------------------------------
 199    Print large numbers, with punctuation.
 200    -------------------------------------------------------------------------- */
 201
 202 char *
 203 ullong_format_string(ullong x, char *s, rtsBool with_commas)
 204 {
 205     if (x < (ullong)1000)
 206         sprintf(s, "%d", (nat)x);
 207     else if (x < (ullong)1000000)
 208         sprintf(s, (with_commas) ? "%ld,%3.3ld" : "%ld%3.3ld",
 209                 (nat)((x)/(ullong)1000),
 210                 (nat)((x)%(ullong)1000));
 211     else if (x < (ullong)1000000000)
 212         sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld" :  "%ld%3.3ld%3.3ld",
 213                 (nat)((x)/(ullong)1000000),
 214                 (nat)((x)/(ullong)1000%(ullong)1000),
 215                 (nat)((x)%(ullong)1000));
 216     else
 217         sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld,%3.3ld" : "%ld%3.3ld%3.3ld%3.3ld",
 218                 (nat)((x)/(ullong)1000000000),
 219                 (nat)((x)/(ullong)1000000%(ullong)1000),
 220                 (nat)((x)/(ullong)1000%(ullong)1000),
 221                 (nat)((x)%(ullong)1000));
 222     return s;
 223 }