A few typofixes
[ghc.git] / rts / RtsUtils.c
index 3091aa1..618815d 100644 (file)
@@ -7,30 +7,30 @@
  * ---------------------------------------------------------------------------*/
 
 #include "PosixSource.h"
-
 #include "Rts.h"
 #include "RtsAPI.h"
-#include "RtsFlags.h"
+
 #include "RtsUtils.h"
 #include "Ticky.h"
 #include "Schedule.h"
+#include "RtsFlags.h"
 
-#ifdef HAVE_TIME_H
+#if defined(HAVE_TIME_H)
 #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
+#if defined(HAVE_CTIME_R) && !HAVE_DECL_CTIME_R
 extern char *ctime_r(const time_t *, char *);
 #endif
 
-#ifdef HAVE_FCNTL_H
+#if defined(HAVE_FCNTL_H)
 #include <fcntl.h>
 #endif
 
-#ifdef HAVE_GETTIMEOFDAY
+#if defined(HAVE_GETTIMEOFDAY)
 #include <sys/time.h>
 #endif
 
@@ -39,7 +39,7 @@ extern char *ctime_r(const time_t *, char *);
 #include <stdarg.h>
 #include <stdio.h>
 
-#ifdef HAVE_SIGNAL_H
+#if defined(HAVE_SIGNAL_H)
 #include <signal.h>
 #endif
 
@@ -53,270 +53,103 @@ 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: %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
-
-/* -----------------------------------------------------------------------------
    Result-checking malloc wrappers.
    -------------------------------------------------------------------------- */
 
 void *
-stgMallocBytes (int n, char *msg)
+stgMallocBytes (size_t n, char *msg)
 {
-    char *space;
-    size_t n2;
+    void *space;
+
+    if ((space = malloc(n)) == NULL) {
+      /* Quoting POSIX.1-2008 (which says more or less the same as ISO C99):
+       *
+       *   "Upon successful completion with size not equal to 0, malloc() shall
+       *   return a pointer to the allocated space. If size is 0, either a null
+       *   pointer or a unique pointer that can be successfully passed to free()
+       *   shall be returned. Otherwise, it shall return a null pointer and set
+       *   errno to indicate the error."
+       *
+       * Consequently, a NULL pointer being returned by `malloc()` for a 0-size
+       * allocation is *not* to be considered an error.
+       */
+      if (n == 0) return 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*/
+      rtsConfig.mallocFailHook((W_) n, msg);
       stg_exit(EXIT_INTERNAL_ERROR);
     }
-#if defined(DEBUG)
-    addAllocation(space, n2);
-#endif
+    IF_DEBUG(sanity, memset(space, 0xbb, n));
     return space;
 }
 
 void *
