X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FRtsUtils.c;h=dc11cb46ef23bc0c2055742e0efb5bee06a59420;hb=661c97c65e5fa47177502e592bb763f752b487ac;hp=7d6c4a557cb2c567b55fd1611541c1bb33cfbceb;hpb=5a5acb3698aa4ffdd738c301fa722afe12a1f3de;p=ghc-hetmet.git diff --git a/rts/RtsUtils.c b/rts/RtsUtils.c index 7d6c4a5..dc11cb4 100644 --- a/rts/RtsUtils.c +++ b/rts/RtsUtils.c @@ -7,10 +7,9 @@ * ---------------------------------------------------------------------------*/ #include "PosixSource.h" - #include "Rts.h" #include "RtsAPI.h" -#include "RtsFlags.h" + #include "RtsUtils.h" #include "Ticky.h" #include "Schedule.h" @@ -110,8 +109,8 @@ shutdownAllocator(void) free(prev); if (a == NULL) return; IF_DEBUG(sanity, - debugBelch("Warning: %p still allocated at shutdown\n", - a->addr);) + debugBelch("Warning: %ld bytes at %p still allocated at shutdown\n", + (long)a->len, a->addr);) prev = a; } } @@ -139,8 +138,8 @@ static void addAllocation(void *addr, size_t len) { /* 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 %zd as allocs is NULL\n", - addr, len);) + debugBelch("Ignoring allocation %p %d as allocs is NULL\n", + addr, (int)len);) } } @@ -284,22 +283,6 @@ heapOverflow(void) } /* ----------------------------------------------------------------------------- - 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; - - while (*p) p++; - return p-s; -} - - -/* ----------------------------------------------------------------------------- genSym stuff, used by GHC itself for its splitting unique supply. ToDo: put this somewhere sensible. @@ -343,104 +326,78 @@ time_str(void) } /* ----------------------------------------------------------------------------- - * 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; } @@ -461,7 +418,7 @@ 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); @@ -473,17 +430,42 @@ static void mkRtsInfoPair(char *key, char *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"); + 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"); } +// 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 +}