Ticket #1657: threadbug.hs

File threadbug.hs, 2.8 KB (added by guest, 7 years ago)

Test case

Line 
1{-# OPTIONS_GHC -fglasgow-exts #-}
2module Main where
3
4import Control.Concurrent
5import Control.Exception
6import System.IO.Unsafe (unsafeInterleaveIO)
7import Data.Dynamic (Typeable)
8import Data.IORef
9
10delay :: Int
11delay = 10000
12
13runFor :: Int
14runFor = 1000
15
16compute :: Int -> Int -> IO [Int]
17compute max n
18        | n > max = do
19                putStrLn ("# complete!")
20                return []
21        | otherwise = do
22                putStrLn ("# computing " ++ show n)
23                --threadDelay delay
24                ns <- unsafeInterleaveIO $ compute max (n+1)
25                return (n:ns)
26
27data BGState a = BGS
28        { bgsIsRunning          :: MVar ()
29        , bgsIsComplete         :: MVar () -- write-once
30        , bgsResult             :: MVar [a]
31        , bgsSrc                :: IORef [a] -- worker thread only
32        , bgsIter               :: IORef Int -- main thread only
33        }
34
35data Suspend = Suspend Int deriving Typeable
36
37newBGS :: [a] -> IO (BGState a)
38newBGS computation = do
39        isRunning <- newEmptyMVar
40        isComplete <- newEmptyMVar
41        result <- newEmptyMVar
42        src <- newIORef computation
43        iter <- newIORef 0
44       
45        return $ BGS isRunning isComplete result src iter
46
47runBGSFor :: Int -> BGState a -> IO (Maybe [a])
48runBGSFor us state = do
49        done <- tryTakeMVar (bgsIsComplete state)
50        iter <- readIORef (bgsIter state)
51       
52        case (iter, done) of
53                (10,_) -> return Nothing
54                (_,Just ()) -> return Nothing
55                _ -> do
56                        putStrLn "*** starting!"
57                        thread <- forkIO $ runBGSThread state
58                       
59                        -- verify that we are inside "catch" block before
60                        -- advancing further
61                        takeMVar (bgsIsRunning state)
62                       
63                        -- wait
64                        threadDelay us
65               
66                        -- suspend background computation
67                        n <- readIORef (bgsIter state)
68                        modifyIORef (bgsIter state) (+1)
69                        putStrLn ("*** throwing " ++ show n)
70                        throwDynTo thread (Suspend n)
71                        result <- takeMVar (bgsResult state)
72                        return $ Just result
73
74runBGSThread :: BGState a -> IO ()
75runBGSThread state = do
76        computation <- readIORef (bgsSrc state)
77       
78        -- locally we store our results here
79        ans <- newIORef ([], computation)
80       
81        let loop = do
82                (out, inp) <- readIORef ans
83                case inp of
84                        [] -> putMVar (bgsIsComplete state) ()
85                        (x:xs) -> x `seq` (writeIORef ans (x:out, xs) >> loop)
86        let run = do
87                putStrLn "*** running!"
88                putMVar (bgsIsRunning state) ()
89                loop
90        let handler (Suspend n) = do
91                putStrLn ("*** caught " ++ show n)
92                return ()
93       
94        catchDyn run handler
95       
96        -- get the work we've done so far
97        (result, rest) <- readIORef ans
98        writeIORef (bgsSrc state) rest
99       
100        -- write output
101        putMVar (bgsResult state) (reverse result)
102
103main :: IO ()
104main = do
105        computation <- unsafeInterleaveIO $ compute (10^10) 0
106        bgState <- newBGS computation
107       
108        let iter = do
109                x <- runBGSFor runFor bgState
110                case x of Nothing -> return ()
111                          Just [] -> putStrLn "^ Got  0" >> iter
112                          Just xs -> do
113                                putStrLn ("^ Got  " ++ show (length xs)) 
114                                putStrLn ("^ Last " ++ show (last xs))
115                                iter
116        iter