Cleanup after the OPTIONS parsing was moved.

[ghc-hetmet.git] / ghc / rts / MBlock.c

diff --git a/ghc/rts/MBlock.c b/ghc/rts/MBlock.c
index ff4467f..fa8fd49 100644 (file)
--- a/ghc/rts/MBlock.c
+++ b/ghc/rts/MBlock.c
@@ -29,7 +29,7 @@
 #ifdef HAVE_SYS_TYPES_H
 #include <sys/types.h>
 #endif
 #ifdef HAVE_SYS_TYPES_H
 #include <sys/types.h>
 #endif

-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS

 # ifdef HAVE_SYS_MMAN_H
 # include <sys/mman.h>
 # endif
 # ifdef HAVE_SYS_MMAN_H
 # include <sys/mman.h>
 # endif

@@ -40,7 +40,7 @@
 #if HAVE_WINDOWS_H
 #include <windows.h>
 #endif
 #if HAVE_WINDOWS_H
 #include <windows.h>
 #endif

-#if darwin_TARGET_OS
+#if darwin_HOST_OS

 #include <mach/vm_map.h>
 #endif
 
 #include <mach/vm_map.h>
 #endif
 

@@ -52,10 +52,63 @@ lnat mblocks_allocated = 0;
    The MBlock Map: provides our implementation of HEAP_ALLOCED()
    -------------------------------------------------------------------------- */
 
    The MBlock Map: provides our implementation of HEAP_ALLOCED()
    -------------------------------------------------------------------------- */
 

-#ifdef MBLOCK_MAP_SIZE
+#if SIZEOF_VOID_P == 4

 StgWord8 mblock_map[MBLOCK_MAP_SIZE]; // initially all zeros
 StgWord8 mblock_map[MBLOCK_MAP_SIZE]; // initially all zeros

+#elif SIZEOF_VOID_P == 8
+static MBlockMap dummy_mblock_map;
+MBlockMap *mblock_cache = &dummy_mblock_map;
+int mblock_map_count = 0;
+MBlockMap **mblock_maps = NULL;
+
+static MBlockMap *
+findMBlockMap(void *p)
+{
+    int i;
+    StgWord32 hi = (StgWord32) (((StgWord)p) >> 32);
+    for( i = 0; i < mblock_map_count; i++ )
+    {
+        if(mblock_maps[i]->addrHigh32 == hi)
+        {
+           return mblock_maps[i];
+       }
+    }
+    return NULL;
+}
+
+StgBool
+slowIsHeapAlloced(void *p)
+{
+    MBlockMap *map = findMBlockMap(p);
+    if(map)
+    {
+       mblock_cache = map;
+       return map->mblocks[MBLOCK_MAP_ENTRY(p)];
+    }
+    else
+       return 0;
+}

 #endif
 
 #endif
 

+static void
+markHeapAlloced(void *p)
+{
+#if SIZEOF_VOID_P == 4
+    mblock_map[MBLOCK_MAP_ENTRY(p)] = 1;
+#elif SIZEOF_VOID_P == 8
+    MBlockMap *map = findMBlockMap(p);
+    if(map == NULL)
+    {
+       mblock_map_count++;
+       mblock_maps = realloc(mblock_maps,
+                             sizeof(MBlockMap*) * mblock_map_count);
+       map = mblock_maps[mblock_map_count-1] = calloc(1,sizeof(MBlockMap));
+       map->addrHigh32 = (StgWord32) (((StgWord)p) >> 32);
+    }
+    map->mblocks[MBLOCK_MAP_ENTRY(p)] = 1;
+    mblock_cache = map;
+#endif
+}
+

 /* -----------------------------------------------------------------------------
    Allocate new mblock(s)
    -------------------------------------------------------------------------- */
 /* -----------------------------------------------------------------------------
    Allocate new mblock(s)
    -------------------------------------------------------------------------- */

@@ -81,9 +134,19 @@ getMBlock(void)
    chunk, on the grounds that this is aligned and likely to be free.
    If it turns out that we were wrong, we have to munmap() and try
    again using the general method.
    chunk, on the grounds that this is aligned and likely to be free.
    If it turns out that we were wrong, we have to munmap() and try
    again using the general method.

