X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FRtsUtils.c;h=51c1250682e9e15c3bf54db74c47a13bfc36c3f0;hb=158e71360bfad8b8ee037e0f6ab81a6e8ced2e03;hp=0123531e27ab3a8bdeed2607e852e065ae29898f;hpb=224a7fa07de24c67f52bc613f31ae1bf453cd7b8;p=ghc-hetmet.git diff --git a/rts/RtsUtils.c b/rts/RtsUtils.c index 0123531..51c1250 100644 --- a/rts/RtsUtils.c +++ b/rts/RtsUtils.c @@ -7,12 +7,12 @@ * ---------------------------------------------------------------------------*/ #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 @@ -109,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; } } @@ -272,33 +272,16 @@ 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. @@ -343,81 +326,6 @@ 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. -------------------------------------------------------------------------- */ @@ -461,7 +369,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 +381,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 +}