Fix #16525: ObjectCode freed wrongly because of lack of info header check

`checkUnload` currently doesn't check the info header of static objects.
Thus, it may free an `ObjectCode` struct wrongly even if there's still a
live static object whose info header lies in a mapped section of that
`ObjectCode`. This fixes the issue by adding an appropriate check.

8 files changed, 34 insertions, 1 deletions

diff --git a/rts/CheckUnload.c b/rts/CheckUnload.c
index 0af9f464a1..f658d2c73d 100644
--- a/rts/CheckUnload.c
+++ b/rts/CheckUnload.c
@@ -404,6 +404,7 @@ void checkUnload (StgClosure *static_objects)
       p = UNTAG_STATIC_LIST_PTR(p);
       checkAddress(addrs, p, s_indices);
       info = get_itbl(p);
+      checkAddress(addrs, info, s_indices);
       link = *STATIC_LINK(info, p);
   }
 
diff --git a/rts/Linker.c b/rts/Linker.c
index 6f0ba58abb..9fb91bf3ca 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -1185,11 +1185,17 @@ void freeObjectCode (ObjectCode *oc)
                            oc->sections[i].mapped_size);
                     break;
                 case SECTION_M32:
+                    IF_DEBUG(sanity,
+                        memset(oc->sections[i].start,
+                            0x00, oc->sections[i].size));
                     m32_free(oc->sections[i].start,
                              oc->sections[i].size);
                     break;
 #endif
                 case SECTION_MALLOC:
+                    IF_DEBUG(sanity,
+                        memset(oc->sections[i].start,
+                            0x00, oc->sections[i].size));
                     stgFree(oc->sections[i].start);
                     break;
                 default:
diff --git a/rts/linker/M32Alloc.c b/rts/linker/M32Alloc.c
index 52b182e54d..33c4335286 100644
--- a/rts/linker/M32Alloc.c
+++ b/rts/linker/M32Alloc.c
@@ -24,7 +24,7 @@ Note [Compile Time Trickery]
 This file implements two versions of each of the `m32_*` functions. At the top
 of the file there is the real implementation (compiled in when
 `RTS_LINKER_USE_MMAP` is true) and a dummy implementation that exists only to
-satisfy the compiler and which hould never be called. If any of these dummy
+satisfy the compiler and which should never be called. If any of these dummy
 implementations are called the program will abort.
 
 The rationale for this is to allow the calling code to be written without using
diff --git a/testsuite/tests/ghci/T16525a/A.hs b/testsuite/tests/ghci/T16525a/A.hs
new file mode 100644
index 0000000000..dc4ced10cb
--- /dev/null
+++ b/testsuite/tests/ghci/T16525a/A.hs
@@ -0,0 +1,12 @@
+module A where
+
+import B
+
+myIntVal :: Int
+myIntVal = sum [1,2,3,4]
+
+value :: [Value]
+value = [Value "a;lskdfa;lszkfsd;alkfjas" myIntVal]
+
+v1 :: Value -> String
+v1 (Value a _) = a
diff --git a/testsuite/tests/ghci/T16525a/B.hs b/testsuite/tests/ghci/T16525a/B.hs
new file mode 100644
index 0000000000..7be77cb1b6
--- /dev/null
+++ b/testsuite/tests/ghci/T16525a/B.hs
@@ -0,0 +1,3 @@
+module B where
+
+data Value = Value String Int
diff --git a/testsuite/tests/ghci/T16525a/T16525a.script b/testsuite/tests/ghci/T16525a/T16525a.script
new file mode 100644
index 0000000000..d48cfd0f2d
--- /dev/null
+++ b/testsuite/tests/ghci/T16525a/T16525a.script
@@ -0,0 +1,6 @@
+:set -fobject-code
+:load A
+import Control.Concurrent
+_ <- forkIO $ threadDelay 1000000 >> (print (map v1 value))
+:l []
+System.Mem.performGC
diff --git a/testsuite/tests/ghci/T16525a/T16525a.stdout b/testsuite/tests/ghci/T16525a/T16525a.stdout
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/testsuite/tests/ghci/T16525a/T16525a.stdout
diff --git a/testsuite/tests/ghci/T16525a/all.T b/testsuite/tests/ghci/T16525a/all.T
new file mode 100644
index 0000000000..6fbd3e8a4f
--- /dev/null
+++ b/testsuite/tests/ghci/T16525a/all.T
@@ -0,0 +1,5 @@
+test('T16525a',
+     [extra_files(['A.hs', 'B.hs', ]),
+      extra_run_opts('+RTS -DS -RTS'),
+      when(ghc_dynamic(), skip), ],
+     ghci_script, ['T16525a.script'])