+
+   Note on posix_memalign(): this interface is available on recent
+   systems and appears to provide exactly what we want.  However, it
+   turns out not to be as good as our mmap() implementation, because
+   it wastes extra space (using double the address space, in a test on
+   x86_64/Linux).  The problem seems to be that posix_memalign()
+   returns memory that can be free()'d, so the library must store
+   extra information along with the allocated block, thus messing up
+   the alignment.  Hence, we don't use posix_memalign() for now.
+

    -------------------------------------------------------------------------- */
 
    -------------------------------------------------------------------------- */
 

-#if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS)
+#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS)

 
 // A wrapper around mmap(), to abstract away from OS differences in
 // the mmap() interface.
 
 // A wrapper around mmap(), to abstract away from OS differences in
 // the mmap() interface.

@@ -93,16 +156,16 @@ my_mmap (void *addr, lnat size)
 {
     void *ret;
 
 {
     void *ret;
 

-#if defined(solaris2_TARGET_OS) || defined(irix_TARGET_OS)
+#if defined(solaris2_HOST_OS) || defined(irix_HOST_OS)

     { 
        int fd = open("/dev/zero",O_RDONLY);
        ret = mmap(addr, size, PROT_READ | PROT_WRITE, MAP_PRIVATE, fd, 0);
        close(fd);
     }
     { 
        int fd = open("/dev/zero",O_RDONLY);
        ret = mmap(addr, size, PROT_READ | PROT_WRITE, MAP_PRIVATE, fd, 0);
        close(fd);
     }

-#elif hpux_TARGET_OS
+#elif hpux_HOST_OS

     ret = mmap(addr, size, PROT_READ | PROT_WRITE, 
               MAP_ANONYMOUS | MAP_PRIVATE, -1, 0);
     ret = mmap(addr, size, PROT_READ | PROT_WRITE, 
               MAP_ANONYMOUS | MAP_PRIVATE, -1, 0);

-#elif darwin_TARGET_OS
+#elif darwin_HOST_OS

     // Without MAP_FIXED, Apple's mmap ignores addr.
     // With MAP_FIXED, it overwrites already mapped regions, whic
     // mmap(0, ... MAP_FIXED ...) is worst of all: It unmaps the program text
     // Without MAP_FIXED, Apple's mmap ignores addr.
     // With MAP_FIXED, it overwrites already mapped regions, whic
     // mmap(0, ... MAP_FIXED ...) is worst of all: It unmaps the program text

@@ -118,10 +181,14 @@ my_mmap (void *addr, lnat size)
     if(!addr || err)   // try to allocate anywhere
        err = vm_allocate(mach_task_self(),(vm_address_t*) &ret, size, TRUE);
        
     if(!addr || err)   // try to allocate anywhere
        err = vm_allocate(mach_task_self(),(vm_address_t*) &ret, size, TRUE);
        

-    if(err) // don't know what the error codes mean exactly
-       barf("memory allocation failed (requested %d bytes)", size);
-    else
+    if(err) {
+       // don't know what the error codes mean exactly, assume it's
+       // not our problem though.
+       errorBelch("memory allocation failed (requested %lu bytes)", size);
+       stg_exit(EXIT_FAILURE);
+    } else {

        vm_protect(mach_task_self(),ret,size,FALSE,VM_PROT_READ|VM_PROT_WRITE);
        vm_protect(mach_task_self(),ret,size,FALSE,VM_PROT_READ|VM_PROT_WRITE);

+    }

 #else
     ret = mmap(addr, size, PROT_READ | PROT_WRITE | PROT_EXEC, 
               MAP_ANON | MAP_PRIVATE, -1, 0);
 #else
     ret = mmap(addr, size, PROT_READ | PROT_WRITE | PROT_EXEC, 
               MAP_ANON | MAP_PRIVATE, -1, 0);

@@ -132,7 +199,7 @@ my_mmap (void *addr, lnat size)
            (errno == EINVAL && sizeof(void*)==4 && size >= 0xc0000000)) {
            // If we request more than 3Gig, then we get EINVAL
            // instead of ENOMEM (at least on Linux).
            (errno == EINVAL && sizeof(void*)==4 && size >= 0xc0000000)) {
            // If we request more than 3Gig, then we get EINVAL
            // instead of ENOMEM (at least on Linux).

-           errorBelch("out of memory (requested %d bytes)", size);
+           errorBelch("out of memory (requested %lu bytes)", size);

            stg_exit(EXIT_FAILURE);
        } else {
            barf("getMBlock: mmap: %s", strerror(errno));
            stg_exit(EXIT_FAILURE);
        } else {
            barf("getMBlock: mmap: %s", strerror(errno));

@@ -224,7 +291,7 @@ getMBlocks(nat n)
 
   // fill in the table
   for (i = 0; i < n; i++) {
 
   // fill in the table
   for (i = 0; i < n; i++) {

-      MARK_HEAP_ALLOCED( ret + i * MBLOCK_SIZE );
+      markHeapAlloced( ret + i * MBLOCK_SIZE );

   }
 
   mblocks_allocated += n;
   }
 
   mblocks_allocated += n;

@@ -232,7 +299,13 @@ getMBlocks(nat n)
   return ret;
 }
 
   return ret;
 }
 

