#include <time.h>
#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 <fcntl.h>
#endif
#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;
+#if defined(_WIN32)
+#include <windows.h>
#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 <windows.h>
+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: %p still allocated at shutdown\n",
+ 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 %zd as allocs is NULL\n",
+ addr, 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
/* -----------------------------------------------------------------------------
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;
}
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;
}
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;
}
void
stgFree(void* p)
{
+#if defined(DEBUG)
+ removeAllocation(p, 1);
+#endif
free(p);
}
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
#endif
}
-/* -----------------------------------------------------------------------------
- Allocating executable memory
- -------------------------------------------------------------------------- */
-
-/* Heavily arch-specific, I'm afraid.. */
+static void mkRtsInfoPair(char *key, char *val) {
+ /* XXX should check for "s, \s etc in key and val */
+ printf(" ,(\"%s\", \"%s\")\n", key, val);
+}
-/*
- * 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)
-{
- 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);
- }
-#endif
- return addr;
+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("Build platform", BuildPlatform);
+ mkRtsInfoPair("Target platform", TargetPlatform);
+ mkRtsInfoPair("Compiler unregisterised", GhcUnregisterised);
+ mkRtsInfoPair("Tables next to code", GhcEnableTablesNextToCode);
+ printf(" ]\n");
}
+
projects / ghc-hetmet.git / blobdiff