|
|
1
|
+{-# OPTIONS_GHC -fno-full-laziness -fno-worker-wrapper #-}
|
|
|
2
|
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
|
|
|
3
|
+
|
|
|
4
|
+-- This test checks that the auto-apply code (stg_ap_0_fast, stg_ap_p) is robust
|
|
|
5
|
+-- against another thread or the GC evaluating a closure at the same time.
|
|
|
6
|
+
|
|
|
7
|
+module Main
|
|
|
8
|
+ -- (main)
|
|
|
9
|
+where
|
|
|
10
|
+
|
|
|
11
|
+import Control.Monad
|
|
|
12
|
+import Control.Concurrent
|
|
|
13
|
+import System.IO
|
|
|
14
|
+import GHC.Data.SmallArray
|
|
|
15
|
+import GHC.Exts
|
|
|
16
|
+import GHC.IO
|
|
|
17
|
+
|
|
|
18
|
+type Arr = SmallMutableArray RealWorld (Int->Int)
|
|
|
19
|
+
|
|
|
20
|
+io :: (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
|
|
|
21
|
+io f = IO f
|
|
|
22
|
+
|
|
|
23
|
+io_ :: (State# RealWorld -> State# RealWorld ) -> IO ()
|
|
|
24
|
+io_ f = IO (\s -> case f s of s2 -> (# s2, () #))
|
|
|
25
|
+
|
|
|
26
|
+{-# NOINLINE readSmallArray #-}
|
|
|
27
|
+readSmallArray (SmallMutableArray arr) (I# idx) = IO $ \s -> case readSmallArray# arr idx s of
|
|
|
28
|
+ (# s2, r #) -> (# s2, r #)
|
|
|
29
|
+
|
|
|
30
|
+-- Continually overwrites the array with unevaluated thunks that will evaluated to
|
|
|
31
|
+-- a PAP under profiling.
|
|
|
32
|
+{-# NOINLINE mkThunks #-}
|
|
|
33
|
+mkThunks :: Arr -> IO ()
|
|
|
34
|
+mkThunks arr = do
|
|
|
35
|
+ forever $ do
|
|
|
36
|
+ yield
|
|
|
37
|
+ forM_ [0..100] $ \_j -> do
|
|
|
38
|
+ forM_ [0..5 :: Int] $ \i -> do
|
|
|
39
|
+ -- With profiling results in a thunk that will evaluate to a PAP capturing the SCC
|
|
|
40
|
+ let g = {-# SCC g #-} succ
|
|
|
41
|
+ io_ (writeSmallArray arr i g)
|
|
|
42
|
+
|
|
|
43
|
+-- Evaluate the array repeatedly in the given order.
|
|
|
44
|
+{-# NOINLINE evaluateThunks #-}
|
|
|
45
|
+evaluateThunks :: Arr -> [Int] -> IO ()
|
|
|
46
|
+evaluateThunks arr idxs = do
|
|
|
47
|
+ forever $ do
|
|
|
48
|
+ yield
|
|
|
49
|
+ -- putStr "." >> hFlush stdout
|
|
|
50
|
+ forM [0..5000::Int] $ \j -> do
|
|
|
51
|
+ forM_ idxs $ \i -> do
|
|
|
52
|
+ !g <- readSmallArray arr i
|
|
|
53
|
+ seq (g i) (pure ())
|
|
|
54
|
+
|
|
|
55
|
+main :: IO ()
|
|
|
56
|
+main = do
|
|
|
57
|
+ -- We spawn three threads. Two are evaluating the thunks in the array in opposite directions
|
|
|
58
|
+ -- One thread is
|
|
|
59
|
+ arr <- io (newSmallArray 6 (id))
|
|
|
60
|
+ _ <- forkIO $ do
|
|
|
61
|
+ evaluateThunks arr [0..5]
|
|
|
62
|
+ _ <- forkIO $ do
|
|
|
63
|
+ evaluateThunks arr [5,4..0]
|
|
|
64
|
+ forkIO $ mkThunks arr
|
|
|
65
|
+ threadDelay 30_000_000 |