-#else /* defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS) */
+void
+freeAllMBlocks(void)
+{
+  /* XXX Do something here */
+}
+
+#else /* defined(mingw32_HOST_OS) || defined(cygwin32_HOST_OS) */

 
 /*
  On Win32 platforms we make use of the two-phased virtual memory API
 
 /*
  On Win32 platforms we make use of the two-phased virtual memory API

@@ -249,8 +322,10 @@ getMBlocks(nat n)
  our case).
 */
 
  our case).
 */
 

-char* base_non_committed = (char*)0;
-char* end_non_committed = (char*)0;
+static char* base_non_committed = (char*)0;
+static char* end_non_committed = (char*)0;
+
+static void *membase;

 
 /* Default is to reserve 256M of VM to minimise the slop cost. */
 #define SIZE_RESERVED_POOL  ( 256 * 1024 * 1024 )
 
 /* Default is to reserve 256M of VM to minimise the slop cost. */
 #define SIZE_RESERVED_POOL  ( 256 * 1024 * 1024 )

@@ -289,9 +364,10 @@ getMBlocks(nat n)
                                      , MEM_RESERVE
                                      , PAGE_READWRITE
                                      );
                                      , MEM_RESERVE
                                      , PAGE_READWRITE
                                      );

+    membase = base_non_committed;

     if ( base_non_committed == 0 ) {
     if ( base_non_committed == 0 ) {

-         errorBelch("getMBlocks: VirtualAlloc failed with: %ld\n", GetLastError());
-         ret=(void*)-1;
+         errorBelch("getMBlocks: VirtualAlloc MEM_RESERVE %lu failed with: %ld\n", size_reserved_pool, GetLastError());
+       ret=(void*)-1;

     } else {
       end_non_committed = (char*)base_non_committed + (unsigned long)size_reserved_pool;
       /* The returned pointer is not aligned on a mega-block boundary. Make it. */
     } else {
       end_non_committed = (char*)base_non_committed + (unsigned long)size_reserved_pool;
       /* The returned pointer is not aligned on a mega-block boundary. Make it. */

@@ -313,7 +389,7 @@ getMBlocks(nat n)
   if ( ret != (void*)-1 ) {
      ret = VirtualAlloc(next_request, size, MEM_COMMIT, PAGE_READWRITE);
      if (ret == NULL) {
   if ( ret != (void*)-1 ) {
      ret = VirtualAlloc(next_request, size, MEM_COMMIT, PAGE_READWRITE);
      if (ret == NULL) {

-        debugBelch("getMBlocks: VirtualAlloc failed with: %ld\n", GetLastError());
+        debugBelch("getMBlocks: VirtualAlloc MEM_COMMIT %lu failed with: %ld\n", size, GetLastError());

         ret=(void*)-1;
      }
   }
         ret=(void*)-1;
      }
   }

@@ -333,12 +409,24 @@ getMBlocks(nat n)
   
   // fill in the table
   for (i = 0; i < n; i++) {
   
   // fill in the table
   for (i = 0; i < n; i++) {

-      MARK_HEAP_ALLOCED ( ret + i * MBLOCK_SIZE );
+      markHeapAlloced( ret + i * MBLOCK_SIZE );

   }
 
   return ret;
 }
 
   }
 
   return ret;
 }
 

+void
+freeAllMBlocks(void)
+{
+  BOOL rc;
+
+  rc = VirtualFree(membase, 0, MEM_RELEASE);
+  
+  if (rc == FALSE) {
+     debugBelch("freeAllMBlocks: VirtualFree failed with: %ld\n", GetLastError());
+  }
+}
+

 /* Hand back the physical memory that is allocated to a mega-block. 
    ToDo: chain the released mega block onto some list so that
          getMBlocks() can get at it.
 /* Hand back the physical memory that is allocated to a mega-block. 
    ToDo: chain the released mega block onto some list so that
          getMBlocks() can get at it.