X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FRtsUtils.c;h=dc11cb46ef23bc0c2055742e0efb5bee06a59420;hb=661c97c65e5fa47177502e592bb763f752b487ac;hp=3e7e225dda3314468ed3deccab22b7d6545e2437;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/rts/RtsUtils.c b/rts/RtsUtils.c index 3e7e225..dc11cb4 100644 --- a/rts/RtsUtils.c +++ b/rts/RtsUtils.c @@ -6,19 +6,25 @@ * * ---------------------------------------------------------------------------*/ -/* gettimeofday isn't POSIX */ -/* #include "PosixSource.h" */ - +#include "PosixSource.h" #include "Rts.h" #include "RtsAPI.h" -#include "RtsFlags.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 @@ -40,22 +46,142 @@ #include #endif -#if defined(openbsd_HOST_OS) || defined(linux_HOST_OS) || defined(darwin_HOST_OS) -#include -#include -#include -/* no C99 header stdint.h on OpenBSD? */ -#if defined(openbsd_HOST_OS) -typedef unsigned long my_uintptr_t; -#else -#include -typedef uintptr_t my_uintptr_t; +#if defined(_WIN32) +#include #endif + +/* ----------------------------------------------------------------------------- + Debugging allocator + -------------------------------------------------------------------------- */ + +#if defined(DEBUG) + +typedef struct Allocated_ { + void *addr; + size_t len; + struct Allocated_ *next; +} Allocated; + +static Allocated *allocs = NULL; + +#ifdef THREADED_RTS +static Mutex allocator_mutex; #endif -#if defined(_WIN32) -#include +void +initAllocator(void) +{ + Allocated *a; + size_t alloc_size; + +#ifdef THREADED_RTS + initMutex(&allocator_mutex); +#endif + alloc_size = sizeof(Allocated); + if ((a = (Allocated *) malloc(alloc_size)) == NULL) { + /* don't fflush(stdout); WORKAROUND bug in Linux glibc */ + MallocFailHook((W_) alloc_size, "initialising debugging allocator"); + stg_exit(EXIT_INTERNAL_ERROR); + } + a->addr = NULL; + a->len = 0; + a->next = NULL; + allocs = a; +} + +void +shutdownAllocator(void) +{ + Allocated *prev, *a; + + if (allocs == NULL) { + barf("Allocator shutdown requested, but not initialised!"); + } + +#ifdef THREADED_RTS + closeMutex(&allocator_mutex); +#endif + + prev = allocs; + while (1) { + a = prev->next; + free(prev); + if (a == NULL) return; + IF_DEBUG(sanity, + debugBelch("Warning: %ld bytes at %p still allocated at shutdown\n", + (long)a->len, a->addr);) + prev = a; + } +} + +static void addAllocation(void *addr, size_t len) { + Allocated *a; + size_t alloc_size; + + if (allocs != NULL) { + alloc_size = sizeof(Allocated); + if ((a = (Allocated *) malloc(alloc_size)) == NULL) { + /* don't fflush(stdout); WORKAROUND bug in Linux glibc */ + MallocFailHook((W_) alloc_size, + "creating info for debugging allocator"); + stg_exit(EXIT_INTERNAL_ERROR); + } + a->addr = addr; + a->len = len; + ACQUIRE_LOCK(&allocator_mutex); + a->next = allocs->next; + allocs->next = a; + RELEASE_LOCK(&allocator_mutex); + } + else { + /* This doesn't actually help as we haven't looked at the flags + * at the time that it matters (while running constructors) */ + IF_DEBUG(sanity, + debugBelch("Ignoring allocation %p %d as allocs is NULL\n", + addr, (int)len);) + } +} + +static void removeAllocation(void *addr, int overwrite_with_aa) { + Allocated *prev, *a; + + if (addr == NULL) { + barf("Freeing NULL!"); + } + + if (allocs != NULL) { + ACQUIRE_LOCK(&allocator_mutex); + prev = allocs; + a = prev->next; + while (a != NULL) { + if (a->addr == addr) { + prev->next = a->next; + if (overwrite_with_aa) { + memset(addr, 0xaa, a->len); + } + free(a); + RELEASE_LOCK(&allocator_mutex); + return; + } + prev = a; + a = a->next; + } + /* We would like to barf here, but we can't as conc021 + * allocates some stuff in a constructor which then gets freed + * during hs_exit */ + /* barf("Freeing non-allocated memory at %p", addr); */ + IF_DEBUG(sanity, + debugBelch("Warning: Freeing non-allocated memory at %p\n", + addr);) + RELEASE_LOCK(&allocator_mutex); + } + else { + IF_DEBUG(sanity, + debugBelch("Ignoring free of %p as allocs is NULL\n", + addr);) + } +} #endif /* ----------------------------------------------------------------------------- @@ -66,12 +192,17 @@ void * stgMallocBytes (int n, char *msg) { char *space; + size_t n2; - if ((space = (char *) malloc((size_t) n)) == NULL) { + 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); } +#if defined(DEBUG) + addAllocation(space, n2); +#endif return space; } @@ -79,12 +210,18 @@ void * stgReallocBytes (void *p, int n, char *msg) { char *space; + size_t n2; - if ((space = (char *) realloc(p, (size_t) n)) == NULL) { + 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); } +#if defined(DEBUG) + removeAllocation(p, 0); + addAllocation(space, n2); +#endif return space; } @@ -98,6 +235,9 @@ stgCallocBytes (int n, int m, char *msg) MallocFailHook((W_) n*m, msg); /*msg*/ stg_exit(EXIT_INTERNAL_ERROR); } +#if defined(DEBUG) + addAllocation(space, (size_t) n * (size_t) m); +#endif return space; } @@ -107,6 +247,9 @@ stgCallocBytes (int n, int m, char *msg) void stgFree(void* p) { +#if defined(DEBUG) + removeAllocation(p, 1); +#endif free(p); } @@ -129,47 +272,30 @@ stackOverflow(void) void heapOverflow(void) { - /* don't fflush(stdout); WORKAROUND bug in Linux glibc */ - OutOfHeapHook(0/*unknown request size*/, - RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE); - -#if defined(TICKY_TICKY) - if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo(); -#endif - - stg_exit(EXIT_HEAPOVERFLOW); -} - -/* ----------------------------------------------------------------------------- - Out-of-line strlen. - - Used in addr2Integer because the C compiler on x86 chokes on - strlen, trying to inline it with not enough registers available. - -------------------------------------------------------------------------- */ - -nat stg_strlen(char *s) -{ - char *p = s; + if (!heap_overflow) + { + /* don't fflush(stdout); WORKAROUND bug in Linux glibc */ + OutOfHeapHook(0/*unknown request size*/, + RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE); - while (*p) p++; - return p-s; + heap_overflow = rtsTrue; + } } - /* ----------------------------------------------------------------------------- genSym stuff, used by GHC itself for its splitting unique supply. ToDo: put this somewhere sensible. ------------------------------------------------------------------------- */ -static I_ __GenSymCounter = 0; +static HsInt __GenSymCounter = 0; -I_ +HsInt genSymZh(void) { return(__GenSymCounter++); } -I_ +HsInt resetGenSymZh(void) /* it's your funeral */ { __GenSymCounter=0; @@ -180,7 +306,6 @@ resetGenSymZh(void) /* it's your funeral */ Get the current time as a string. Used in profiling reports. -------------------------------------------------------------------------- */ -#if defined(PROFILING) || defined(DEBUG) || defined(PAR) || defined(GRAN) char * time_str(void) { @@ -199,107 +324,80 @@ time_str(void) } return nowstr; } -#endif - -/* ----------------------------------------------------------------------------- - * Reset a file handle to blocking mode. We do this for the standard - * file descriptors before exiting, because the shell doesn't always - * clean up for us. - * -------------------------------------------------------------------------- */ - -#if !defined(mingw32_HOST_OS) -void -resetNonBlockingFd(int fd) -{ - long fd_flags; - - /* clear the non-blocking flag on this file descriptor */ - fd_flags = fcntl(fd, F_GETFL); - if (fd_flags & O_NONBLOCK) { - fcntl(fd, F_SETFL, fd_flags & ~O_NONBLOCK); - } -} - -void -setNonBlockingFd(int fd) -{ - long fd_flags; - - /* clear the non-blocking flag on this file descriptor */ - fd_flags = fcntl(fd, F_GETFL); - if (!(fd_flags & O_NONBLOCK)) { - fcntl(fd, F_SETFL, fd_flags | O_NONBLOCK); - } -} -#else -/* Stub defns -- async / non-blocking IO is not done - * via O_NONBLOCK and select() under Win32. - */ -void resetNonBlockingFd(int fd STG_UNUSED) {} -void setNonBlockingFd(int fd STG_UNUSED) {} -#endif - -#ifdef PAR -static ullong startTime = 0; - -/* used in a parallel setup */ -ullong -msTime(void) -{ -# if defined(HAVE_GETCLOCK) && !defined(alpha_HOST_ARCH) && !defined(hppa1_1_HOST_ARCH) - struct timespec tv; - - if (getclock(TIMEOFDAY, &tv) != 0) { - fflush(stdout); - fprintf(stderr, "Clock failed\n"); - stg_exit(EXIT_FAILURE); - } - return tv.tv_sec * LL(1000) + tv.tv_nsec / LL(1000000) - startTime; -# elif HAVE_GETTIMEOFDAY && !defined(alpha_HOST_ARCH) - struct timeval tv; - - if (gettimeofday(&tv, NULL) != 0) { - fflush(stdout); - fprintf(stderr, "Clock failed\n"); - stg_exit(EXIT_FAILURE); - } - return tv.tv_sec * LL(1000) + tv.tv_usec / LL(1000) - startTime; -# else - time_t t; - if ((t = time(NULL)) == (time_t) -1) { - fflush(stdout); - fprintf(stderr, "Clock failed\n"); - stg_exit(EXIT_FAILURE); - } - return t * LL(1000) - startTime; -# endif -} -#endif /* PAR */ /* ----------------------------------------------------------------------------- Print large numbers, with punctuation. -------------------------------------------------------------------------- */ char * -ullong_format_string(ullong x, char *s, rtsBool with_commas) +showStgWord64(StgWord64 x, char *s, rtsBool with_commas) { - if (x < (ullong)1000) - sprintf(s, "%lu", (lnat)x); - else if (x < (ullong)1000000) - sprintf(s, (with_commas) ? "%lu,%3.3lu" : "%lu%3.3lu", - (lnat)((x)/(ullong)1000), - (lnat)((x)%(ullong)1000)); - else if (x < (ullong)1000000000) - sprintf(s, (with_commas) ? "%lu,%3.3lu,%3.3lu" : "%lu%3.3lu%3.3lu", - (lnat)((x)/(ullong)1000000), - (lnat)((x)/(ullong)1000%(ullong)1000), - (lnat)((x)%(ullong)1000)); - else - sprintf(s, (with_commas) ? "%lu,%3.3lu,%3.3lu,%3.3lu" : "%lu%3.3lu%3.3lu%3.3lu", - (lnat)((x)/(ullong)1000000000), - (lnat)((x)/(ullong)1000000%(ullong)1000), - (lnat)((x)/(ullong)1000%(ullong)1000), - (lnat)((x)%(ullong)1000)); + 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; } @@ -320,48 +418,54 @@ heapCheckFail( void ) * genericRaise(), rather than raise(3). */ int genericRaise(int sig) { -#if defined(THREADED_RTS) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS)) +#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 } -/* ----------------------------------------------------------------------------- - Allocating executable memory - -------------------------------------------------------------------------- */ +static void mkRtsInfoPair(char *key, char *val) { + /* XXX should check for "s, \s etc in key and val */ + printf(" ,(\"%s\", \"%s\")\n", key, val); +} -/* Heavily arch-specific, I'm afraid.. */ +/* 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("Host platform", HostPlatform); + mkRtsInfoPair("Host architecture", HostArch); + mkRtsInfoPair("Host OS", HostOS); + mkRtsInfoPair("Host vendor", HostVendor); + mkRtsInfoPair("Build platform", BuildPlatform); + mkRtsInfoPair("Build architecture", BuildArch); + mkRtsInfoPair("Build OS", BuildOS); + mkRtsInfoPair("Build vendor", BuildVendor); + 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"); +} -/* - * Allocate len bytes which are readable, writable, and executable. - * - * ToDo: If this turns out to be a performance bottleneck, one could - * e.g. cache the last VirtualProtect/mprotect-ed region and do - * nothing in case of a cache hit. - */ -void* -stgMallocBytesRWX(int len) +// Provides a way for Haskell programs to tell whether they're being +// profiled or not. GHCi uses it (see #2197). +int rts_isProfiled(void) { - void *addr = stgMallocBytes(len, "mallocBytesRWX"); -#if defined(i386_HOST_ARCH) && defined(_WIN32) - /* This could be necessary for processors which distinguish between READ and - EXECUTE memory accesses, e.g. Itaniums. */ - DWORD dwOldProtect = 0; - if (VirtualProtect (addr, len, PAGE_EXECUTE_READWRITE, &dwOldProtect) == 0) { - barf("mallocBytesRWX: failed to protect 0x%p; error=%lu; old protection: %lu\n", - addr, (unsigned long)GetLastError(), (unsigned long)dwOldProtect); - } -#elif defined(openbsd_HOST_OS) || defined(linux_HOST_OS) || defined(darwin_HOST_OS) - /* malloced memory isn't executable by default on OpenBSD */ - my_uintptr_t pageSize = sysconf(_SC_PAGESIZE); - my_uintptr_t mask = ~(pageSize - 1); - my_uintptr_t startOfFirstPage = ((my_uintptr_t)addr ) & mask; - my_uintptr_t startOfLastPage = ((my_uintptr_t)addr + len - 1) & mask; - my_uintptr_t size = startOfLastPage - startOfFirstPage + pageSize; - if (mprotect((void*)startOfFirstPage, (size_t)size, PROT_EXEC | PROT_READ | PROT_WRITE) != 0) { - barf("mallocBytesRWX: failed to protect 0x%p\n", addr); - } +#ifdef PROFILING + return 1; +#else + return 0; #endif - return addr; }