Comments about the let/app invariant
[ghc.git] / rts / RtsUtils.c
index ed082a3..fff8717 100644 (file)
@@ -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"
@@ -53,139 +52,6 @@ extern char *ctime_r(const time_t *, char *);
 #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
-
-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: %ld bytes at %p still allocated at shutdown\n",
-                            (long)a->len, 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
-
-/* -----------------------------------------------------------------------------
    Result-checking malloc wrappers.
    -------------------------------------------------------------------------- */
 
@@ -201,9 +67,6 @@ stgMallocBytes (int n, char *msg)
       MallocFailHook((W_) n, msg); /*msg*/
       stg_exit(EXIT_INTERNAL_ERROR);
     }
-#if defined(DEBUG)
-    addAllocation(space, n2);
-#endif
     return space;
 }
 
@@ -219,10 +82,6 @@ stgReallocBytes (void *p, int n, char *msg)
       MallocFailHook((W_) n, msg); /*msg*/
       stg_exit(EXIT_INTERNAL_ERROR);
     }
-#if defined(DEBUG)
-    removeAllocation(p, 0);
-    addAllocation(space, n2);
-#endif
     return space;
 }
 
@@ -236,9 +95,6 @@ stgCallocBytes (int n, int m, char *msg)
       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;
 }
 
@@ -248,25 +104,22 @@ stgCallocBytes (int n, int m, char *msg)
 void
 stgFree(void* p)
 {
-#if defined(DEBUG)
-  removeAllocation(p, 1);
-#endif
   free(p);
 }
 
 /* -----------------------------------------------------------------------------
    Stack overflow
-   
+
    Not sure if this belongs here.
    -------------------------------------------------------------------------- */
 
 void
-stackOverflow(void)
+stackOverflow(StgTSO* tso)
 {
-  StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
+    StackOverflowHook(tso->tot_stack_size * sizeof(W_));
 
 #if defined(TICKY_TICKY)
-  if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
+    if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 #endif
 }
 
@@ -277,49 +130,13 @@ heapOverflow(void)
     {
         /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
         OutOfHeapHook(0/*unknown request size*/,
-                      RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
+                      (W_)RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
 
         heap_overflow = rtsTrue;
     }
 }
 
 /* -----------------------------------------------------------------------------
-   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.
-   -------------------------------------------------------------------------  */
-
-static HsInt __GenSymCounter = 0;
-
-HsInt
-genSymZh(void)
-{
-    return(__GenSymCounter++);
-}
-HsInt
-resetGenSymZh(void) /* it's your funeral */
-{
-    __GenSymCounter=0;
-    return(__GenSymCounter);
-}
-
-/* -----------------------------------------------------------------------------
    Get the current time as a string.  Used in profiling reports.
    -------------------------------------------------------------------------- */
 
@@ -330,80 +147,91 @@ time_str(void)
     static char nowstr[26];
 
     if (now == 0) {
-       time(&now);
+        time(&now);
 #if HAVE_CTIME_R
-       ctime_r(&now, nowstr);
+        ctime_r(&now, nowstr);
 #else
-       strcpy(nowstr, ctime(&now));
+        strcpy(nowstr, ctime(&now));
 #endif
-       memmove(nowstr+16,nowstr+19,7);
-       nowstr[21] = '\0';  // removes the \n
+        memmove(nowstr+16,nowstr+19,7);
+        nowstr[21] = '\0';  // removes the \n
     }
     return nowstr;
 }
 
 /* -----------------------------------------------------------------------------
- * 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
-
-/* -----------------------------------------------------------------------------
    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;
 }
 
@@ -416,7 +244,7 @@ heapCheckFail( void )
 }
 #endif
 
-/* 
+/*
  * It seems that pthreads and signals interact oddly in OpenBSD & FreeBSD
  * pthreads (and possibly others). When linking with -lpthreads, we
  * have to use pthread_kill to send blockable signals. So use that
@@ -424,7 +252,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) || defined(netbsd_HOST_OS) || defined(darwin_HOST_OS))
         return pthread_kill(pthread_self(), sig);
 #else
         return raise(sig);
@@ -447,14 +275,14 @@ void printRtsInfo(void) {
     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("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);
@@ -475,3 +303,29 @@ int rts_isProfiled(void)
     return 0;
 #endif
 }
+
+// Provides a way for Haskell programs to tell whether they're
+// dynamically-linked or not.
+int rts_isDynamic(void)
+{
+#ifdef DYNAMIC
+    return 1;
+#else
+    return 0;
+#endif
+}
+
+// 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
+}
+