/* ----------------------------------------------------------------------------- * * (c) The GHC Team, 1998-2004 * * General utility functions used in the RTS. * * ---------------------------------------------------------------------------*/ #include "PosixSource.h" #include "Rts.h" #include "RtsAPI.h" #include "RtsUtils.h" #include "Ticky.h" #include "Schedule.h" #ifdef HAVE_TIME_H #include #endif /* HACK: On Mac OS X 10.4 (at least), time.h doesn't declare ctime_r with * _POSIX_C_SOURCE. If this is the case, we declare it ourselves. */ #if HAVE_CTIME_R && !HAVE_DECL_CTIME_R extern char *ctime_r(const time_t *, char *); #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_GETTIMEOFDAY #include #endif #include #include #include #include #ifdef HAVE_SIGNAL_H #include #endif #if defined(THREADED_RTS) && defined(openbsd_HOST_OS) && defined(HAVE_PTHREAD_H) #include #endif #if defined(_WIN32) #include #endif /* ----------------------------------------------------------------------------- Result-checking malloc wrappers. -------------------------------------------------------------------------- */ void * stgMallocBytes (int n, char *msg) { char *space; size_t n2; n2 = (size_t) n; if ((space = (char *) malloc(n2)) == NULL) { /* don't fflush(stdout); WORKAROUND bug in Linux glibc */ MallocFailHook((W_) n, msg); /*msg*/ stg_exit(EXIT_INTERNAL_ERROR); } return space; } void * stgReallocBytes (void *p, int n, char *msg) { char *space; size_t n2; n2 = (size_t) n; if ((space = (char *) realloc(p, (size_t) n2)) == NULL) { /* don't fflush(stdout); WORKAROUND bug in Linux glibc */ MallocFailHook((W_) n, msg); /*msg*/ stg_exit(EXIT_INTERNAL_ERROR); } return space; } void * stgCallocBytes (int n, int m, char *msg) { char *space; if ((space = (char *) calloc((size_t) n, (size_t) m)) == NULL) { /* don't fflush(stdout); WORKAROUND bug in Linux glibc */ MallocFailHook((W_) n*m, msg); /*msg*/ stg_exit(EXIT_INTERNAL_ERROR); } return space; } /* To simplify changing the underlying allocator used * by stgMallocBytes(), provide stgFree() as well. */ void stgFree(void* p) { free(p); } /* ----------------------------------------------------------------------------- Stack overflow Not sure if this belongs here. -------------------------------------------------------------------------- */ void stackOverflow(void) { StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_)); #if defined(TICKY_TICKY) if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo(); #endif } void heapOverflow(void) { if (!heap_overflow) { /* don't fflush(stdout); WORKAROUND bug in Linux glibc */ OutOfHeapHook(0/*unknown request size*/, RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE); heap_overflow = rtsTrue; } } /* ----------------------------------------------------------------------------- genSym stuff, used by GHC itself for its splitting unique supply. ToDo: put this somewhere sensible. ------------------------------------------------------------------------- */ static HsInt __GenSymCounter = 0; HsInt genSymZh(void) { return(__GenSymCounter++); } HsInt resetGenSymZh(void) /* it's your funeral */ { __GenSymCounter=0; return(__GenSymCounter); } /* ----------------------------------------------------------------------------- Get the current time as a string. Used in profiling reports. -------------------------------------------------------------------------- */ char * time_str(void) { static time_t now = 0; static char nowstr[26]; if (now == 0) { time(&now); #if HAVE_CTIME_R ctime_r(&now, nowstr); #else strcpy(nowstr, ctime(&now)); #endif memmove(nowstr+16,nowstr+19,7); nowstr[21] = '\0'; // removes the \n } return nowstr; } /* ----------------------------------------------------------------------------- Print large numbers, with punctuation. -------------------------------------------------------------------------- */ char * showStgWord64(StgWord64 x, char *s, rtsBool with_commas) { if (with_commas) { if (x < (StgWord64)1e3) sprintf(s, "%" FMT_Word64, (StgWord64)x); else if (x < (StgWord64)1e6) sprintf(s, "%" FMT_Word64 ",%03" FMT_Word64, (StgWord64)(x / 1000), (StgWord64)(x % 1000)); else if (x < (StgWord64)1e9) sprintf(s, "%" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64, (StgWord64)(x / 1e6), (StgWord64)((x / 1000) % 1000), (StgWord64)(x % 1000)); else if (x < (StgWord64)1e12) sprintf(s, "%" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64, (StgWord64)(x / (StgWord64)1e9), (StgWord64)((x / (StgWord64)1e6) % 1000), (StgWord64)((x / (StgWord64)1e3) % 1000), (StgWord64)(x % 1000)); else if (x < (StgWord64)1e15) sprintf(s, "%" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64, (StgWord64)(x / (StgWord64)1e12), (StgWord64)((x / (StgWord64)1e9) % 1000), (StgWord64)((x / (StgWord64)1e6) % 1000), (StgWord64)((x / (StgWord64)1e3) % 1000), (StgWord64)(x % 1000)); else if (x < (StgWord64)1e18) sprintf(s, "%" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64, (StgWord64)(x / (StgWord64)1e15), (StgWord64)((x / (StgWord64)1e12) % 1000), (StgWord64)((x / (StgWord64)1e9) % 1000), (StgWord64)((x / (StgWord64)1e6) % 1000), (StgWord64)((x / (StgWord64)1e3) % 1000), (StgWord64)(x % 1000)); else sprintf(s, "%" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64 ",%03" FMT_Word64, (StgWord64)(x / (StgWord64)1e18), (StgWord64)((x / (StgWord64)1e15) % 1000), (StgWord64)((x / (StgWord64)1e12) % 1000), (StgWord64)((x / (StgWord64)1e9) % 1000), (StgWord64)((x / (StgWord64)1e6) % 1000), (StgWord64)((x / (StgWord64)1e3) % 1000), (StgWord64)(x % 1000)); } else { sprintf(s, "%" FMT_Word64, x); } return s; } // Can be used as a breakpoint to set on every heap check failure. #ifdef DEBUG void heapCheckFail( void ) { } #endif /* * It seems that pthreads and signals interact oddly in OpenBSD & FreeBSD * pthreads (and possibly others). When linking with -lpthreads, we * have to use pthread_kill to send blockable signals. So use that * when we have a threaded rts. So System.Posix.Signals will call * genericRaise(), rather than raise(3). */ int genericRaise(int sig) { #if defined(THREADED_RTS) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS)) return pthread_kill(pthread_self(), sig); #else return raise(sig); #endif } static void mkRtsInfoPair(char *key, char *val) { /* XXX should check for "s, \s etc in key and val */ printf(" ,(\"%s\", \"%s\")\n", key, val); } /* This little bit of magic allows us to say TOSTRING(SYM) and get * "5" if SYM is 5 */ #define TOSTRING2(x) #x #define TOSTRING(x) TOSTRING2(x) void printRtsInfo(void) { /* The first entry is just a hack to make it easy to get the * commas right */ printf(" [(\"GHC RTS\", \"YES\")\n"); mkRtsInfoPair("GHC version", ProjectVersion); mkRtsInfoPair("RTS way", RtsWay); mkRtsInfoPair("Build platform", BuildPlatform); mkRtsInfoPair("Build architecture", BuildArch); mkRtsInfoPair("Build OS", BuildOS); mkRtsInfoPair("Build vendor", BuildVendor); mkRtsInfoPair("Host platform", HostPlatform); mkRtsInfoPair("Host architecture", HostArch); mkRtsInfoPair("Host OS", HostOS); mkRtsInfoPair("Host vendor", HostVendor); mkRtsInfoPair("Target platform", TargetPlatform); mkRtsInfoPair("Target architecture", TargetArch); mkRtsInfoPair("Target OS", TargetOS); mkRtsInfoPair("Target vendor", TargetVendor); mkRtsInfoPair("Word size", TOSTRING(WORD_SIZE_IN_BITS)); mkRtsInfoPair("Compiler unregisterised", GhcUnregisterised); mkRtsInfoPair("Tables next to code", GhcEnableTablesNextToCode); printf(" ]\n"); } // Provides a way for Haskell programs to tell whether they're being // profiled or not. GHCi uses it (see #2197). int rts_isProfiled(void) { #ifdef PROFILING return 1; #else return 0; #endif }