Add -single-threaded flag to force single threaded rts

This is the small part of implementing
https://github.com/ghc-proposals/ghc-proposals/pull/240

9 files changed, 41 insertions, 3 deletions

diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 2cf7072940..2ad09bc7c6 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -2081,6 +2081,7 @@ dynamic_flags_deps = [
          return d)
   , make_ord_flag defGhcFlag "debug"          (NoArg (addWayDynP WayDebug))
   , make_ord_flag defGhcFlag "threaded"       (NoArg (addWayDynP WayThreaded))
+  , make_ord_flag defGhcFlag "single-threaded" (NoArg (removeWayDynP WayThreaded))
 
   , make_ord_flag defGhcFlag "ticky"
       (NoArg (setGeneralFlag Opt_Ticky >> addWayDynP WayDebug))
@@ -2089,7 +2090,7 @@ dynamic_flags_deps = [
     -- is required to get the RTS ticky support.
 
         ----- Linker --------------------------------------------------------
-  , make_ord_flag defGhcFlag "static"         (NoArg removeWayDyn)
+  , make_ord_flag defGhcFlag "static"         (NoArg (removeWayDynP WayDyn))
   , make_ord_flag defGhcFlag "dynamic"        (NoArg (addWayDynP WayDyn))
   , make_ord_flag defGhcFlag "rdynamic" $ noArg $
 #if defined(linux_HOST_OS)
@@ -4187,8 +4188,8 @@ addWay' w dflags0 =
                        (wayUnsetGeneralFlags platform w)
    in dflags3
 
-removeWayDyn :: DynP ()
-removeWayDyn = upd (\dfs -> dfs { targetWays_ = removeWay WayDyn (targetWays_ dfs) })
+removeWayDynP :: Way -> DynP ()
+removeWayDynP w = upd (\dfs -> dfs { targetWays_ = removeWay w (targetWays_ dfs) })
 
 --------------------------
 setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()
diff --git a/docs/users_guide/phases.rst b/docs/users_guide/phases.rst
index 8d0c32f5c1..f60ee30709 100644
--- a/docs/users_guide/phases.rst
+++ b/docs/users_guide/phases.rst
@@ -1076,6 +1076,7 @@ for example).
     :shortdesc: Use the threaded runtime
     :type: dynamic
     :category: linking
+    :reverse: -single-threaded
 
     Link the program with the "threaded" version of the runtime system.
     The threaded runtime system is so-called because it manages multiple
@@ -1099,6 +1100,16 @@ for example).
        called from multiple OS threads simultaneously. See
        :ref:`ffi-threads`.
 
+.. ghc-flag:: -single-threaded
+    :shortdesc: Use the single-threaded runtime
+    :type: dynamic
+    :category: linking
+    :reverse: -threaded
+
+    :since: 9.8
+
+    Switch to the single threaded (default) version of the runtime.
+
 .. ghc-flag:: -eventlog
     :shortdesc: Enable runtime event tracing
     :type: dynamic
diff --git a/testsuite/tests/rts/T22795a.hs b/testsuite/tests/rts/T22795a.hs
new file mode 100644
index 0000000000..0605d93fb3
--- /dev/null
+++ b/testsuite/tests/rts/T22795a.hs
@@ -0,0 +1,6 @@
+module Main (main) where
+
+import System.Posix.Internals (hostIsThreaded)
+
+main :: IO ()
+main = print hostIsThreaded
diff --git a/testsuite/tests/rts/T22795a.stdout b/testsuite/tests/rts/T22795a.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/rts/T22795a.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/rts/T22795b.hs b/testsuite/tests/rts/T22795b.hs
new file mode 100644
index 0000000000..0605d93fb3
--- /dev/null
+++ b/testsuite/tests/rts/T22795b.hs
@@ -0,0 +1,6 @@
+module Main (main) where
+
+import System.Posix.Internals (hostIsThreaded)
+
+main :: IO ()
+main = print hostIsThreaded
diff --git a/testsuite/tests/rts/T22795b.stdout b/testsuite/tests/rts/T22795b.stdout
new file mode 100644
index 0000000000..bc59c12aa1
--- /dev/null
+++ b/testsuite/tests/rts/T22795b.stdout
@@ -0,0 +1 @@
+False
diff --git a/testsuite/tests/rts/T22795c.hs b/testsuite/tests/rts/T22795c.hs
new file mode 100644
index 0000000000..0605d93fb3
--- /dev/null
+++ b/testsuite/tests/rts/T22795c.hs
@@ -0,0 +1,6 @@
+module Main (main) where
+
+import System.Posix.Internals (hostIsThreaded)
+
+main :: IO ()
+main = print hostIsThreaded
diff --git a/testsuite/tests/rts/T22795c.stdout b/testsuite/tests/rts/T22795c.stdout
new file mode 100644
index 0000000000..bc59c12aa1
--- /dev/null
+++ b/testsuite/tests/rts/T22795c.stdout
@@ -0,0 +1 @@
+False
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index 7846bbb191..2bf9ac2f37 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -568,3 +568,8 @@ test('decodeMyStack_emptyListForMissingFlag',
   , ignore_stderr
   , js_broken(22261) # cloneMyStack# not yet implemented
   ], compile_and_run, [''])
+
+# Skip for JS platform as the JS RTS is always single threaded
+test('T22795a', [js_skip], compile_and_run, ['-threaded'])
+test('T22795b', [js_skip], compile_and_run, ['-single-threaded'])
+test('T22795c', [js_skip], compile_and_run, ['-threaded -single-threaded'])