diff options
author | Oleg Grenrus <oleg.grenrus@iki.fi> | 2023-01-18 11:36:45 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-02-15 22:20:57 -0500 |
commit | 26df73fb0d7a5422c209fb4f10d0e2f73f6388aa (patch) | |
tree | 459a2c3560faa516e14f01cb18c80c034315cb9a | |
parent | 9ca51f9e84abc41ba590203d8bc8df8d6af86db2 (diff) | |
download | haskell-26df73fb0d7a5422c209fb4f10d0e2f73f6388aa.tar.gz |
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
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 7 | ||||
-rw-r--r-- | docs/users_guide/phases.rst | 11 | ||||
-rw-r--r-- | testsuite/tests/rts/T22795a.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/rts/T22795a.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/rts/T22795b.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/rts/T22795b.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/rts/T22795c.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/rts/T22795c.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/rts/all.T | 5 |
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']) |