[commit: ghc] master: Fix a bug introduced with allocation counters (2a6f193)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/2a6f193bb82f88e8dcb919ee7affc13feae56e98/ghc

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

commit 2a6f193bb82f88e8dcb919ee7affc13feae56e98
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Mon Nov 17 13:03:56 2014 +0000

    Fix a bug introduced with allocation counters


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

2a6f193bb82f88e8dcb919ee7affc13feae56e98
 rts/Schedule.c                            |  3 +++
 testsuite/tests/ffi/should_run/all.T      |  4 ++++
 testsuite/tests/ffi/should_run/ffi023.hs  | 23 +++++++++++++++++++++++
 testsuite/tests/ffi/should_run/ffi023_c.c |  9 +++++++++
 4 files changed, 39 insertions(+)

diff --git a/rts/Schedule.c b/rts/Schedule.c
index c2260f0..e9b0289 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -2233,6 +2233,9 @@ suspendThread (StgRegTable *reg, rtsBool interruptible)
   task->incall->suspended_tso = tso;
   task->incall->suspended_cap = cap;
 
+  // Otherwise allocate() will write to invalid memory.
+  cap->r.rCurrentTSO = NULL
+
   ACQUIRE_LOCK(&cap->lock);
 
   suspendTask(cap,task);
diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T
index 6fe0878..0499631 100644
--- a/testsuite/tests/ffi/should_run/all.T
+++ b/testsuite/tests/ffi/should_run/all.T
@@ -209,3 +209,7 @@ test('T8083',
      compile_and_run,
      ['T8083_c.c'])
 
+test('ffi023', [ omit_ways(['ghci']),
+                extra_clean(['ffi023_c.o']),
+                extra_run_opts('1000 4') ],
+              compile_and_run, ['ffi023_c.c'])
diff --git a/testsuite/tests/ffi/should_run/ffi023.hs b/testsuite/tests/ffi/should_run/ffi023.hs
new file mode 100644
index 0000000..96a6092
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/ffi023.hs
@@ -0,0 +1,23 @@
+-- Tests for a bug fixed in
+
+module Main where
+
+import System.Environment
+import Control.Concurrent
+import Control.Monad
+
+foreign import ccall safe "out"
+  out :: Int -> IO Int
+
+foreign export ccall "incall"  incall :: Int -> IO Int
+
+incall :: Int -> IO Int
+incall x = return $ x + 1
+
+main = do
+  [n, m] <- fmap (fmap read) getArgs
+  ms <- replicateM m $ do
+    v <- newEmptyMVar
+    forkIO $ do mapM out [0..n]; putMVar v ()
+    return v
+  mapM_ takeMVar ms
diff --git a/testsuite/tests/ffi/should_run/ffi023_c.c b/testsuite/tests/ffi/should_run/ffi023_c.c
new file mode 100644
index 0000000..a8a5a15
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/ffi023_c.c
@@ -0,0 +1,9 @@
+#include "ffi023_stub.h"
+#include "HsFFI.h"
+#include "Rts.h"
+
+HsInt out (HsInt x)
+{
+    performMajorGC();
+    return incall(x);
+}