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 allocate(void *addr, size_t len) {
+static void addAllocation(void *addr, size_t len) {
Allocated *a;
size_t alloc_size;
- 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);
+ 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);)
}
- a->addr = addr;
- a->len = len;
- ACQUIRE_LOCK(&allocator_mutex);
- a->next = allocs->next;
- allocs->next = a;
- RELEASE_LOCK(&allocator_mutex);
}
-static void deallocate(void *addr) {
+static void removeAllocation(void *addr, int overwrite_with_aa) {
Allocated *prev, *a;
if (addr == NULL) {
barf("Freeing NULL!");
}
- ACQUIRE_LOCK(&allocator_mutex);
- prev = allocs;
- a = prev->next;
- while (a != NULL) {
- if (a->addr == addr) {
- prev->next = a->next;
- memset(addr, 0xaa, a->len);
- free(a);
- RELEASE_LOCK(&allocator_mutex);
- return;
+ 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;
}
- 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);)
}
- barf("Freeing non-allocated memory at %p", addr);
}
#endif
stg_exit(EXIT_INTERNAL_ERROR);
}
#if defined(DEBUG)
- allocate(space, n2);
+ addAllocation(space, n2);
#endif
return space;
}
stg_exit(EXIT_INTERNAL_ERROR);
}
#if defined(DEBUG)
- deallocate(p);
- allocate(space, n2);
+ removeAllocation(p, 0);
+ addAllocation(space, n2);
#endif
return space;
}
stg_exit(EXIT_INTERNAL_ERROR);
}
#if defined(DEBUG)
- allocate(space, (size_t) n * (size_t) m);
+ addAllocation(space, (size_t) n * (size_t) m);
#endif
return space;
}
stgFree(void* p)
{
#if defined(DEBUG)
- deallocate(p);
+ 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