rts: Dump memory map on memory mapping failures

Fixes #20992.

5 files changed, 158 insertions, 0 deletions

diff --git a/rts/Linker.c b/rts/Linker.c
index 6468e7818d..0b24a49979 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -33,6 +33,7 @@
 #include "linker/SymbolExtras.h"
 #include "PathUtils.h"
 #include "CheckUnload.h" // createOCSectionIndices
+#include "MemoryMap.h"
 
 #if !defined(mingw32_HOST_OS)
 #include "posix/Signals.h"
@@ -1106,6 +1107,7 @@ mmap_again:
                  MAP_PRIVATE|tryMap32Bit|fixed|flags, fd, offset);
 
    if (result == MAP_FAILED) {
+       reportMemoryMap();
        sysErrorBelch("mmap %" FMT_Word " bytes at %p",(W_)size,map_addr);
        errorBelch("Try specifying an address with +RTS -xm<addr> -RTS");
        return NULL;
@@ -1128,6 +1130,7 @@ mmap_again:
                fixed = MAP_FIXED;
                goto mmap_again;
 #else
+               reportMemoryMap();
                errorBelch("mmapForLinker: failed to mmap() memory below 2Gb; "
                           "asked for %lu bytes at %p. "
                           "Try specifying an address with +RTS -xm<addr> -RTS",
diff --git a/rts/MemoryMap.c b/rts/MemoryMap.c
new file mode 100644
index 0000000000..67db8b4830
--- /dev/null
+++ b/rts/MemoryMap.c
@@ -0,0 +1,138 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Memory-map dumping.
+ *
+ * This is intended to be used for reporting the process memory-map
+ * in diagnostics when the RTS fails to map a block of memory.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "rts/PosixSource.h"
+#include "Rts.h"
+
+#include <string.h>
+
+#if defined(darwin_HOST_OS)
+#include <mach/mach.h>
+#include <mach/mach_vm.h>
+#include <mach/vm_region.h>
+#include <mach/vm_statistics.h>
+#endif
+
+#include "MemoryMap.h"
+
+#if defined(mingw32_HOST_OS)
+
+void reportMemoryMap() {
+    debugBelch("\nMemory map:\n");
+    uint8_t *addr = NULL;
+    while (true) {
+        MEMORY_BASIC_INFORMATION info;
+        int res = VirtualQuery(addr, &info, sizeof(info));
+        if (!res && GetLastError() == ERROR_INVALID_PARAMETER) {
+            return;
+        } else if (!res) {
+            sysErrorBelch("VirtualQuery failed");
+            return;
+        }
+
+        if (info.State & MEM_FREE) {
+            // free range
+        } else {
+            const char *protection;
+            switch (info.Protect) {
+            case PAGE_EXECUTE:           protection = "--x"; break;
+            case PAGE_EXECUTE_READ:      protection = "r-x"; break;
+            case PAGE_EXECUTE_READWRITE: protection = "rwx"; break;
+            case PAGE_EXECUTE_WRITECOPY: protection = "rcx"; break;
+            case PAGE_NOACCESS:          protection = "---"; break;
+            case PAGE_READONLY:          protection = "r--"; break;
+            case PAGE_READWRITE:         protection = "rw-"; break;
+            case PAGE_WRITECOPY:         protection = "rc-"; break;
+            default:                     protection = "???"; break;
+            }
+
+            const char *type;
+            switch (info.Type) {
+            case MEM_IMAGE:   type = "image"; break;
+            case MEM_MAPPED:  type = "mapped"; break;
+            case MEM_PRIVATE: type = "private"; break;
+            default:          type = "unknown"; break;
+            }
+
+            debugBelch("%08llx-%08llx %8zuK %3s (%s)\n",
+                       (uintptr_t) info.BaseAddress,
+                       (uintptr_t) info.BaseAddress + info.RegionSize,
+                       (size_t) info.RegionSize,
+                       protection, type);
+        }
+        addr = (uint8_t *) info.BaseAddress + info.RegionSize;
+    }
+}
+
+#elif defined(darwin_HOST_OS)
+
+void reportMemoryMap() {
+    // Inspired by MacFUSE /proc implementation
+    debugBelch("\nMemory map:\n");
+    while (true) {
+        vm_size_t vmsize;
+        vm_address_t address;
+        vm_region_basic_info_data_t info;
+        vm_region_flavor_t flavor = VM_REGION_BASIC_INFO;
+        memory_object_name_t object;
+        mach_msg_type_number_t info_count = VM_REGION_BASIC_INFO_COUNT;
+        kern_return_t kr =
+            mach_vm_region(mach_task_self(), &address, &vmsize, flavor,
+                           (vm_region_info_t)&info, &info_count, &object);
+        if (kr == KERN_SUCCESS) {
+            debugBelch("%08lx-%08lx %8zuK %c%c%c/%c%c%c\n",
+                       address, (address + vmsize), (vmsize >> 10),
+                       (info.protection & VM_PROT_READ)        ? 'r' : '-',
+                       (info.protection & VM_PROT_WRITE)       ? 'w' : '-',
+                       (info.protection & VM_PROT_EXECUTE)     ? 'x' : '-',
+                       (info.max_protection & VM_PROT_READ)    ? 'r' : '-',
+                       (info.max_protection & VM_PROT_WRITE)   ? 'w' : '-',
+                       (info.max_protection & VM_PROT_EXECUTE) ? 'x' : '-');
+            address += vmsize;
+        } else if (kr == KERN_INVALID_ADDRESS) {
+            // We presumably reached the end of address space
+            break;
+        } else {
+            debugBelch("  Error: %s\n", mach_error_string(kr));
+            break;
+        }
+    }
+}
+
+#else
+
+// Linux et al.
+void reportMemoryMap() {
+    debugBelch("\nMemory map:\n");
+    FILE *f = fopen("/proc/self/maps", "r");
+    if (f == NULL) {
+        debugBelch("  Could not open /proc/self/maps\n");
+        return;
+    }
+
+    while (true) {
+        char buf[256];
+        size_t n = fread(buf, 1, sizeof(buf)-1, f);
+        if (n <= 0) {
+            debugBelch("  Error: %s\n", strerror(errno));
+            break;
+        }
+        buf[n] = '\0';
+        debugBelch("%s", buf);
+        if (n < sizeof(buf)-1) {
+            break;
+        }
+    }
+    debugBelch("\n");
+    fclose(f);
+}
+
+#endif
diff --git a/rts/MemoryMap.h b/rts/MemoryMap.h
new file mode 100644
index 0000000000..7d2c4a58b1
--- /dev/null
+++ b/rts/MemoryMap.h
@@ -0,0 +1,13 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Memory-map dumping.
+ *
+ * This is intended to be used for reporting the process memory-map
+ * in diagnostics when the RTS fails to map a block of memory.
+ *
+ * ---------------------------------------------------------------------------*/
+
+void reportMemoryMap(void);
+
diff --git a/rts/linker/M32Alloc.c b/rts/linker/M32Alloc.c
index c81cac919c..c09662ed24 100644
--- a/rts/linker/M32Alloc.c
+++ b/rts/linker/M32Alloc.c
@@ -11,6 +11,7 @@
 #include "RtsUtils.h"
 #include "linker/M32Alloc.h"
 #include "LinkerInternals.h"
+#include "MemoryMap.h"
 
 #include <inttypes.h>
 #include <stdlib.h>
@@ -325,6 +326,7 @@ m32_alloc_page(void)
     const size_t map_sz = pgsz * M32_MAP_PAGES;
     uint8_t *chunk = mmapAnonForLinker(map_sz);
     if (! is_okay_address(chunk + map_sz)) {
+      reportMemoryMap();
       barf("m32_alloc_page: failed to allocate pages within 4GB of program text (got %p)", chunk);
     }
     IF_DEBUG(sanity, memset(chunk, 0xaa, map_sz));
@@ -477,6 +479,7 @@ m32_alloc(struct m32_allocator_t *alloc, size_t size, size_t alignment)
           sysErrorBelch("m32_alloc: Failed to map pages for %zd bytes", size);
           return NULL;
       } else if (! is_okay_address(page)) {
+          reportMemoryMap();
           barf("m32_alloc: warning: Allocation of %zd bytes resulted in pages above 4GB (%p)",
                size, page);
       }
diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in
index a2449a5ce5..986d6bf6e0 100644
--- a/rts/rts.cabal.in
+++ b/rts/rts.cabal.in
@@ -493,6 +493,7 @@ library
                Libdw.c
                LibdwPool.c
                Linker.c
+               MemoryMap.c
                Messages.c
                OldARMAtomic.c
                PathUtils.c