-stgReallocBytes (void *p, int n, char *msg)
+stgReallocBytes (void *p, size_t n, char *msg)
 {
-    char *space;
-    size_t n2;
+    void *space;
 
-    n2 = (size_t) n;
-    if ((space = (char *) realloc(p, (size_t) n2)) == NULL) {
+    if ((space = realloc(p, n)) == NULL) {
       /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
-      MallocFailHook((W_) n, msg); /*msg*/
+      rtsConfig.mallocFailHook((W_) n, msg);
       stg_exit(EXIT_INTERNAL_ERROR);
     }
-#if defined(DEBUG)
-    removeAllocation(p, 0);
-    addAllocation(space, n2);
-#endif
     return space;
 }
 
 void *
-stgCallocBytes (int n, int m, char *msg)
+stgCallocBytes (size_t n, size_t m, char *msg)
 {
-    char *space;
+    void *space;
 
-    if ((space = (char *) calloc((size_t) n, (size_t) m)) == NULL) {
+    if ((space = calloc(n, m)) == NULL) {
       /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
-      MallocFailHook((W_) n*m, msg); /*msg*/
+      rtsConfig.mallocFailHook((W_) n*m, msg);
       stg_exit(EXIT_INTERNAL_ERROR);
     }
-#if defined(DEBUG)
-    addAllocation(space, (size_t) n * (size_t) m);
-#endif
     return space;
 }
 
+/* borrowed from the MUSL libc project */
+char *stgStrndup(const char *s, size_t n)
+{
+    size_t l = strnlen(s, n);
+    char *d = stgMallocBytes(l+1, "stgStrndup");
+    if (!d) return NULL;
+    memcpy(d, s, l);
+    d[l] = 0;
+    return d;
+}
+
+
 /* To simplify changing the underlying allocator used
  * by stgMallocBytes(), provide stgFree() as well.
  */
 void
 stgFree(void* p)
 {
-#if defined(DEBUG)
-  removeAllocation(p, 1);
-#endif
   free(p);
 }
 
 /* -----------------------------------------------------------------------------
-   Stack overflow
-   
-   Not sure if this belongs here.
+   Stack/heap overflow
    -------------------------------------------------------------------------- */
 
 void
-stackOverflow(void)
+reportStackOverflow(StgTSO* tso)
 {
-  StackOverflowHook(RtsFlags.GcFlags.maxStkSize * sizeof(W_));
+    rtsConfig.stackOverflowHook(tso->tot_stack_size * sizeof(W_));
 
 #if defined(TICKY_TICKY)
-  if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
+    if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
 #endif
 }
 
 void
-heapOverflow(void)
-{
-    if (!heap_overflow)
-    {
-        /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
-        OutOfHeapHook(0/*unknown request size*/,
-                      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 */
+reportHeapOverflow(void)
 {
-    __GenSymCounter=0;
-    return(__GenSymCounter);
+    /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
+    rtsConfig.outOfHeapHook(0/*unknown request size*/,
+                            (W_)RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
 }
 
 /* -----------------------------------------------------------------------------
@@ -330,93 +163,104 @@ time_str(void)
     static char nowstr[26];
 
     if (now == 0) {
-       time(&now);
-#if HAVE_CTIME_R
-       ctime_r(&now, nowstr);
+        time(&now);
+#if defined(HAVE_CTIME_R)
+        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, bool 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;
 }
 
 
 // Can be used as a breakpoint to set on every heap check failure.
-#ifdef DEBUG
+#if defined(DEBUG)
 void
 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,14 +268,14 @@ 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);
 #endif
 }
 
-static void mkRtsInfoPair(char *key, char *val) {
+static void mkRtsInfoPair(const char *key, const char *val) {
     /* XXX should check for "s, \s etc in key and val */
     printf(" ,(\"%s\", \"%s\")\n", key, val);
 }
@@ -441,20 +285,20 @@ static void mkRtsInfoPair(char *key, char *val) {
 #define TOSTRING2(x) #x
 #define TOSTRING(x)  TOSTRING2(x)
 
-void printRtsInfo(void) {
+void printRtsInfo(const RtsConfig rts_config) {
     /* 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("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);
@@ -462,6 +306,8 @@ void printRtsInfo(void) {
     mkRtsInfoPair("Word size",               TOSTRING(WORD_SIZE_IN_BITS));
     mkRtsInfoPair("Compiler unregisterised", GhcUnregisterised);
     mkRtsInfoPair("Tables next to code",     GhcEnableTablesNextToCode);
+    mkRtsInfoPair("Flag -with-rtsopts",      /* See Trac #15261 */
+        rts_config.rts_opts != NULL ? rts_config.rts_opts : "");
     printf(" ]\n");
 }
 
@@ -469,9 +315,34 @@ void printRtsInfo(void) {
 // profiled or not.  GHCi uses it (see #2197).
 int rts_isProfiled(void)
 {
-#ifdef PROFILING
+#if defined(PROFILING)
+    return 1;
+#else
+    return 0;
+#endif
+}
+
+// Provides a way for Haskell programs to tell whether they're
+// dynamically-linked or not.
+int rts_isDynamic(void)
+{
+#if defined(DYNAMIC)
     return 1;
 #else
     return 0;
 #endif
 }
+
+// Used for detecting a non-empty FPU stack on x86 (see #4914)
+void checkFPUStack(void)
+{
+#if defined(i386_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
+}