From 6685444335fe57d5d86b61965989e45f34fddf0e Mon Sep 17 00:00:00 2001
From: Simon Marlow <marlowsd@gmail.com>
Date: Tue, 1 Mar 2011 10:32:46 +0000
Subject: [PATCH] add threadCapability :: ThreadId -> IO (Int,Bool)

-- | returns the number of the capability on which the thread is currently
-- running, and a boolean indicating whether the thread is locked to
-- that capability or not.  A thread is locked to a capability if it
-- was created with @forkOnIO@.
---
 GHC/Conc.lhs      |    1 +
 GHC/Conc/Sync.lhs |   12 +++++++++++-
 2 files changed, 12 insertions(+), 1 deletion(-)

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 1b5ff7e..1332fca 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -48,6 +48,7 @@ module GHC.Conc
 
         , ThreadStatus(..), BlockReason(..)
         , threadStatus  -- :: ThreadId -> IO ThreadStatus
+        , threadCapability
 
         -- * Waiting
         , threadDelay           -- :: Int -> IO ()
diff --git a/GHC/Conc/Sync.lhs b/GHC/Conc/Sync.lhs
index abad130..370bfd9 100644
--- a/GHC/Conc/Sync.lhs
+++ b/GHC/Conc/Sync.lhs
@@ -56,6 +56,7 @@ module GHC.Conc.Sync
 
         , ThreadStatus(..), BlockReason(..)
         , threadStatus  -- :: ThreadId -> IO ThreadStatus
+        , threadCapability
 
         -- * TVars
         , STM(..)
@@ -426,7 +427,7 @@ data ThreadStatus
 threadStatus :: ThreadId -> IO ThreadStatus
 threadStatus (ThreadId t) = IO $ \s ->
    case threadStatus# t s of
-    (# s', stat, _cap #) -> (# s', mk_stat (I# stat) #)
+    (# s', stat, _cap, _locked #) -> (# s', mk_stat (I# stat) #)
    where
         -- NB. keep these in sync with includes/Constants.h
      mk_stat 0  = ThreadRunning
@@ -439,6 +440,15 @@ threadStatus (ThreadId t) = IO $ \s ->
      mk_stat 16 = ThreadFinished
      mk_stat 17 = ThreadDied
      mk_stat _  = ThreadBlocked BlockedOnOther
+
+-- | returns the number of the capability on which the thread is currently
+-- running, and a boolean indicating whether the thread is locked to
+-- that capability or not.  A thread is locked to a capability if it
+-- was created with @forkOnIO@.
+threadCapability :: ThreadId -> IO (Int, Bool)
+threadCapability (ThreadId t) = IO $ \s ->
+   case threadStatus# t s of
+     (# s', _, cap#, locked# #) -> (# s', (I# cap#, locked# /=# 0#) #)
 \end{code}
 
 
-- 
1.7.10.4