ghc/rts/RtsUtils.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: RtsUtils.c,v 1.9 1999/08/25 16:11:51 simonmar 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   /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
  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   /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
  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       /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
  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       /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
  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   /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
  95   fprintf(stderr, "ASSERTION FAILED: file %s, line %u\n", filename, linenum);
  96   abort();
  97 }
  98
  99 /* -----------------------------------------------------------------------------
 100    Stack overflow
 101
 102    Not sure if this belongs here.
 103    -------------------------------------------------------------------------- */
 104
 105 void
 106 stackOverflow(void)
 107 {
 108   StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
 109
 110 #if defined(TICKY_TICKY)
 111   if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 112 #endif
 113 }
 114
 115 void
 116 heapOverflow(void)
 117 {
 118   /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
 119   OutOfHeapHook(0/*unknown request size*/,
 120                 RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
 121
 122 #if defined(TICKY_TICKY)
 123   if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 124 #endif
 125
 126   stg_exit(EXIT_FAILURE);
 127 }
 128
 129 /* -----------------------------------------------------------------------------
 130    Out-of-line strlen.
 131
 132    Used in addr2Integer because the C compiler on x86 chokes on
 133    strlen, trying to inline it with not enough registers available.
 134    -------------------------------------------------------------------------- */
 135
 136 nat stg_strlen(char *s)
 137 {
 138    char *p = s;
 139
 140    while (*p) p++;
 141    return p-s;
 142 }
 143
 144
 145 /* -----------------------------------------------------------------------------
 146    genSym stuff, used by GHC itself for its splitting unique supply.
 147
 148    ToDo: put this somewhere sensible.
 149    -------------------------------------------------------------------------  */
 150
 151 I_ __GenSymCounter = 0;
 152
 153 I_
 154 genSymZh(void)
 155 {
 156     return(__GenSymCounter++);
 157 }
 158 I_
 159 resetGenSymZh(void) /* it's your funeral */
 160 {
 161     __GenSymCounter=0;
 162     return(__GenSymCounter);
 163 }
 164
 165 /* -----------------------------------------------------------------------------
 166    Get the current time as a string.  Used in profiling reports.
 167    -------------------------------------------------------------------------- */
 168
 169 #if defined(PROFILING) || defined(DEBUG)
 170 char *
 171 time_str(void)
 172 {
 173     static time_t now = 0;
 174     static char nowstr[26];
 175
 176     if (now == 0) {
 177         time(&now);
 178         strcpy(nowstr, ctime(&now));
 179         strcpy(nowstr+16,nowstr+19);
 180         nowstr[21] = '\0';
 181     }
 182     return nowstr;
 183 }
 184 #endif
 185
 186 /* -----------------------------------------------------------------------------
 187    Print large numbers, with punctuation.
 188    -------------------------------------------------------------------------- */
 189
 190 char *
 191 ullong_format_string(ullong x, char *s, rtsBool with_commas)
 192 {
 193     if (x < (ullong)1000)
 194         sprintf(s, "%d", (nat)x);
 195     else if (x < (ullong)1000000)
 196         sprintf(s, (with_commas) ? "%ld,%3.3ld" : "%ld%3.3ld",
 197                 (nat)((x)/(ullong)1000),
 198                 (nat)((x)%(ullong)1000));
 199     else if (x < (ullong)1000000000)
 200         sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld" :  "%ld%3.3ld%3.3ld",
 201                 (nat)((x)/(ullong)1000000),
 202                 (nat)((x)/(ullong)1000%(ullong)1000),
 203                 (nat)((x)%(ullong)1000));
 204     else
 205         sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld,%3.3ld" : "%ld%3.3ld%3.3ld%3.3ld",
 206                 (nat)((x)/(ullong)1000000000),
 207                 (nat)((x)/(ullong)1000000%(ullong)1000),
 208                 (nat)((x)/(ullong)1000%(ullong)1000),
 209                 (nat)((x)%(ullong)1000));
 210     return s;
 211 }