[commit: ghc] ghc-8.4: storageAddCapabilities: fix bug in updating nursery pointers (31d3806)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.4
Link       : http://ghc.haskell.org/trac/ghc/changeset/31d38067c9f15ebdc1c338ca34fc994d8412ae92/ghc

>---------------------------------------------------------------

commit 31d38067c9f15ebdc1c338ca34fc994d8412ae92
Author: Simon Marlow <smarlow at fb.com>
Date:   Fri Apr 27 11:31:19 2018 -0700

    storageAddCapabilities: fix bug in updating nursery pointers
    
    Summary:
    We were unconditionally updating the nursery pointers to be
    `nurseries[cap->no]`, but when using nursery chunks this might be
    wrong. This manifested as a later assertion failure in allocate().
    
    Test Plan: new test case
    
    Reviewers: bgamari, niteria, erikd
    
    Subscribers: thomie, carter
    
    Differential Revision: https://phabricator.haskell.org/D4649
    
    (cherry picked from commit 4cb5595e5e800818721a623a5419cad29a528000)


>---------------------------------------------------------------

31d38067c9f15ebdc1c338ca34fc994d8412ae92
 rts/sm/Storage.c                       |  7 +++++--
 testsuite/tests/rts/all.T              |  7 +++++++
 testsuite/tests/rts/nursery-chunks1.hs | 12 ++++++++++++
 3 files changed, 24 insertions(+), 2 deletions(-)

diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c
index e801c34..c6e1cb4 100644
--- a/rts/sm/Storage.c
+++ b/rts/sm/Storage.c
@@ -224,6 +224,7 @@ initStorage (void)
 void storageAddCapabilities (uint32_t from, uint32_t to)
 {
     uint32_t n, g, i, new_n_nurseries;
+    nursery *old_nurseries;
 
     if (RtsFlags.GcFlags.nurseryChunkSize == 0) {
         new_n_nurseries = to;
@@ -233,6 +234,7 @@ void storageAddCapabilities (uint32_t from, uint32_t to)
             stg_max(to, total_alloc / RtsFlags.GcFlags.nurseryChunkSize);
     }
 
+    old_nurseries = nurseries;
     if (from > 0) {
         nurseries = stgReallocBytes(nurseries,
                                     new_n_nurseries * sizeof(struct nursery_),
@@ -244,8 +246,9 @@ void storageAddCapabilities (uint32_t from, uint32_t to)
 
     // we've moved the nurseries, so we have to update the rNursery
     // pointers from the Capabilities.
-    for (i = 0; i < to; i++) {
-        capabilities[i]->r.rNursery = &nurseries[i];
+    for (i = 0; i < from; i++) {
+        uint32_t index = capabilities[i]->r.rNursery - old_nurseries;
+        capabilities[i]->r.rNursery = &nurseries[index];
     }
 
     /* The allocation area.  Policy: keep the allocation area
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index 7c5b9c7..9e2a6ac 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -382,3 +382,10 @@ test('T12903', [when(opsys('mingw32'), skip)], compile_and_run, [''])
 test('T13832', exit_code(1), compile_and_run, ['-threaded'])
 test('T13894', normal, compile_and_run, [''])
 test('T14497', normal, compile_and_run, ['-O'])
+
+test('nursery-chunks1',
+  [ extra_run_opts('4 100 +RTS -n32k -A1m -RTS')
+  , only_ways(['threaded1','threaded2'])
+  ],
+  compile_and_run,
+  [''])
diff --git a/testsuite/tests/rts/nursery-chunks1.hs b/testsuite/tests/rts/nursery-chunks1.hs
new file mode 100644
index 0000000..f8f9f6a
--- /dev/null
+++ b/testsuite/tests/rts/nursery-chunks1.hs
@@ -0,0 +1,12 @@
+-- Test for a bug that provoked the following assertion failure:
+-- nursery-chunks1: internal error: ASSERTION FAILED: file rts/sm/Sanity.c, line 903
+module Main (main) where
+
+import Control.Monad
+import System.Environment
+import GHC.Conc
+
+main = do
+  [n,m] <- fmap read <$> getArgs
+  forM_ [1..n] $ \n' ->
+    when (sum [1.. m::Integer] > 0) $ setNumCapabilities (fromIntegral n')