[Git][ghc/ghc][master] Fix #16525: ObjectCode freed wrongly because of lack of info header check

[Marge Bot]

 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
fc6b23be by Phuong Trinh at 2019-06-13T06:48:50Z
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 changed files:

- rts/CheckUnload.c
- rts/Linker.c
- rts/linker/M32Alloc.c
- + testsuite/tests/ghci/T16525a/A.hs
- + testsuite/tests/ghci/T16525a/B.hs
- + testsuite/tests/ghci/T16525a/T16525a.script
- + testsuite/tests/ghci/T16525a/T16525a.stdout
- + testsuite/tests/ghci/T16525a/all.T


Changes:

=====================================
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);
   }
 


=====================================
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:


=====================================
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


=====================================
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


=====================================
testsuite/tests/ghci/T16525a/B.hs
=====================================
@@ -0,0 +1,3 @@
+module B where
+
+data Value = Value String Int


=====================================
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


=====================================
testsuite/tests/ghci/T16525a/T16525a.stdout
=====================================


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/fc6b23be509e290f8d27775a1c637284a335ed81

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/fc6b23be509e290f8d27775a1c637284a335ed81
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190613/ac50b91f/attachment-0001.html>