Add primop to list threads

A user came to #ghc yesterday wondering how best to check whether they
were leaking threads. We ended up using the eventlog but it seems to me
like it would be generally useful if Haskell programs could query their
own threads.

6 files changed, 49 insertions, 1 deletions

diff --git a/libraries/base/GHC/Conc.hs b/libraries/base/GHC/Conc.hs
index 15397422a5..fbb7521860 100644
--- a/libraries/base/GHC/Conc.hs
+++ b/libraries/base/GHC/Conc.hs
@@ -45,6 +45,7 @@ module GHC.Conc
         , yield
         , labelThread
         , mkWeakThreadId
+        , listThreads
 
         , ThreadStatus(..), BlockReason(..)
         , threadStatus
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index 6ae26678aa..bb8d6592b6 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE Unsafe #-}
 
 {-# OPTIONS_HADDOCK not-home #-}
@@ -39,7 +40,7 @@ module GHC.Conc.Sync
         , yield
         , labelThread
         , mkWeakThreadId
-
+        , listThreads
         , ThreadStatus(..), BlockReason(..)
         , threadStatus
         , threadCapability
@@ -536,6 +537,25 @@ runSparks = IO loop
                       then (# s', () #)
                       else p `seq` loop s'
 
+-- | List the Haskell threads of the current process.
+--
+-- @since 4.18
+listThreads :: IO [ThreadId]
+listThreads = IO $ \s ->
+    case listThreads# s of
+      (# s', arr #) ->
+        (# s', mapListArrayUnlifted ThreadId arr #)
+
+mapListArrayUnlifted :: forall (a :: TYPE UnliftedRep) b. (a -> b) -> Array# a -> [b]
+mapListArrayUnlifted f arr = go 0#
+  where
+    sz = sizeofArray# arr
+    go i#
+      | isTrue# (i# ==# sz) = []
+      | otherwise = case indexArray# arr i# of
+                      (# x #) -> f x : go (i# +# 1#)
+{-# NOINLINE mapListArrayUnlifted #-}
+
 data BlockReason
   = BlockedOnMVar
         -- ^blocked on 'MVar'
@@ -575,6 +595,7 @@ data ThreadStatus
            , Show -- ^ @since 4.3.0.0
            )
 
+-- | Query the current execution status of a thread.
 threadStatus :: ThreadId -> IO ThreadStatus
 threadStatus (ThreadId t) = IO $ \s ->
    case threadStatus# t s of
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 06570b5371..8991915db9 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -13,6 +13,8 @@
     [Core Libraries proposal](https://github.com/haskell/core-libraries-committee/issues/65).
   * Add default implementation of `(<>)` in terms of `sconcat` and `mempty` in
     terms of `mconcat`.
+  * `GHC.Conc.Sync.listThreads` was added, allowing the user to list the threads
+    (both running and blocked) of the program.
 
 ## 4.17.0.0 *TBA*
 
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index 69c990e0a2..7f0580b84a 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -273,3 +273,4 @@ test('T19288', exit_code(1), compile_and_run, [''])
 test('T19719', normal, compile_and_run, [''])
 test('T20107', extra_run_opts('+RTS -M50M'), compile_and_run, ['-package bytestring'])
 test('trace', normal, compile_and_run, [''])
+test('listThreads', normal, compile_and_run, [''])
diff --git a/libraries/base/tests/listThreads.hs b/libraries/base/tests/listThreads.hs
new file mode 100644
index 0000000000..00e2178297
--- /dev/null
+++ b/libraries/base/tests/listThreads.hs
@@ -0,0 +1,22 @@
+import Control.Concurrent
+import GHC.Conc.Sync
+
+dummyThread :: MVar () -> Int -> IO ()
+dummyThread mvar n = do
+  tid <- myThreadId
+  labelThread tid ("thread-"++show n)
+  readMVar mvar
+
+main :: IO ()
+main = do
+  mvar <- newEmptyMVar
+  let mkThread n = do
+        tid <- forkIO $ readMVar mvar
+        labelThread tid ("thread-"++show n)
+
+  mapM_ mkThread [0..100]
+  threads <- listThreads
+  -- TODO: Check labels
+  print $ length threads
+  putMVar mvar ()
+
diff --git a/libraries/base/tests/listThreads.stdout b/libraries/base/tests/listThreads.stdout
new file mode 100644
index 0000000000..257e563266
--- /dev/null
+++ b/libraries/base/tests/listThreads.stdout
@@ -0,0 +1 @@
+102