*
* ---------------------------------------------------------------------------*/
-/* 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
-#ifdef solaris2_HOST_OS
-// Solaris requires this to get access to the POSIX ctime_r()
-#define _POSIX_PTHREAD_SEMANTICS
-#endif
#include <time.h>
-#ifdef solaris2_HOST_OS
-#undef _POSIX_PTHREAD_SEMANTICS
#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 <pthread.h>
#endif
-#if defined(openbsd_HOST_OS) || defined(linux_HOST_OS) || defined(darwin_HOST_OS)
-#include <unistd.h>
-#include <sys/types.h>
-#include <sys/mman.h>
-
-/* no C99 header stdint.h on OpenBSD? */
-#if defined(openbsd_HOST_OS)
-typedef unsigned long my_uintptr_t;
-#else
-#include <stdint.h>
-typedef uintptr_t my_uintptr_t;
-#endif
-#endif
#if defined(_WIN32)
#include <windows.h>
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);
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);
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.
+ if (!heap_overflow)
+ {
+ /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
+ OutOfHeapHook(0/*unknown request size*/,
+ RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
- 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;
+ 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;
Get the current time as a string. Used in profiling reports.
-------------------------------------------------------------------------- */
-#if defined(PROFILING) || defined(DEBUG) || defined(PAR) || defined(GRAN)
char *
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;
}
* 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("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");
+}
-/*
- * 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;
}
+
+// Used for detecting a non-empty FPU stack on x86 (see #4914)
+void checkFPUStack(void)
+{
+#ifdef x86_HOST_ARCH
+ static unsigned char buf[108];
+ asm("FSAVE %0":"=m" (buf));
+
+ if(buf[8]!=255 || buf[9]!=255) {
+ errorBelch("NONEMPTY FPU Stack, TAG = %x %x\n",buf[8],buf[9]);
+ abort();
+ }
+#endif
+}
+
projects / ghc-hetmet.git / blobdiff