ghc/rts/RtsUtils.c

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