diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2019-10-26 13:08:39 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2022-08-06 11:48:50 -0400 |
| commit | aa818a9f83308d0742e8f8c91cb9878182dacce5 (patch) | |
| tree | 48089b58289212cfdaef065ad7cc21b77c8beaaa /libraries/base/GHC | |
| parent | 7267cd52fb0b06479b9ceea2dc4700d949a1d75b (diff) | |
| download | haskell-aa818a9f83308d0742e8f8c91cb9878182dacce5.tar.gz | |
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.
Diffstat (limited to 'libraries/base/GHC')
| -rw-r--r-- | libraries/base/GHC/Conc.hs | 1 | ||||
| -rw-r--r-- | libraries/base/GHC/Conc/Sync.hs | 23 |
2 files changed, 23 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 |