Cmm: fix sinking after suspendThread

Suppose a safe call: myCall(x,y,z)

It is lowered into three unsafe calls in Cmm:

  r = suspendThread(...);
  myCall(x,y,z);
  resumeThread(r);

Consider the following situation for myCall arguments:

  x = Sp[..] -- stack
  y = Hp[..] -- heap
  z = R1     -- global register
  r = suspendThread(...);
  myCall(x,y,z);
  resumeThread(r);

The sink pass assumes that unsafe calls clobber memory (heap and stack),
hence x and y assignments are not sunk after `suspendThread`. The sink
pass also correctly handles global register clobbering for all unsafe
calls, except `suspendThread`!

`suspendThread` is special because it releases the capability the thread
is running on. Hence the sink pass must also take into account global
registers that are mapped into memory (in the capability).

In the example above, we could get:

  r = suspendThread(...);
  z = R1
  myCall(x,y,z);
  resumeThread(r);

But this transformation isn't valid if R1 is (BaseReg->rR1) as BaseReg
is invalid between suspendThread and resumeThread. This caused argument
corruption at least with the C backend ("unregisterised") in #19237.

Fix #19237

3 files changed, 37 insertions, 0 deletions

diff --git a/testsuite/tests/ffi/should_run/T19237.hs b/testsuite/tests/ffi/should_run/T19237.hs
new file mode 100644
index 0000000000..4080067d01
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T19237.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# OPTIONS_GHC -dno-typeable-binds -O #-}
+
+module Main where
+
+import Control.Monad
+import GHC.Exts
+import Control.Concurrent
+
+foreign import ccall expect_999 :: Int# -> IO ()
+
+main :: IO ()
+main = do
+  _ <- forkIO $ forever $ putStr ""
+  replicateM_ 100000 (baz (# #))
+
+{-# NOINLINE baz #-}
+baz :: (# #) -> IO ()
+baz c = expect_999 (bar c)
+
+{-# NOINLINE bar #-}
+bar :: (# #) -> Int#
+bar (# #) = 999#
diff --git a/testsuite/tests/ffi/should_run/T19237_c.c b/testsuite/tests/ffi/should_run/T19237_c.c
new file mode 100644
index 0000000000..a052d72113
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T19237_c.c
@@ -0,0 +1,9 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+void expect_999(int p) {
+    if (p != 999) {
+        printf("Error: received %d\n",p);
+        exit(1);
+    }
+}
diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T
index 3116946d29..f4950cf7ca 100644
--- a/testsuite/tests/ffi/should_run/all.T
+++ b/testsuite/tests/ffi/should_run/all.T
@@ -229,3 +229,5 @@ test('IncallAffinity',
       when(unregisterised(), skip)],
      compile_and_run,
      ['IncallAffinity_c.c -no-hs-main'])
+
+test('T19237', normal, compile_and_run, ['T19237_c.c'])