From 1abbd1656db9feef08d7ba3a27360d24148d142d Mon Sep 17 00:00:00 2001
From: Hamish Mackenzie <Hamish.Mackenzie@iohk.io>
Date: Fri, 19 Mar 2021 17:01:45 +1300
Subject: [PATCH] Add GHC 8.10 Make markLiveObject thread-safe (#1076)

See https://github.com/input-output-hk/haskell.nix/issues/1062
---
 overlays/bootstrap.nix                        |  2 +
 ...-rts-make-markLiveObject-thread-safe.patch | 63 +++++++++++++++++++
 2 files changed, 65 insertions(+)
 create mode 100644 overlays/patches/ghc/ghc-8.10.3-rts-make-markLiveObject-thread-safe.patch

diff --git a/overlays/bootstrap.nix b/overlays/bootstrap.nix
index c08b8023d1..df80eb32da 100644
--- a/overlays/bootstrap.nix
+++ b/overlays/bootstrap.nix
@@ -155,6 +155,8 @@ in {
                 ++ fromUntil "8.10.1" "8.10.3" ./patches/ghc/ghc-8.10-ubxt.patch
                 ++ fromUntil "8.10.3" "8.11"   ./patches/ghc/ghc-8.10.3-ubxt.patch
                 ++ final.lib.optional (versionAtLeast "8.6.4") ./patches/ghc/Cabal-3886.patch
+
+                ++ fromUntil "8.10.3" "8.10.5" ./patches/ghc/ghc-8.10.3-rts-make-markLiveObject-thread-safe.patch
                 ;
         in ({
             ghc844 = final.callPackage ../compiler/ghc {
diff --git a/overlays/patches/ghc/ghc-8.10.3-rts-make-markLiveObject-thread-safe.patch b/overlays/patches/ghc/ghc-8.10.3-rts-make-markLiveObject-thread-safe.patch
new file mode 100644
index 0000000000..1b3bb0e29a
--- /dev/null
+++ b/overlays/patches/ghc/ghc-8.10.3-rts-make-markLiveObject-thread-safe.patch
@@ -0,0 +1,63 @@
+From 96f8e2a47c5e53ae5fb86739aecd27c502e7f121 Mon Sep 17 00:00:00 2001
+From: Ben Gamari <ben@smart-cactus.org>
+Date: Tue, 23 Feb 2021 18:30:48 +0000
+Subject: [PATCH] rts: Make markLiveObject thread-safe
+
+markLiveObject is called by GC worker threads and therefore must be
+thread-safe. This was a rather egregious oversight which the testsuite
+missed.
+
+
+(cherry picked from commit fe28a062e47bd914a6879f2d01ff268983c075ad)
+---
+ rts/CheckUnload.c     | 10 ++++++++--
+ rts/LinkerInternals.h |  2 +-
+ 2 files changed, 9 insertions(+), 3 deletions(-)
+
+diff --git a/rts/CheckUnload.c b/rts/CheckUnload.c
+index 8f834d13fa..345a17cfec 100644
+--- a/rts/CheckUnload.c
++++ b/rts/CheckUnload.c
+@@ -381,11 +381,16 @@ static ObjectCode *findOC(OCSectionIndices *s_indices, const void *addr) {
+ 
+ static bool markObjectLive(void *data STG_UNUSED, StgWord key, const void *value STG_UNUSED) {
+     ObjectCode *oc = (ObjectCode*)key;
+-    if (oc->mark == object_code_mark_bit) {
++
++    // N.B. we may be called by the parallel GC and therefore this must be
++    // thread-safe. To avoid taking the linker_mutex in the fast path
++    // (when the object is already marked) we do an atomic exchange here and
++    // only take the lock in the case that the object is unmarked.
++    if (xchg(&oc->mark, object_code_mark_bit) == object_code_mark_bit) {
+         return true; // for hash table iteration
+     }
+ 
+-    oc->mark = object_code_mark_bit;
++    ACQUIRE_LOCK(&linker_mutex);
+     // Remove from 'old_objects' list
+     if (oc->prev != NULL) {
+         // TODO(osa): Maybe 'prev' should be a pointer to the referencing
+@@ -405,6 +410,7 @@ static bool markObjectLive(void *data STG_UNUSED, StgWord key, const void *value
+         objects->prev = oc;
+     }
+     objects = oc;
++    RELEASE_LOCK(&linker_mutex);
+ 
+     // Mark its dependencies
+     iterHashTable(oc->dependencies, NULL, markObjectLive);
+diff --git a/rts/LinkerInternals.h b/rts/LinkerInternals.h
+index 44fe337802..444849fbac 100644
+--- a/rts/LinkerInternals.h
++++ b/rts/LinkerInternals.h
+@@ -262,7 +262,7 @@ struct _ObjectCode {
+     struct _ObjectCode *next_loaded_object;
+ 
+     // Mark bit
+-    uint8_t mark;
++    StgWord mark;
+ 
+     // Set of dependencies (ObjectCode*) of the object file. Traverse
+     // dependencies using `iterHashTable`.
+-- 
+GitLab
+