|
|
1
|
+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
|
|
|
2
|
+-- Test for deadlocks related to string literal CAFs
|
|
|
3
|
+--
|
|
|
4
|
+-- Thread A enters a shared thunk X, and from X a string literal whose stack
|
|
|
5
|
+-- check fails while another thread B owns X. threadPaused then suspends A's
|
|
|
6
|
+-- work on X. If A still owns the literal, B blocks on it forever (#27272).
|
|
|
7
|
+module Main (main) where
|
|
|
8
|
+
|
|
|
9
|
+import T27272_Lits (asciiLits, utf8Lits)
|
|
|
10
|
+
|
|
|
11
|
+import Control.Concurrent
|
|
|
12
|
+import Control.Exception (evaluate)
|
|
|
13
|
+import Control.Monad
|
|
|
14
|
+import Data.Char (ord)
|
|
|
15
|
+import Data.IORef
|
|
|
16
|
+import GHC.Conc (BlockReason (..), ThreadStatus (..), threadStatus)
|
|
|
17
|
+import GHC.Exts
|
|
|
18
|
+import GHC.IO (IO (..))
|
|
|
19
|
+import System.Exit
|
|
|
20
|
+import System.Timeout
|
|
|
21
|
+#if defined(SELF_CHECK)
|
|
|
22
|
+import GHC.Exts.Heap
|
|
|
23
|
+ (ClosureType (..), GenClosure (..), StgInfoTable (..), getClosureData)
|
|
|
24
|
+#endif
|
|
|
25
|
+
|
|
|
26
|
+-- | Per literal: the gate (0 until A is in X, 1 once it is, 2 once B is in X
|
|
|
27
|
+-- too, 3 once B has claimed X), A's thread id, and for the self check whether
|
|
|
28
|
+-- A was suspended at the literal's stack check.
|
|
|
29
|
+data Gate = Gate (MutableByteArray# RealWorld) (MVar ThreadId) (IORef Bool)
|
|
|
30
|
+
|
|
|
31
|
+newGate :: IO Gate
|
|
|
32
|
+newGate = do
|
|
|
33
|
+ aVar <- newEmptyMVar
|
|
|
34
|
+ suspended <- newIORef False
|
|
|
35
|
+ IO $ \s -> case newByteArray# 8# s of
|
|
|
36
|
+ (# s1, g #) -> case writeIntArray# g 0# 0# s1 of
|
|
|
37
|
+ s2 -> (# s2, Gate g aVar suspended #)
|
|
|
38
|
+
|
|
|
39
|
+readGate :: Gate -> IO Int
|
|
|
40
|
+readGate (Gate g _ _) = IO $ \s -> case atomicReadIntArray# g 0# s of
|
|
|
41
|
+ (# s', n #) -> (# s', I# n #)
|
|
|
42
|
+
|
|
|
43
|
+data Box = Box String
|
|
|
44
|
+
|
|
|
45
|
+-- | Force the boxed string under @n@ one-word return frames. 'lazy' hides
|
|
|
46
|
+-- the strictness in @s@, otherwise the string is evaluated before the call.
|
|
|
47
|
+-- The frames are only one word with -O (see all.T).
|
|
|
48
|
+deepFrames :: Int -> Box -> Int
|
|
|
49
|
+deepFrames 0 (Box s) = case lazy s of
|
|
|
50
|
+ c : _ -> ord c
|
|
|
51
|
+ [] -> -1
|
|
|
52
|
+deepFrames n b = 1 + deepFrames (n - 1) b
|
|
|
53
|
+{-# NOINLINE deepFrames #-}
|
|
|
54
|
+
|
|
|
55
|
+-- | Build the shared thunk X for a literal and return it unevaluated.
|
|
|
56
|
+-- A's path through X only uses inline primops and does not allocate: any
|
|
|
57
|
+-- return to the scheduler would claim X for A. The spin is bounded because it
|
|
|
58
|
+-- holds up GC syncs.
|
|
|
59
|
+mkShared :: Gate -> String -> IO String
|
|
|
60
|
+mkShared gate@(Gate g _ _) lit = return x
|
|
|
61
|
+ where
|
|
|
62
|
+ x = runRW# (\s0 -> case fetchAddIntArray# g 0# 1# s0 of
|
|
|
63
|
+ (# s1, 0# #) -> case spin 100000000# s1 of (# _, () #) -> lit
|
|
|
64
|
+ (# s1, _ #) -> case claimX gate lit of
|
|
|
65
|
+ IO m -> case m s1 of (# _, r #) -> r)
|
|
|
66
|
+ spin :: Int# -> State# RealWorld -> (# State# RealWorld, () #)
|
|
|
67
|
+ spin 0# s = (# s, () #)
|
|
|
68
|
+ spin n s = case atomicReadIntArray# g 0# s of
|
|
|
69
|
+ (# s', 3# #) -> (# s', () #)
|
|
|
70
|
+ (# s', _ #) -> spin (n -# 1#) s'
|
|
|
71
|
+{-# NOINLINE mkShared #-}
|
|
|
72
|
+
|
|
|
73
|
+-- | B's part of the gate. The yield calls threadPaused, which claims X for B,
|
|
|
74
|
+-- and B only enters the literal once A is blocked (suspended) or done.
|
|
|
75
|
+-- It is OPAQUE and returns the literal, so X saves nothing across the call:
|
|
|
76
|
+-- X's stack check stays small enough for the literal's check to fail.
|
|
|
77
|
+claimX :: Gate -> String -> IO String
|
|
|
78
|
+claimX (Gate g aVar suspended) lit = do
|
|
|
79
|
+ yield
|
|
|
80
|
+ IO $ \s -> (# atomicWriteIntArray# g 0# 3# s, () #)
|
|
|
81
|
+ a <- readMVar aVar
|
|
|
82
|
+ let waitA = do
|
|
|
83
|
+ st <- threadStatus a
|
|
|
84
|
+ case st of
|
|
|
85
|
+ ThreadRunning -> yield >> waitA
|
|
|
86
|
+ ThreadBlocked BlockedOnBlackHole ->
|
|
|
87
|
+ writeIORef suspended =<< suspendedAtCheck lit
|
|
|
88
|
+ _ -> return ()
|
|
|
89
|
+ waitA
|
|
|
90
|
+ return lit
|
|
|
91
|
+{-# OPAQUE claimX #-}
|
|
|
92
|
+
|
|
|
93
|
+-- Self check of the test, enabled with -DSELF_CHECK -package ghc-heap: fail
|
|
|
94
|
+-- if no literal entry was suspended at the literal's own stack check, i.e. if
|
|
|
95
|
+-- the test did not exercise the bug. The literal is then still unevaluated.
|
|
|
96
|
+suspendedAtCheck :: String -> IO Bool
|
|
|
97
|
+selfCheck :: [Bool] -> IO ()
|
|
|
98
|
+#if defined(SELF_CHECK)
|
|
|
99
|
+suspendedAtCheck lit = do
|
|
|
100
|
+ c <- getClosureData lit
|
|
|
101
|
+ return $ case c of
|
|
|
102
|
+ ThunkClosure { info = i } -> tipe i == THUNK_STATIC
|
|
|
103
|
+ _ -> False
|
|
|
104
|
+selfCheck results =
|
|
|
105
|
+ unless (or results) $ failWith "no literal entry was suspended"
|
|
|
106
|
+#else
|
|
|
107
|
+suspendedAtCheck _ = return False
|
|
|
108
|
+selfCheck _ = return ()
|
|
|
109
|
+#endif
|
|
|
110
|
+
|
|
|
111
|
+failWith :: String -> IO a
|
|
|
112
|
+failWith msg = putStrLn msg >> exitFailure
|
|
|
113
|
+
|
|
|
114
|
+main :: IO ()
|
|
|
115
|
+main = do
|
|
|
116
|
+ let expect c fmt = [ (c, c : shows i fmt) | i <- [0 :: Int ..] ]
|
|
|
117
|
+ lits = zip3 [0 ..] asciiLits (expect 'A' "-ABCDEFGHIJKLMNOPQRSTUVWXYZ") ++
|
|
|
118
|
+ zip3 [0 ..] utf8Lits (expect 'U' "-λμν-ÄÖÜ-€")
|
|
|
119
|
+ -- Literal d is entered under d frames. With the stack sizes from all.T this
|
|
|
120
|
+ -- crosses stack chunk ends, so the literal's stack check fails for some d.
|
|
|
121
|
+ results <- forM lits $ \(d, lit, (c, e)) -> do
|
|
|
122
|
+ gate@(Gate _ aVar suspended) <- newGate
|
|
|
123
|
+ x <- mkShared gate lit
|
|
|
124
|
+ doneA <- newEmptyMVar
|
|
|
125
|
+ doneB <- newEmptyMVar
|
|
|
126
|
+ -- New threads for each literal, so that A's stack only depends on d. A and
|
|
|
127
|
+ -- B have their own capabilities (-N3), so that B runs while A spins.
|
|
|
128
|
+ a <- forkOn 1 $ do
|
|
|
129
|
+ v <- evaluate (deepFrames d (Box x))
|
|
|
130
|
+ putMVar doneA (v == d + ord c && x == e)
|
|
|
131
|
+ putMVar aVar a
|
|
|
132
|
+ _ <- forkOn 2 $ do
|
|
|
133
|
+ -- B must only enter X once A is in it
|
|
|
134
|
+ let waitA = do
|
|
|
135
|
+ n <- readGate gate
|
|
|
136
|
+ when (n == 0) (yield >> waitA)
|
|
|
137
|
+ waitA
|
|
|
138
|
+ _ <- evaluate x
|
|
|
139
|
+ putMVar doneB ()
|
|
|
140
|
+ -- With the bug, A blocks on X and B on the literal: the timeout catches it
|
|
|
141
|
+ r <- timeout 10000000 (takeMVar doneA <* takeMVar doneB)
|
|
|
142
|
+ case r of
|
|
|
143
|
+ Just True -> readIORef suspended
|
|
|
144
|
+ Just False -> failWith ("wrong result at depth " ++ show d)
|
|
|
145
|
+ Nothing -> failWith ("deadlock at depth " ++ show d)
|
|
|
146
|
+ selfCheck results |