blob: fa2bc66795d1f0b94a3e33ec0fd36986bcf8ac8a (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
|
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnliftedFFITypes #-}
import GHC.Prim (StackSnapshot#, ThreadId#)
import GHC.Conc.Sync (ThreadId(..))
import GHC.Stack.CloneStack
import Control.Concurrent
import GHC.Conc
import System.Mem
foreign import ccall "expectStacksToBeEqual" expectStacksToBeEqual:: StackSnapshot# -> ThreadId# -> IO ()
foreign import ccall "expectStackToBeNotDirty" expectStackToBeNotDirty:: StackSnapshot# -> IO ()
-- | Clone the stack of another thread and check it's snapshot for being equal
-- with the live stack.
-- In the meanwhile enforce a garbage collection to ensure that the stack
-- snapshot is still valid afterwards (is not gc'ed while in use).
main :: IO ()
main = do
mVarToBeBlockedOn <- newEmptyMVar
threadId <- forkIO $ immediatelyBlocking mVarToBeBlockedOn
waitUntilBlocked threadId
stackSnapshot <- cloneThreadStack threadId
performMajorGC
let (StackSnapshot stack) = stackSnapshot
let (ThreadId tid#) = threadId
expectStacksToBeEqual stack tid#
expectStackToBeNotDirty stack
immediatelyBlocking :: MVar Int -> IO ()
immediatelyBlocking mVarToBeBlockedOn = do
takeMVar mVarToBeBlockedOn
return ()
waitUntilBlocked :: ThreadId -> IO ()
waitUntilBlocked tid = do
blocked <- isBlocked tid
if blocked
then return ()
else do
threadDelay 100000
waitUntilBlocked tid
isBlocked :: ThreadId -> IO Bool
isBlocked = fmap isThreadStatusBlocked . threadStatus
isThreadStatusBlocked :: ThreadStatus -> Bool
isThreadStatusBlocked (ThreadBlocked _) = True
isThreadStatusBlocked _ = False
|
