├── .gitignore ├── LICENSE ├── README.markdown ├── Setup.hs ├── Test ├── MiniFu.hs └── MiniFu │ └── Internal.hs ├── examples.hs ├── minifu.cabal ├── stack.yaml └── tutorial ├── 01-writing-a-concurrency-testing-library.markdown └── 02-exceptions.markdown /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Michael Walker 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | MiniFu: Write Your Own Concurrency Testing Library 2 | ================================================== 3 | 4 | This is a tutorial series I am writing about how to make your very own 5 | concurrency testing library in Haskell. It's called "MiniFu" because 6 | the result will be a simpler version of my [Déjà Fu][] library. 7 | 8 | [Déjà Fu]: https://github.com/barrucadu/dejafu 9 | 10 | See the `tutorial` directory for previous articles. 11 | 12 | Tags relate the code to the articles. While the git history should be 13 | fairly clear, jumping between tags is probably the easiest way to 14 | follow along. The tags are: 15 | 16 | 1. [post-01](https://github.com/barrucadu/minifu/tree/post-01): 17 | end of the first post 18 | 2. [homework-01](https://github.com/barrucadu/minifu/tree/homework-01): 19 | homework solution for the first post (`CRef` functions) 20 | 3. [pre-02](https://github.com/barrucadu/minifu/tree/pre-02): 21 | some refactoring and an implementation of `readMVar` 22 | 4. [post-02](https://github.com/barrucadu/minifu/tree/post-02): 23 | end of the second post 24 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Test/MiniFu.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Test.MiniFu 3 | ( module Test.MiniFu 4 | -- * Re-exports 5 | , MiniFu, ThreadId, MVar, CRef, Scheduler 6 | ) where 7 | 8 | import qualified Control.Concurrent.Classy as C 9 | import qualified Control.Exception as E 10 | import qualified Control.Monad.Cont as K 11 | import Data.List.NonEmpty (NonEmpty(..)) 12 | import qualified System.Random as R 13 | 14 | import Test.MiniFu.Internal 15 | 16 | -- | Fork a computation to happen concurrently. 17 | fork :: MiniFu m () -> MiniFu m ThreadId 18 | fork ma = MiniFu (K.cont (Fork ma)) 19 | 20 | -- | Create a new empty @MVar@. 21 | newEmptyMVar :: MiniFu m (MVar m a) 22 | newEmptyMVar = MiniFu (K.cont NewEmptyMVar) 23 | 24 | -- | Put a value into a @MVar@. If there is already a value there, 25 | -- this will block until that value has been taken, at which point the 26 | -- value will be stored. 27 | putMVar :: MVar m a -> a -> MiniFu m () 28 | putMVar v a = MiniFu (K.cont (\k -> PutMVar v a (k ()))) 29 | 30 | -- | Attempt to put a value in a @MVar@ non-blockingly, returning 31 | -- 'True' (and filling the @MVar@) if there was nothing there, 32 | -- otherwise returning 'False'. 33 | tryPutMVar :: MVar m a -> a -> MiniFu m Bool 34 | tryPutMVar v a = MiniFu (K.cont (TryPutMVar v a)) 35 | 36 | -- | Block until a value is present in the @MVar@, and then return 37 | -- it. This does not "remove" the value, multiple reads are possible. 38 | readMVar :: MVar m a -> MiniFu m a 39 | readMVar v = MiniFu (K.cont (ReadMVar v)) 40 | 41 | -- | Attempt to read a value from a @MVar@ non-blockingly, returning a 42 | -- 'Just' if there is something there, otherwise returning 43 | -- 'Nothing'. As with 'readMVar', this does not \"remove\" the value. 44 | tryReadMVar :: MVar m a -> MiniFu m (Maybe a) 45 | tryReadMVar v = MiniFu (K.cont (TryReadMVar v)) 46 | 47 | -- | Take a value from a @MVar@. This "empties" the @MVar@, allowing a 48 | -- new value to be put in. This will block if there is no value in the 49 | -- @MVar@ already, until one has been put. 50 | takeMVar :: MVar m a -> MiniFu m a 51 | takeMVar v = MiniFu (K.cont (TakeMVar v)) 52 | 53 | -- | Attempt to take a value from a @MVar@ non-blockingly, returning a 54 | -- 'Just' (and emptying the @MVar@) if there was something there, 55 | -- otherwise returning 'Nothing'. 56 | tryTakeMVar :: MVar m a -> MiniFu m (Maybe a) 57 | tryTakeMVar v = MiniFu (K.cont (TryTakeMVar v)) 58 | 59 | -- | Create a new reference. 60 | newCRef :: a -> MiniFu m (CRef m a) 61 | newCRef a = MiniFu (K.cont (NewCRef a)) 62 | 63 | -- | Read the current value stored in a reference. 64 | readCRef :: CRef m a -> MiniFu m a 65 | readCRef r = MiniFu (K.cont (ReadCRef r)) 66 | 67 | -- | Write a new value into an @CRef@. 68 | writeCRef :: CRef m a -> a -> MiniFu m () 69 | writeCRef r a = MiniFu (K.cont (\k -> WriteCRef r a (k ()))) 70 | 71 | -- | Atomically modify the value stored in a reference. 72 | atomicModifyCRef :: CRef m a -> (a -> (a, b)) -> MiniFu m b 73 | atomicModifyCRef r f = MiniFu (K.cont (ModifyCRef r f)) 74 | 75 | -- | Throw an exception. This will \"bubble up\" looking for an 76 | -- exception handler capable of dealing with it and, if one is not 77 | -- found, the thread is killed. 78 | throw :: E.Exception e => e -> MiniFu m a 79 | throw e = MiniFu (K.cont (\_ -> Throw e)) 80 | 81 | -- | Catch an exception raised by 'throw'. 82 | catch :: E.Exception e => MiniFu m a -> (e -> MiniFu m a) -> MiniFu m a 83 | catch act h = MiniFu (K.cont (Catch act h)) 84 | 85 | -- | Throw an exception to the target thread. This blocks until the 86 | -- exception is delivered. 87 | throwTo :: E.Exception e => ThreadId -> e -> MiniFu m () 88 | throwTo tid e = MiniFu (K.cont (\k -> ThrowTo tid e (k ()))) 89 | 90 | -- | Executes a computation with asynchronous exceptions masked. That 91 | -- is, any thread which attempts to raise an exception in the current 92 | -- thread with throwTo will be blocked until asynchronous exceptions 93 | -- are unmasked again. 94 | -- 95 | -- The argument passed to mask is a function that takes as its 96 | -- argument another function, which can be used to restore the 97 | -- prevailing masking state within the context of the masked 98 | -- computation. This function should not be used within an 99 | -- 'uninterruptibleMask'. 100 | mask :: ((forall x. MiniFu m x -> MiniFu m x) -> MiniFu m a) -> MiniFu m a 101 | mask ma = MiniFu (K.cont (InMask E.MaskedInterruptible ma)) 102 | 103 | -- | Like mask, but the masked computation is not interruptible. THIS 104 | -- SHOULD BE USED WITH GREAT CARE, because if a thread executing in 105 | -- uninterruptibleMask blocks for any reason, then the thread (and 106 | -- possibly the program, if this is the main thread) will be 107 | -- unresponsive and unkillable. This function should only be necessary 108 | -- if you need to mask exceptions around an interruptible operation, 109 | -- and you can guarantee that the interruptible operation will only 110 | -- block for a short period of time. The supplied unmasking function 111 | -- should not be used within a 'mask'. 112 | uninterruptibleMask :: ((forall x. MiniFu m x -> MiniFu m x) -> MiniFu m a) -> MiniFu m a 113 | uninterruptibleMask ma = MiniFu (K.cont (InMask E.MaskedUninterruptible ma)) 114 | 115 | ------------------------------------------------------------------------------- 116 | 117 | -- | Execute a concurrent computation with a given scheduler, and 118 | -- return the result. 119 | minifu :: C.MonadConc m => Scheduler s -> s -> MiniFu m a -> m (Maybe a, s) 120 | minifu sched s (MiniFu ma) = do 121 | out <- C.newCRef Nothing 122 | s' <- run sched s (K.runCont ma (Stop . C.writeCRef out . Just)) 123 | a <- C.readCRef out 124 | pure (a, s') 125 | 126 | ------------------------------------------------------------------------------- 127 | 128 | -- | A simple random scheduler. 129 | randomSched :: R.RandomGen g => Scheduler g 130 | randomSched (t:|ts) g = 131 | let (i, g') = R.randomR (0, length ts) g 132 | in ((t:ts) !! i, g') 133 | -------------------------------------------------------------------------------- /Test/MiniFu/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Test.MiniFu.Internal where 6 | 7 | import qualified Control.Concurrent.Classy as C 8 | import qualified Control.Exception as E 9 | import Control.Monad (when) 10 | import qualified Control.Monad.Catch as EM 11 | import qualified Control.Monad.Cont as K 12 | import Data.List.NonEmpty (NonEmpty(..), nonEmpty) 13 | import Data.Map (Map) 14 | import qualified Data.Map as M 15 | import Data.Maybe (fromJust, isJust, isNothing) 16 | 17 | -- | Threads are just identified by their creation order. 18 | newtype ThreadId = ThreadId Int 19 | deriving (Eq, Ord) 20 | 21 | -- | A scheduler is a stateful function which chooses a thread to run. 22 | type Scheduler s = NonEmpty ThreadId -> s -> (ThreadId, s) 23 | 24 | -- | A MiniFu computation is just a continuation over primops. 25 | newtype MiniFu m a = MiniFu { runMiniFu :: K.Cont (PrimOp m) a } 26 | deriving (Functor, Applicative, Monad) 27 | 28 | instance EM.MonadThrow (MiniFu m) where 29 | throwM e = MiniFu (K.cont (\_ -> Throw e)) 30 | 31 | instance EM.MonadCatch (MiniFu m) where 32 | catch act h = MiniFu (K.cont (Catch act h)) 33 | 34 | instance EM.MonadMask (MiniFu m) where 35 | mask ma = MiniFu (K.cont (InMask E.MaskedInterruptible ma)) 36 | uninterruptibleMask ma = MiniFu (K.cont (InMask E.MaskedUninterruptible ma)) 37 | 38 | -- | One of the basic actions that a @MonadConc@ can do. 39 | data PrimOp m where 40 | -- threading 41 | Fork :: MiniFu m () -> (ThreadId -> PrimOp m) -> PrimOp m 42 | -- mvars 43 | NewEmptyMVar :: (MVar m a -> PrimOp m) -> PrimOp m 44 | PutMVar :: MVar m a -> a -> PrimOp m -> PrimOp m 45 | ReadMVar :: MVar m a -> (a -> PrimOp m) -> PrimOp m 46 | TakeMVar :: MVar m a -> (a -> PrimOp m) -> PrimOp m 47 | TryPutMVar :: MVar m a -> a -> (Bool -> PrimOp m) -> PrimOp m 48 | TryReadMVar :: MVar m a -> (Maybe a -> PrimOp m) -> PrimOp m 49 | TryTakeMVar :: MVar m a -> (Maybe a -> PrimOp m) -> PrimOp m 50 | -- crefs 51 | NewCRef :: a -> (CRef m a -> PrimOp m) -> PrimOp m 52 | ReadCRef :: CRef m a -> (a -> PrimOp m) -> PrimOp m 53 | WriteCRef :: CRef m a -> a -> PrimOp m -> PrimOp m 54 | ModifyCRef :: CRef m a -> (a -> (a, b)) -> (b -> PrimOp m) -> PrimOp m 55 | -- exceptions 56 | Throw :: E.Exception e => e -> PrimOp m 57 | ThrowTo :: E.Exception e => ThreadId -> e -> PrimOp m -> PrimOp m 58 | Catch :: E.Exception e => MiniFu m a -> (e -> MiniFu m a) -> (a -> PrimOp m) -> PrimOp m 59 | PopH :: PrimOp m -> PrimOp m 60 | Mask :: E.MaskingState -> PrimOp m -> PrimOp m 61 | InMask :: E.MaskingState -> ((forall x. MiniFu m x -> MiniFu m x) -> MiniFu m a) -> (a -> PrimOp m) -> PrimOp m 62 | -- misc 63 | Stop :: m () -> PrimOp m 64 | 65 | -- | @MVar@s have a unique ID too, used in thread blocking. 66 | newtype MVarId = MVarId Int 67 | deriving (Eq, Ord) 68 | 69 | -- | An @MVar@ is a @CRef@ in the underlying monad, holding a maybe 70 | -- value, with a unique identifier. 71 | data MVar m a = MVar 72 | { mvarId :: MVarId 73 | , mvarRef :: C.CRef m (Maybe a) 74 | } 75 | 76 | -- | A @CRef@ just delegates directly to the underlying monad. 77 | newtype CRef m a = CRef { crefRef :: C.CRef m a } 78 | 79 | ------------------------------------------------------------------------------- 80 | 81 | -- | Run a collection of threads to completion. 82 | run :: C.MonadConc m => Scheduler s -> s -> PrimOp m -> m s 83 | run sched s0 = go s0 . initialise where 84 | go s (threads, idsrc) 85 | | initialThreadId `M.member` threads = case runnable threads of 86 | Just tids -> do 87 | let (chosen, s') = sched tids s 88 | (threads', idsrc') <- stepThread chosen (threads, idsrc) 89 | let threads'' = if (isInterruptible <$> M.lookup chosen threads') /= Just False 90 | then unblock (Left chosen) threads' 91 | else threads' 92 | go s' (threads'', idsrc') 93 | Nothing -> pure s 94 | | otherwise = pure s 95 | 96 | runnable = nonEmpty . M.keys . M.filter (isNothing . threadBlock) 97 | 98 | initialThreadId = fst (nextThreadId initialIdSource) 99 | 100 | stepThread :: C.MonadConc m => ThreadId -> (Threads m, IdSource) -> m (Threads m, IdSource) 101 | stepThread tid (threads, idsrc) = case M.lookup tid threads of 102 | Just thrd -> go (threadK thrd) 103 | Nothing -> pure (threads, idsrc) 104 | where 105 | adjust f = M.adjust f tid 106 | goto k = adjust (\thrd -> thrd { threadK = k }) 107 | block v = adjust (\thrd -> thrd { threadBlock = Just v }) 108 | simple f = pure (f threads, idsrc) 109 | 110 | go (Fork (MiniFu ma) k) = 111 | let (tid', idsrc') = nextThreadId idsrc 112 | thrd' = thread (K.runCont ma (\_ -> Stop (pure ()))) 113 | in pure (goto (k tid') (M.insert tid' thrd' threads), idsrc') 114 | go (NewEmptyMVar k) = do 115 | ref <- C.newCRef Nothing 116 | let (mvid, idsrc') = nextMVarId idsrc 117 | pure (goto (k (MVar mvid ref)) threads, idsrc') 118 | go (PutMVar mvar a k) = 119 | simple . ($tid) =<< putIntoMVar Blocking mvar a (const k) 120 | go (TakeMVar mvar k) = 121 | simple . ($tid) =<< seeIntoMVar Blocking Emptying mvar (k . fromJust) 122 | go (ReadMVar mvar k) = 123 | simple . ($tid) =<< seeIntoMVar Blocking NonEmptying mvar (k . fromJust) 124 | go (TryPutMVar mvar a k) = 125 | simple . ($tid) =<< putIntoMVar NonBlocking mvar a k 126 | go (TryTakeMVar mvar k) = 127 | simple . ($tid) =<< seeIntoMVar NonBlocking Emptying mvar k 128 | go (TryReadMVar mvar k) = 129 | simple . ($tid) =<< seeIntoMVar NonBlocking NonEmptying mvar k 130 | go (NewCRef a k) = do 131 | ref <- C.newCRef a 132 | simple (goto (k (CRef ref))) 133 | go (ReadCRef (CRef ref) k) = do 134 | cur <- C.readCRef ref 135 | simple (goto (k cur)) 136 | go (WriteCRef (CRef ref) a k) = do 137 | C.writeCRef ref a 138 | simple (goto k) 139 | go (ModifyCRef (CRef ref) f k) = do 140 | new <- C.atomicModifyCRef ref f 141 | simple (goto (k new)) 142 | go (Throw e) = 143 | simple (M.update (raise e) tid) 144 | go (ThrowTo threadid e k) = simple $ case M.lookup threadid threads of 145 | Just t 146 | | isInterruptible t -> goto k . M.update (raise e) threadid 147 | | otherwise -> block (Left threadid) 148 | Nothing -> goto k 149 | go (Catch (MiniFu ma) h k) = simple . adjust $ \thrd -> thrd 150 | { threadK = K.runCont ma (PopH . k) 151 | , threadExc = 152 | let ms0 = threadMask thrd 153 | h' exc = flip K.runCont k $ do 154 | K.cont (\c -> Mask ms0 (c ())) 155 | runMiniFu (h exc) 156 | in Handler h' : threadExc thrd 157 | } 158 | go (PopH k) = simple . adjust $ \thrd -> thrd 159 | { threadK = k 160 | , threadExc = tail (threadExc thrd) 161 | } 162 | go (Mask ms k) = simple . adjust $ \thrd -> thrd 163 | { threadK = k 164 | , threadMask = ms 165 | } 166 | go (InMask ms ma k) = simple . adjust $ \thrd -> thrd 167 | { threadK = 168 | let ms0 = threadMask thrd 169 | umask :: MiniFu m x -> MiniFu m x 170 | umask (MiniFu mx) = MiniFu $ do 171 | K.cont (\c -> Mask ms0 (c ())) 172 | x <- mx 173 | K.cont (\c -> Mask ms (c ())) 174 | pure x 175 | in K.runCont (runMiniFu (ma umask)) (Mask ms0 . k) 176 | , threadMask = ms 177 | } 178 | go (Stop mx) = do 179 | mx 180 | simple (M.delete tid) 181 | 182 | ------------------------------------------------------------------------------- 183 | 184 | -- | An identifier source is a simple counter. 185 | type IdSource = Int 186 | 187 | -- | Create an identifier source. 188 | initialIdSource :: IdSource 189 | initialIdSource = 0 190 | 191 | -- | Get a new unique thread ID. 192 | nextThreadId :: IdSource -> (ThreadId, IdSource) 193 | nextThreadId n = (ThreadId n, n + 1) 194 | 195 | -- | Get a new unique @MVar@ ID: 196 | nextMVarId :: IdSource -> (MVarId, IdSource) 197 | nextMVarId n = (MVarId n, n + 1) 198 | 199 | ------------------------------------------------------------------------------- 200 | 201 | -- | A collection of threads is just a map of thread records keyed by 202 | -- ID. 203 | type Threads m = Map ThreadId (Thread m) 204 | 205 | -- | A thread is a continuation along with what @MVar@ it is blocked 206 | -- on. 207 | data Thread m = Thread 208 | { threadK :: PrimOp m 209 | , threadBlock :: Maybe (Either ThreadId MVarId) 210 | , threadExc :: [Handler m] 211 | , threadMask :: E.MaskingState 212 | } 213 | 214 | -- | An exception handler. 215 | data Handler m where 216 | Handler :: E.Exception e => (e -> PrimOp m) -> Handler m 217 | 218 | -- | Create a new thread 219 | thread :: PrimOp m -> Thread m 220 | thread k = Thread 221 | { threadK = k 222 | , threadBlock = Nothing 223 | , threadExc = [] 224 | , threadMask = E.Unmasked 225 | } 226 | 227 | -- | Create the initial thread and ID source 228 | initialise :: PrimOp m -> (Threads m, IdSource) 229 | initialise pop = 230 | let (tid, idsrc) = nextThreadId initialIdSource 231 | in (M.singleton tid (thread pop), idsrc) 232 | 233 | -- | Raise an exception in a thread. If this returns @Nothing@ the 234 | -- thread has been killed. 235 | raise :: E.Exception e => e -> Thread m -> Maybe (Thread m) 236 | raise exc thrd = go (threadExc thrd) where 237 | go (Handler h:hs) = case h <$> E.fromException exc' of 238 | Just pop -> Just (thrd { threadK = pop, threadBlock = Nothing, threadExc = hs }) 239 | Nothing -> go hs 240 | go [] = Nothing 241 | 242 | exc' = E.toException exc 243 | 244 | -- | Check if a thread is interruptible by an asynchronous exception. 245 | isInterruptible :: Thread m -> Bool 246 | isInterruptible thrd = 247 | threadMask thrd == E.Unmasked || 248 | (threadMask thrd == E.MaskedInterruptible && isJust (threadBlock thrd)) 249 | 250 | -- | Block a thread. 251 | block :: Either ThreadId MVarId -> ThreadId -> Threads m -> Threads m 252 | block v = M.adjust (\thrd -> thrd { threadBlock = Just v }) 253 | 254 | -- | Unblock all matching threads. 255 | unblock :: Functor f => Either ThreadId MVarId -> f (Thread m) -> f (Thread m) 256 | unblock v = fmap $ \thrd -> 257 | if threadBlock thrd == Just v 258 | then thrd { threadBlock = Nothing } 259 | else thrd 260 | 261 | -- | Change the continuation of a thread. 262 | goto :: PrimOp m -> ThreadId -> Threads m -> Threads m 263 | goto k = M.adjust (\thrd -> thrd { threadK = k }) 264 | 265 | ------------------------------------------------------------------------------- 266 | 267 | data Blocking = Blocking | NonBlocking 268 | data Emptying = Emptying | NonEmptying deriving Eq 269 | 270 | -- | Abstraction over @putMVar@ and @tryPutMVar@ 271 | putIntoMVar :: C.MonadConc m 272 | => Blocking 273 | -> MVar m a 274 | -> a 275 | -> (Bool -> PrimOp m) 276 | -> m (ThreadId -> Threads m -> Threads m) 277 | putIntoMVar blocking (MVar mvid ref) a k = do 278 | old <- C.readCRef ref 279 | case old of 280 | Just _ -> pure $ case blocking of 281 | Blocking -> block (Right mvid) 282 | NonBlocking -> goto (k False) 283 | Nothing -> do 284 | C.writeCRef ref (Just a) 285 | pure $ \tid -> goto (k True) tid . unblock (Right mvid) 286 | 287 | -- | Abstraction over @readMVar@, @takeMVar@, @tryReadMVar@, and 288 | -- @tryTakeMVar@. 289 | seeIntoMVar :: C.MonadConc m 290 | => Blocking 291 | -> Emptying 292 | -> MVar m a 293 | -> (Maybe a -> PrimOp m) 294 | -> m (ThreadId -> Threads m -> Threads m) 295 | seeIntoMVar blocking emptying (MVar mvid ref) k = do 296 | old <- C.readCRef ref 297 | case old of 298 | Just a -> do 299 | when (emptying == Emptying) (C.writeCRef ref Nothing) 300 | pure $ \tid -> goto (k (Just a)) tid . unblock (Right mvid) 301 | Nothing -> pure $ case blocking of 302 | Blocking -> block (Right mvid) 303 | NonBlocking -> goto (k Nothing) 304 | -------------------------------------------------------------------------------- /examples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | import qualified Control.Exception as E 4 | import Control.Monad (join) 5 | import qualified System.Random as R 6 | 7 | import Test.MiniFu 8 | 9 | 10 | example :: MiniFu m Int 11 | example = do 12 | a <- newEmptyMVar 13 | fork (putMVar a 1) 14 | fork (putMVar a 2) 15 | takeMVar a 16 | 17 | example_sync :: MiniFu m Int 18 | example_sync = do 19 | a <- newEmptyMVar 20 | fork (putMVar a (pure 1)) 21 | fork (putMVar a (throw E.NonTermination)) 22 | fork (putMVar a (throw E.AllocationLimitExceeded)) 23 | catch 24 | (catch 25 | (join (readMVar a)) 26 | (\(_ :: E.AllocationLimitExceeded) -> pure 2)) 27 | (\(_ :: E.NonTermination) -> pure 3) 28 | 29 | example_async :: MiniFu m String 30 | example_async = do 31 | a <- newEmptyMVar 32 | tid <- fork (putMVar a "hello from the other thread") 33 | throwTo tid E.ThreadKilled 34 | readMVar a 35 | 36 | demo :: IO () 37 | demo = do 38 | g <- R.newStdGen 39 | print . fst =<< minifu randomSched g example 40 | 41 | demo_sync :: IO () 42 | demo_sync = do 43 | g <- R.newStdGen 44 | print . fst =<< minifu randomSched g example_sync 45 | 46 | demo_async :: IO () 47 | demo_async = do 48 | g <- R.newStdGen 49 | print . fst =<< minifu randomSched g example_async 50 | -------------------------------------------------------------------------------- /minifu.cabal: -------------------------------------------------------------------------------- 1 | -- Initial minifu.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: minifu 5 | version: 0.0.0.0 6 | synopsis: Small and simple concurrency testing library in Haskell, as a teaching aid. 7 | homepage: https://github.com/barrucadu/minifu 8 | license: MIT 9 | license-file: LICENSE 10 | author: Michael Walker 11 | maintainer: mike@barrucadu.co.uk 12 | category: Testing 13 | build-type: Simple 14 | cabal-version: >=1.10 15 | 16 | library 17 | exposed-modules: Test.MiniFu 18 | , Test.MiniFu.Internal 19 | build-depends: base >=4.9 && <4.10 20 | , concurrency 21 | , containers 22 | , exceptions 23 | , mtl 24 | , random 25 | default-language: Haskell2010 26 | ghc-options: -Wall 27 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-9.6 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.5" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /tutorial/01-writing-a-concurrency-testing-library.markdown: -------------------------------------------------------------------------------- 1 | Writing a Concurrency Testing Library (Part 1) 2 | ============================================== 3 | 4 | Welcome to the first part of a tutorial on writing your very own 5 | concurrency testing library for Haskell. Before we get into the 6 | details, let's just clarify what I mean by a "concurrency testing 7 | library". The goal is a function which, given some concurrent Haskell 8 | like so: 9 | 10 | ```haskell 11 | example = do 12 | a <- newEmptyMVar 13 | forkIO (putMVar a 1) 14 | forkIO (putMVar a 2) 15 | takeMVar a 16 | ``` 17 | 18 | Will tell us the possible results of that computation: 19 | 20 | ``` 21 | λ> test example 22 | [1, 2] 23 | ``` 24 | 25 | We're going to build this from the ground up, using 26 | the [concurrency][] library, as it provides a typeclass abstraction 27 | over forking, MVars, STM, and suchlike. 28 | 29 | [concurrency]: https://hackage.haskell.org/package/concurrency 30 | 31 | You may have come across my [dejafu][] library before. If not, don't 32 | worry, but you may want to check it out as we're going to be building 33 | something very similar. 34 | 35 | [dejafu]: https://hackage.haskell.org/package/dejafu 36 | 37 | 38 | Let's get down to business 39 | -------------------------- 40 | 41 | Ok, with the preliminaries over, let's get coding! All the code 42 | written in this series is on [GitHub][], with one tag for each post. 43 | The code for this post is under the "post-01" tag. 44 | 45 | [GitHub]: https://github.com/barrucadu/minifu 46 | 47 | The goal in this post is to be able to implement a function which can 48 | execute simple thread-and-MVar computations (like the example from the 49 | beginning) with a stateful scheduler. Firstly, let's say what we 50 | know: 51 | 52 | - We're using the `MonadConc` typeclass from [concurrency][], rather 53 | than `IO`. 54 | - We want to be able to examine arbitrary `MonadConc` computations. 55 | - We also want to be able to pause and resume "threads" at will, so we 56 | can explore different executions. 57 | 58 | That sounds rather like something based on continuations or a free 59 | monad. Furthermore, we're going to need mutable state to implement 60 | all of this, as we're modelling a DSL with mutable references, and 61 | doing that purely is a huge pain. 62 | 63 | Let's write down some types. Because we're writing a mini-dejafu, I'm 64 | calling this project "minifu". So we want a function: 65 | 66 | ```haskell 67 | import qualified Control.Concurrent.Classy as C 68 | import Data.List.NonEmpty (NonEmpty(..)) 69 | 70 | newtype ThreadId = ThreadId Int 71 | deriving (Eq, Ord) 72 | 73 | type Scheduler s = NonEmpty ThreadId -> s -> (ThreadId, s) 74 | 75 | minifu :: C.MonadConc m => Scheduler s -> s -> MiniFu m a -> m (Maybe a, s) 76 | ``` 77 | 78 | For some suitable `MiniFu` monad transformer. Now we're going to take 79 | the standard way of constructing a free monad, and have a data 80 | structure representing our class of interest (`MonadConc`), with one 81 | constructor for every function. Because we're only talking about 82 | threads and MVars in this post, it will be a fairly small type: 83 | 84 | ```haskell 85 | {-# LANGUAGE GADTs #-} 86 | 87 | data PrimOp m where 88 | Fork :: MiniFu m () -> (ThreadId -> PrimOp m) -> PrimOp m 89 | NewEmptyMVar :: (MVar m a -> PrimOp m) -> PrimOp m 90 | PutMVar :: MVar m a -> a -> PrimOp m -> PrimOp m 91 | TakeMVar :: MVar m a -> (a -> PrimOp m) -> PrimOp m 92 | Stop :: m () -> PrimOp m 93 | 94 | newtype MVarId = MVarId Int 95 | deriving (Eq, Ord) 96 | 97 | data MVar m a = MVar 98 | { mvarId :: MVarId 99 | , mvarRef :: C.CRef m (Maybe a) 100 | } 101 | ``` 102 | 103 | The `Stop` action is what is going to let us communicate the final 104 | result out of the computation. I've also defined an `MVar` type. Our 105 | MVars are going to be implemented as a `CRef` (what [concurrency][] 106 | calls an `IORef`) holding a maybe value, along with an identifier. 107 | These identifiers will come into play when we look at threads 108 | blocking. 109 | 110 | Given this set up, the `MiniFu` type is very simple: 111 | 112 | ```haskell 113 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 114 | 115 | import qualified Control.Monad.Cont as K 116 | 117 | newtype MiniFu m a = MiniFu { runMiniFu :: K.Cont (PrimOp m) a } 118 | deriving (Functor, Applicative, Monad) 119 | ``` 120 | 121 | We're not actually going to write a `MonadConc` instance for `MiniFu` 122 | yet, because there are a bunch of constraints which we can't really 123 | satisfy. But we can still define the functions of interest: 124 | 125 | ```haskell 126 | fork :: MiniFu m () -> MiniFu m ThreadId 127 | fork ma = MiniFu (K.cont (Fork ma)) 128 | 129 | newEmptyMVar :: MiniFu m (MVar m a) 130 | newEmptyMVar = MiniFu (K.cont NewEmptyMVar) 131 | 132 | putMVar :: MVar m a -> a -> MiniFu m () 133 | putMVar v a = MiniFu (K.cont (\k -> PutMVar v a (k ()))) 134 | 135 | takeMVar :: MVar m a -> MiniFu m a 136 | takeMVar v = MiniFu (K.cont (TakeMVar v)) 137 | ``` 138 | 139 | Hey, not bad! Now we can slap a `MiniFu m Int` type signature on our 140 | example from the start (and rename the `forkIO` calls) and it 141 | compiles! 142 | 143 | ```haskell 144 | example :: MiniFu m Int 145 | example = do 146 | a <- newEmptyMVar 147 | fork (putMVar a 1) 148 | fork (putMVar a 2) 149 | takeMVar a 150 | ``` 151 | 152 | Take a moment to make sure you're happy with this section before 153 | moving on to the next. MiniFu is going to be a layered application: 154 | this is the basic layer which defines the functions we can test; the 155 | next layer executes a MiniFu computation; the layers above that will 156 | implement the systematic testing behaviour. 157 | 158 | 159 | Implementing `minifu` 160 | --------------------- 161 | 162 | Recall the type of `minifu`: 163 | 164 | ```haskell 165 | minifu :: C.MonadConc m => Scheduler s -> s -> MiniFu m a -> m (Maybe a, s) 166 | ``` 167 | 168 | So, what does it need to do? It needs to set up the execution 169 | environment: in this case that's specifying that the provided 170 | computation is the main thread, and then it needs to repeatedly call 171 | the scheduler, executing one `PrimOp` of the chosen thread at a time, 172 | until either the main thread terminates or everything is blocked. 173 | 174 | In the best functional programming practice, `minifu` is going to do 175 | the minimum it can and call another function to do the rest. So what 176 | `minifu` is *actually* going to do is to extract the continuation and 177 | set up the mechanism to communicate the final result back: 178 | 179 | ```haskell 180 | minifu sched s (MiniFu ma) = do 181 | out <- C.newCRef Nothing 182 | s' <- run sched s (K.runCont ma (Stop . C.writeCRef out . Just)) 183 | a <- C.readCRef out 184 | pure (a, s') 185 | ``` 186 | 187 | Before we move on to the implementation of `run`, let's first look at 188 | two concerns we'll have along the way: getting unique names (for 189 | threads and MVars) and representing threads. 190 | 191 | ### Names 192 | 193 | Each thread gets a unique `ThreadId`, and each MVar gets a unique 194 | `MVarId`. As these are just an `Int`, we can use the same source for 195 | both: 196 | 197 | ```haskell 198 | type IdSource = Int 199 | 200 | initialIdSource :: IdSource 201 | initialIdSource = 0 202 | 203 | nextThreadId :: IdSource -> (ThreadId, IdSource) 204 | nextThreadId n = (ThreadId n, n + 1) 205 | 206 | nextMVarId :: IdSource -> (MVarId, IdSource) 207 | nextMVarId n = (MVarId n, n + 1) 208 | ``` 209 | 210 | This is as simple as it gets, but it's good enough for now. 211 | 212 | ### Threads 213 | 214 | What is a thread? Well, it has a continuation, which is some value of 215 | type `PrimOp m`, and it might be blocked. We want to know if a thread 216 | is blocked for two reasons: we don't want the scheduler to schedule a 217 | blocked thread, and we want to be able to tell if the computation is 218 | deadlocked. Threads can only block on reading from or writing to 219 | MVars (currently), so let's use a `Maybe MVarId` to indicate whether 220 | the thread is blocked: 221 | 222 | ```haskell 223 | data Thread m = Thread 224 | { threadK :: PrimOp m 225 | , threadBlock :: Maybe MVarId 226 | } 227 | ``` 228 | 229 | When we create a thread, it's initially unblocked: 230 | 231 | ```haskell 232 | thread :: PrimOp m -> Thread m 233 | thread k = Thread 234 | { threadK = k 235 | , threadBlock = Nothing 236 | } 237 | ``` 238 | 239 | And finally we need a way to construct our initial collection of 240 | threads: 241 | 242 | ```haskell 243 | import Data.Map (Map) 244 | import qualified Data.Map as M 245 | 246 | type Threads m = Map ThreadId (Thread m) 247 | 248 | initialise :: PrimOp m -> (Threads m, IdSource) 249 | initialise k = 250 | let (tid, idsrc) = nextThreadId initialIdSource 251 | in (M.singleton tid (thread k), idsrc) 252 | ``` 253 | 254 | And now back to the implementation of `minifu`. 255 | 256 | ### Implementing `run` 257 | 258 | The `run` function is responsible for taking the first continuation, 259 | creating the collection of threads, and repeatedly calling the 260 | scheduler and stepping the chosen thread, until the computation is 261 | done. 262 | 263 | It has this type: 264 | 265 | ```haskell 266 | run :: C.MonadConc m => Scheduler s -> s -> PrimOp m -> m s 267 | ``` 268 | 269 | As with `minifu`, we shall keep it simple, and delegate most of the 270 | work to yet another function: 271 | 272 | ```haskell 273 | import Data.List.NonEmpty (nonEmpty) 274 | import Data.Maybe (isNothing) 275 | 276 | run sched s0 = go s0 . initialise where 277 | go s (threads, ids) 278 | | initialThreadId `M.member` threads = case runnable threads of 279 | Just tids -> 280 | let (chosen, s') = sched tids s 281 | in go s' =<< stepThread chosen (threads, ids) 282 | Nothing -> pure s 283 | | otherwise = pure s 284 | 285 | runnable = nonEmpty . M.keys . M.filter (isNothing . threadBlock) 286 | 287 | initialThreadId = fst (nextThreadId initialIdSource) 288 | ``` 289 | 290 | Let's break down that `go` function a bit: 291 | 292 | 1. We check if the initial thread still exists. If not, we return. 293 | 2. We check if the collection of runnable threads is nonempty. If 294 | not, we return. 295 | 3. We call the scheduler to pick a thread from the runnable ones. 296 | 4. We call the (not yet defined) `stepThread` function to execute one 297 | step of that thread. 298 | 5. We go around the loop again. 299 | 300 | Not too bad, hey? Finally (really finally) we just have one function 301 | to go, `stepThread`. Can you see what the type will be? 302 | 303 | It's going to start like this: 304 | 305 | ```haskell 306 | stepThread :: C.MonadConc m => ThreadId -> (Threads m, IdSource) -> m (Threads m, IdSource) 307 | stepThread tid (threads, idsrc) = case M.lookup tid threads of 308 | Just thrd -> go (threadK thrd) 309 | Nothing -> pure (threads, idsrc) 310 | where 311 | adjust :: (Thread m -> Thread m) -> Threads m -> Threads m 312 | adjust f = M.adjust f tid 313 | 314 | goto :: PrimOp m -> Threads m -> Threads m 315 | goto k = adjust (\thrd -> thrd { threadK = k }) 316 | 317 | block :: Maybe MVarId -> Threads m -> Threads m 318 | block mv = adjust (\thrd -> thrd { threadBlock = mv }) 319 | 320 | unblock :: MVarId -> Threads m -> Threads m 321 | unblock v = fmap (\thrd -> 322 | if threadBlock thrd == Just v 323 | then thrd { threadBlock = Nothing } 324 | else thrd) 325 | 326 | go :: PrimOp m -> m (Threads m, IdSource) 327 | -- go ... 328 | ``` 329 | 330 | I've introduced a few helper functions, which will crop up a lot. 331 | That `go` function will have a case for every constructor of `PrimOp 332 | m`, and it's going to look a bit hairy, so we'll take it one 333 | constructor at a time. Let's do the constructors in order. 334 | 335 | First, we can fork threads: 336 | 337 | ```haskell 338 | go (Fork (MiniFu ma) k) = 339 | let (tid', idsrc') = nextThreadId idsrc 340 | thrd' = thread (K.runCont ma (\_ -> Stop (pure ()))) 341 | in pure (goto (k tid') (M.insert tid' thrd' threads), idsrc') 342 | ``` 343 | 344 | Forking is pretty straightforward. We simply get the next available 345 | `ThreadId` from the `IdSource`, create a thread with the provided 346 | continuation, and insert it into the `Threads m` map. 347 | 348 | Next up is `NewEmptyMVar`: 349 | 350 | ```haskell 351 | go (NewEmptyMVar k) = do 352 | ref <- C.newCRef Nothing 353 | let (mvid, idsrc') = nextMVarId idsrc 354 | pure (goto (k (MVar mvid ref)) threads, idsrc') 355 | ``` 356 | 357 | Remember that we're implementing our `MVar` type using the `CRef` type 358 | of the underlying `MonadConc`. As the `MVar` starts out empty, the 359 | `CRef` starts out holding `Nothing`. 360 | 361 | The `PutMVar` and `TakeMVar` actions are almost the same, so let's 362 | tackle them together: 363 | 364 | ```haskell 365 | go (PutMVar (MVar mvid ref) a k) = do 366 | old <- C.readCRef ref 367 | case old of 368 | Just _ -> pure (block (Just mvid) threads, idsrc) 369 | Nothing -> do 370 | C.writeCRef ref (Just a) 371 | pure (goto k (unblock mvid threads), idsrc) 372 | 373 | go (TakeMVar (MVar mvid ref) k) = do 374 | old <- C.readCRef ref 375 | case old of 376 | Just a -> do 377 | C.writeCRef ref Nothing 378 | pure (goto (k a) (unblock mvid threads), idsrc) 379 | Nothing -> pure (block (Just mvid) threads, idsrc) 380 | ``` 381 | 382 | In both cases, we start out by reading the value of the reference. 383 | Remember that `Nothing` indicates emptiness, and `Just` indicates the 384 | presence of a value. So, for `PutMVar` *if there already is a value* 385 | (and for `TakeMVar` *if there isn't a value*), we block the thread. 386 | In the other case, we update the value in the reference, putting in 387 | the new value (or taking out the old), unblock all the relevant 388 | threads, and go to the continuation. 389 | 390 | These implementations are not atomic. But that's fine: despite MiniFu 391 | testing concurrent programs, there's no concurrency going on within 392 | MiniFu itself. We can do as much or as little as we want during one 393 | atomic "step" of our program. This will turn out to be very useful 394 | when we implement STM in a few posts time. 395 | 396 | Finally, we have `Stop`: 397 | 398 | ```haskell 399 | go (Stop mx) = do 400 | mx 401 | pure (M.delete tid threads, idsrc) 402 | ``` 403 | 404 | And we're done! That's it! All we need now is a scheduler, and we 405 | can execute our example! 406 | 407 | 408 | A Simple Scheduler 409 | ------------------ 410 | 411 | Our example is nondeterministic, so we want a scheduler which will let 412 | us see that. It would be no good us implementing something which 413 | always made the same decisions, as we'd only see one result! So until 414 | we implement the systematic testing behaviour, let's just use a simple 415 | random scheduler. 416 | 417 | ```haskell 418 | import qualified System.Random as R 419 | 420 | randomSched :: R.RandomGen g => Scheduler g 421 | randomSched (t:|ts) g = 422 | let (i, g') = R.randomR (0, length ts) g 423 | in ((t:ts) !! i, g') 424 | ``` 425 | 426 | There's no deep magic here, we're just picking a random value from a 427 | nonempty list. Finally, we can construct a little demo: 428 | 429 | ```haskell 430 | demo :: IO () 431 | demo = do 432 | g <- R.newStdGen 433 | print . fst =<< minifu randomSched g example 434 | ``` 435 | 436 | Which we can run in ghci like so: 437 | 438 | ``` 439 | λ> demo 440 | Just 1 441 | λ> demo 442 | Just 1 443 | λ> demo 444 | Just 1 445 | λ> demo 446 | Just 2 447 | λ> demo 448 | Just 1 449 | ``` 450 | 451 | Success! 452 | 453 | A random scheduler is fine for demonstration purposes, but not so 454 | great for testing. Different seeds may lead to the same execution, 455 | which makes it hard to know how many executions of a test is enough. 456 | It can be a useful technique, but for us this is only the beginning. 457 | 458 | 459 | Next time... 460 | ------------ 461 | 462 | Next time we'll look at implementing exceptions, both synchronous and 463 | asynchronous. 464 | 465 | I hope you enjoyed this post, any feedback is welcome. As I mentioned 466 | at the start, this is on [GitHub][], you can get the code we ended up 467 | with at the "post-01" tag. 468 | 469 | *Before* next time, I have some homework for you! You have seen how 470 | to implement MVars, so now try implementing CRefs! Here are the 471 | functions should you have a go at writing: 472 | 473 | ```haskell 474 | data CRef m a = -- ... 475 | 476 | newCRef :: a -> MiniFu m (CRef m a) 477 | 478 | readCRef :: CRef m a -> MiniFu m a 479 | 480 | writeCRef :: CRef m a -> a -> MiniFu m () 481 | 482 | atomicModifyCRef :: CRef m a -> (a -> (a, b)) -> MiniFu m b 483 | ``` 484 | 485 | Don't worry about any of the relaxed memory stuff implemented in 486 | dejafu, just do sequential consistency (and if you don't know what 487 | that means: it means to do the obvious). I'll put up a solution (and 488 | maybe do a little refactoring) before the next post. 489 | 490 | --- 491 | 492 | Thanks to [José Manuel Calderón Trilla][jmct] for reading an earlier 493 | draft of this post. 494 | 495 | [jmct]: https://twitter.com/josecalderon 496 | -------------------------------------------------------------------------------- /tutorial/02-exceptions.markdown: -------------------------------------------------------------------------------- 1 | Writing a Concurrency Testing Library (Part 2): Exceptions 2 | ========================================================== 3 | 4 | Welcome back to my series on implementing a concurrency testing 5 | library for Haskell. This is part 2 of the series, and today we'll 6 | implement exceptions. If you missed part 1, you can read it [here][]. 7 | 8 | As before, all code is available on [GitHub][]. The code for this 9 | post is under the "post-02" tag. 10 | 11 | [here]: https://www.barrucadu.co.uk/posts/concurrency/2017-10-14-writing-a-concurrency-testing-library-01.html 12 | [GitHub]: https://github.com/barrucadu/minifu 13 | 14 | --- 15 | 16 | Did you do last time's homework task? It was to implement this 17 | interface: 18 | 19 | ```haskell 20 | data CRef m a = -- ... 21 | 22 | newCRef :: a -> MiniFu m (CRef m a) 23 | 24 | readCRef :: CRef m a -> MiniFu m a 25 | 26 | writeCRef :: CRef m a -> a -> MiniFu m () 27 | 28 | atomicModifyCRef :: CRef m a -> (a -> (a, b)) -> MiniFu m b 29 | ``` 30 | 31 | Here are my solutions, available at the "homework-01" tag: 32 | 33 | 1. ([`2070bdf`][]) Add the `CRef` type, the `PrimOp` constructors, and the wrapper functions 34 | 2. ([`188eec5`][]) Implement the primops 35 | 36 | [`2070bdf`]: https://github.com/barrucadu/minifu/commit/2070bdfaf5174fc14f6835d8410988cf111a854a 37 | [`188eec5`]: https://github.com/barrucadu/minifu/commit/188eec562f619c26fe117dd891ff86befc27b5a2 38 | 39 | I also made some changes, available at the "pre-02" tag: 40 | 41 | 1. ([`7ce6e41`][]) Add a helper for primops which don't create any identifiers 42 | 2. ([`2419796`][]) Move some definitions into an internal module 43 | 3. ([`9c49f9d`][]) Change the type of the `block` helper to `MVarId -> Threads m -> Threads m` 44 | 4. ([`dabd84b`][]) Implement `readMVar` 45 | 46 | [`7ce6e41`]: https://github.com/barrucadu/minifu/commit/7ce6e41f8bdc60c73affa00f7760a46a7e6ecfc3 47 | [`2419796`]: https://github.com/barrucadu/minifu/commit/24197965787555c5552ce8cb70fcb078016a167c 48 | [`9c49f9d`]: https://github.com/barrucadu/minifu/commit/9c49f9d76f27ce0fa1ed445c34d9107105e66171 49 | [`dabd84b`]: https://github.com/barrucadu/minifu/commit/dabd84b1ed4f713889b607b142ecb2d1987ee804 50 | 51 | Now on to the show... 52 | 53 | 54 | Synchronous exceptions 55 | ---------------------- 56 | 57 | We can't implement exceptions with what we have already. We're going 58 | to need some new primops. I think you're getting a feel for how this 59 | works now, so I won't drag this out. Here we go: 60 | 61 | ```haskell 62 | import qualified Control.Exception as E 63 | 64 | data PrimOp m where 65 | -- ... 66 | Throw :: E.Exception e => e -> PrimOp m 67 | Catch :: E.Exception e => MiniFu m a -> (e -> MiniFu m a) -> (a -> PrimOp m) 68 | -> PrimOp m 69 | PopH :: PrimOp m -> PrimOp m 70 | 71 | throw :: E.Exception e => e -> MiniFu m a 72 | throw e = MiniFu (K.cont (\_ -> Throw e)) 73 | 74 | catch :: E.Exception e => MiniFu m a -> (e -> MiniFu m a) -> MiniFu m a 75 | catch act h = MiniFu (K.cont (Catch act h)) 76 | ``` 77 | 78 | Throwing an exception with `throw` jumps back to the closest enclosing 79 | `catch` with an exception handler of the appropriate type, killing the 80 | thread if there is none. The `PopH` primop will pop the top exception 81 | handler from the stack. We'll insert those as appropriate when 82 | entering a `catch`. 83 | 84 | Before we can actually implement these primops, we need to give 85 | threads a place to store their exception handlers. You might have 86 | guessed it when I said "stack": we'll just give every thread a list of 87 | them. This requires changing our `Thread` type and `thread` function: 88 | 89 | ```haskell 90 | data Thread m = Thread 91 | { threadK :: PrimOp m 92 | , threadBlock :: Maybe MVarId 93 | , threadExc :: [Handler m] -- <- new 94 | } 95 | 96 | data Handler m where 97 | Handler :: E.Exception e => (e -> PrimOp m) -> Handler m 98 | 99 | thread :: PrimOp m -> Thread m 100 | thread k = Thread 101 | { threadK = k 102 | , threadBlock = Nothing 103 | , threadExc = [] -- <- new 104 | } 105 | ``` 106 | 107 | As `Exception` is a subclass of `Typeable`, given some exception value 108 | we're able to look for the first matching handler: 109 | 110 | ```haskell 111 | raise :: E.Exception e => e -> Thread m -> Maybe (Thread m) 112 | raise exc thrd = go (threadExc thrd) where 113 | go (Handler h:hs) = case h <$> E.fromException exc' of 114 | Just pop -> Just (thrd { threadK = pop, threadBlock = Nothing, threadExc = hs }) 115 | Nothing -> go hs 116 | go [] = Nothing 117 | 118 | exc' = E.toException exc 119 | ``` 120 | 121 | If `raise` returns a `Just`, then a handler was found and entered. 122 | Otherwise, no handler exists and the thread should be removed from the 123 | `Threads` collection. This can be expressed rather nicely as 124 | `M.update . raise`. 125 | 126 | Now we have enough support to implement the primops: 127 | 128 | ```haskell 129 | stepThread {- ... -} 130 | where 131 | -- ... 132 | go (Throw e) = 133 | simple (M.update (raise e) tid) 134 | go (Catch (MiniFu ma) h k) = simple . adjust $ \thrd -> thrd 135 | { threadK = K.runCont ma (PopH . k) 136 | , threadExc = 137 | let h' exc = K.runCont (runMiniFu (h exc)) k 138 | in Handler h' : threadExc thrd 139 | } 140 | go (PopH k) = simple . adjust $ \thrd -> thrd 141 | { threadK = k 142 | , threadExc = tail (threadExc thrd) 143 | } 144 | ``` 145 | 146 | Let's break that down: 147 | 148 | - `Throw` just re-uses our `raise` function to either jump to the 149 | exception handler or kill the thread. 150 | - `Catch` changes the continuation of the thread to run the enclosed 151 | action, then do a `PopH` action, then run the outer action. It also 152 | adds an exception continuation, which just runs the exception 153 | handler, then runs the outer action. 154 | - `PopH` just removes the head exception continuation. 155 | 156 | It's important that the exception continuation *doesn't* use `PopH` to 157 | remove itself: that happens in `raise` when an exception is thrown. 158 | When writing this section I realised I'd made that mistake in dejafu 159 | ([#139][])! 160 | 161 | [#139]: https://github.com/barrucadu/dejafu/issues/139 162 | 163 | ### So what? 164 | 165 | So now we can use synchronous exceptions! Here's an incredibly 166 | contrived example: 167 | 168 | ```haskell 169 | {-# LANGUAGE ScopedTypeVariables #-} 170 | 171 | import Control.Monad (join) 172 | 173 | example_sync :: MiniFu m Int 174 | example_sync = do 175 | a <- newEmptyMVar 176 | fork (putMVar a (pure 1)) 177 | fork (putMVar a (throw E.NonTermination)) 178 | fork (putMVar a (throw E.AllocationLimitExceeded)) 179 | catch 180 | (catch 181 | (join (readMVar a)) 182 | (\(_ :: E.AllocationLimitExceeded) -> pure 2)) 183 | (\(_ :: E.NonTermination) -> pure 3) 184 | 185 | demo_sync :: IO () 186 | demo_sync = do 187 | g <- R.newStdGen 188 | print . fst =<< minifu randomSched g example_sync 189 | ``` 190 | 191 | If we run this a few times in ghci, we can see the different 192 | exceptions being thrown and caught (resulting in different outputs): 193 | 194 | ``` 195 | λ> demo_sync 196 | Just 1 197 | λ> demo_sync 198 | Just 3 199 | λ> demo_sync 200 | Just 3 201 | λ> demo_sync 202 | Just 2 203 | ``` 204 | 205 | ### MonadThrow and MonadCatch 206 | 207 | `MonadConc` has a bunch of superclasses, and we can now implement two 208 | of them! 209 | 210 | ```haskell 211 | import qualified Control.Monad.Catch as EM 212 | 213 | instance EM.MonadThrow (MiniFu m) where 214 | throwM = -- 'throw' from above 215 | 216 | instance EM.MonadCatch (MiniFu m) where 217 | catch = -- 'catch' from above 218 | ``` 219 | 220 | The [exceptions][] package provides the `MonadThrow`, `MonadCatch`, 221 | and `MonadMask` typeclasses, so we can talk about exceptions in a 222 | wider context than just `IO`. We'll get on to `MonadMask` when we 223 | look at asynchronous exceptions. 224 | 225 | [exceptions]: https://hackage.haskell.org/package/exceptions 226 | 227 | ### Incompleteness! 228 | 229 | It is with exceptions that we hit the first thing we can't do in 230 | MiniFu. 231 | 232 | When in `IO`, we can catch exceptions from pure code: 233 | 234 | ``` 235 | λ> import Control.Exception 236 | λ> evaluate undefined `catch` \e -> putStrLn ("Got " ++ show (e :: SomeException)) 237 | Got Prelude.undefined 238 | CallStack (from HasCallStack): 239 | error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err 240 | undefined, called at :5:10 in interactive:Ghci2 241 | ``` 242 | 243 | But we can't do that in `MiniFu`, as there's no suitable `evaluate` 244 | function. 245 | 246 | Should there be an `evaluate` in the `MonadConc` class? I'm 247 | unconvinced, as it's not really a *concurrency* operation. 248 | 249 | Should we constrain the `m` in `MiniFu m` to be a `MonadIO`, which 250 | would let us call `evaluate`? Perhaps, that would certainly be a way 251 | to do it, and I'm currently investigating the advantages of an `IO` 252 | base monad for dejafu (although originally for a different reason). 253 | 254 | 255 | Asynchronous exceptions 256 | ----------------------- 257 | 258 | Asynchronous exceptions are like synchronous exceptions, except for 259 | two details: 260 | 261 | 1. They are thrown to a thread identified by `ThreadId`. We can do 262 | this already with `raise`. 263 | 2. Raising the exception may be blocked due to the target thread's 264 | *masking state*. We need to do some extra work to implement this. 265 | 266 | When a thread is masked, attempting to deliver an asynchronous 267 | exception to it will block. There are three masking states: 268 | 269 | - `Unmasked`, asynchronous exceptions are unmasked. 270 | - `MaskedInterruptible`, asynchronous exceptions are masked, but 271 | blocked operations may still be interrupted. 272 | - `MaskedUninterruptible`, asynchronous exceptions are masked, and 273 | blocked operations may not be interrupted. 274 | 275 | So we'll add the current masking state to our `Thread` type, 276 | defaulting to `Unmasked`, and also account for blocking on another 277 | thread: 278 | 279 | ```haskell 280 | data Thread m = Thread 281 | { threadK :: PrimOp m 282 | , threadBlock :: Maybe (Either ThreadId MVarId) -- <- new 283 | , threadExc :: [Handler m] 284 | , threadMask :: E.MaskingState -- <- new 285 | } 286 | 287 | thread :: PrimOp m -> Thread m 288 | thread k = Thread 289 | { threadK = k 290 | , threadBlock = Nothing 291 | , threadExc = [] 292 | , threadMask = E.Unmasked -- <- new 293 | } 294 | ``` 295 | 296 | We'll also need a primop to set the masking state: 297 | 298 | ```haskell 299 | data PrimOp m where 300 | -- ... 301 | Mask :: E.MaskingState -> PrimOp m -> PrimOp m 302 | ``` 303 | 304 | Which has a fairly straightforward implementation: 305 | 306 | ```haskell 307 | stepThread {- ... -} 308 | where 309 | -- ... 310 | go (Mask ms k) = simple . adjust $ \thrd -> thrd 311 | { threadK = k 312 | , threadMask = ms 313 | } 314 | ``` 315 | 316 | Finally, we need to make sure that if an exception is raised, and we 317 | jump into an exception handler, the masking state gets reset to what 318 | it was when the handler was created. This means we need a small 319 | change to the `Catch` primop: 320 | 321 | ```haskell 322 | stepThread {- ... -} 323 | where 324 | -- ... 325 | go (Catch (MiniFu ma) h k) = simple . adjust $ \thrd -> thrd 326 | { threadK = K.runCont ma (PopH . k) 327 | , threadExc = 328 | let ms0 = threadMask thrd -- <- new 329 | h' exc = flip K.runCont k $ do 330 | K.cont (\c -> Mask ms0 (c ())) -- <- new 331 | runMiniFu (h exc) 332 | in Handler h' : threadExc thrd 333 | } 334 | ``` 335 | 336 | Alright, now we have enough background to actually implement the 337 | user-facing operations. 338 | 339 | ### Throwing 340 | 341 | To throw an asynchronous exception, we're going to need a new primop: 342 | 343 | ```haskell 344 | data PrimOp m where 345 | -- ... 346 | ThrowTo :: E.Exception e => ThreadId -> e -> PrimOp m -> PrimOp m 347 | ``` 348 | 349 | Which has a corresponding wrapper function: 350 | 351 | ```haskell 352 | throwTo :: E.Exception e => ThreadId -> e -> MiniFu m () 353 | throwTo tid e = MiniFu (K.cont (\k -> ThrowTo tid e (k ()))) 354 | ``` 355 | 356 | Let's think about the implementation of the `ThrowTo` primop. It 357 | first needs to check if the target thread is interruptible and, if so, 358 | raises the exception in that thread; if not, it blocks the current 359 | thread. A thread is interruptible if its masking state is `Unmasked`, 360 | or `MaskedInterruptible` and it's currently blocked. 361 | 362 | Let's encapsulate that logic: 363 | 364 | ```haskell 365 | import Data.Maybe (isJust) 366 | 367 | isInterruptible :: Thread m -> Bool 368 | isInterruptible thrd = 369 | threadMask thrd == E.Unmasked || 370 | (threadMask thrd == E.MaskedInterruptible && isJust (threadBlock thrd)) 371 | ``` 372 | 373 | Given that, the implementation of `ThrowTo` is straightforward: 374 | 375 | ```haskell 376 | stepThread {- ... -} 377 | where 378 | -- ... 379 | go (ThrowTo threadid e k) = simple $ case M.lookup threadid threads of 380 | Just t 381 | | isInterruptible t -> goto k . M.update (raise e) threadid 382 | | otherwise -> block (Left threadid) 383 | Nothing -> goto k 384 | ``` 385 | 386 | First, check if the thread exists. Then check if it's interruptible: 387 | if it is, raise the exception, otherwise block. If the thread doesn't 388 | exist any more, just continue. 389 | 390 | Now we just need to handle *unblocking* threads which are blocked in 391 | `ThrowTo`. For that, we'll go back to the `run` function and add a 392 | pass to unblock threads if the current one is interruptible after it 393 | processes its action: 394 | 395 | ```haskell 396 | run :: C.MonadConc m => Scheduler s -> s -> PrimOp m -> m s 397 | run sched s0 = go s0 . initialise where 398 | go s (threads, idsrc) 399 | | initialThreadId `M.member` threads = case runnable threads of 400 | Just tids -> do 401 | let (chosen, s') = sched tids s 402 | (threads', idsrc') <- stepThread chosen (threads, idsrc) 403 | let threads'' = if (isInterruptible <$> M.lookup chosen threads') /= Just False 404 | then unblock (Left chosen) threads' 405 | else threads' 406 | -- ^- new 407 | go s' (threads'', idsrc') 408 | Nothing -> pure s 409 | | otherwise = pure s 410 | 411 | runnable = nonEmpty . M.keys . M.filter (isNothing . threadBlock) 412 | 413 | initialThreadId = fst (nextThreadId initialIdSource) 414 | ``` 415 | 416 | So after stepping a thread, we unblock every thread blocked on it if 417 | it either doesn't exist, of if it does exist and is interruptible. 418 | It's much more robust to do this once here than everywhere in 419 | `stepThread` which might cause the thread to become interruptible. 420 | 421 | ### Masking and MonadMask 422 | 423 | There are two operations at the programmer's disposal to change the 424 | masking state of a thread, `mask` and `uninterruptibleMask`. Here's 425 | what the `MiniFu` types will look like: 426 | 427 | ```haskell 428 | {-# LANGUAGE RankNTypes #-} 429 | 430 | mask :: ((forall x. MiniFu m x -> MiniFu m x) -> MiniFu m a) -> MiniFu m a 431 | uninterruptibleMask :: ((forall x. MiniFu m x -> MiniFu m x) -> MiniFu m a) -> MiniFu m a 432 | ``` 433 | 434 | Each takes an action to run, and runs it as either 435 | `MaskedInterruptible` or `MaskedUninterruptible`. The action is 436 | provided with a polymorphic callback to run a subcomputation with the 437 | original masking state. 438 | 439 | This is going to need, you guessed it, a new primop! We *could* 440 | modify the `Mask` primop to do this job as well, but I think it's a 441 | little clearer to have two separate ones: 442 | 443 | ```haskell 444 | data PrimOp m where 445 | -- ... 446 | InMask :: E.MaskingState -> ((forall x. MiniFu m x -> MiniFu m x) -> MiniFu m a) 447 | -> (a -> PrimOp m) -> PrimOp m 448 | ``` 449 | 450 | And here's the implementations of our masking functions: 451 | 452 | ```haskell 453 | mask ma = MiniFu (K.cont (InMask E.MaskedInterruptible ma)) 454 | uninterruptibleMask ma = MiniFu (K.cont (InMask E.MaskedUninterruptible ma)) 455 | ``` 456 | 457 | We can now fulfil another requirement of `MonadConc`: a `MonadMask` 458 | instance! 459 | 460 | ```haskell 461 | instance MonadMask (MiniFu m) where 462 | mask = -- 'mask' from above 463 | uninterruptibleMask = -- 'uninterruptibleMask' from above 464 | ``` 465 | 466 | The very last piece of the puzzle for exception handling in MiniFu is 467 | to implement this `InMask` primop. Its type looks quite intense, but 468 | the implementation is really not that bad. There are three parts: 469 | 470 | ```haskell 471 | stepThread {- ... -} 472 | where 473 | -- ... 474 | go (InMask ms ma k) = simple . adjust $ \thrd -> thrd 475 | { threadK = 476 | let ms0 = threadMask thrd 477 | 478 | -- (1) we need to construct the polymorphic argument function 479 | umask :: MiniFu m x -> MiniFu m x 480 | umask (MiniFu mx) = MiniFu $ do 481 | K.cont (\c -> Mask ms0 (c ())) 482 | x <- mx 483 | K.cont (\c -> Mask ms (c ())) 484 | pure x 485 | 486 | -- (2) we need to run the inner continuation, resetting the masking state 487 | -- when done 488 | in K.runCont (runMiniFu (ma umask)) (Mask ms0 . k) 489 | 490 | -- (3) we need to change the masking state 491 | , threadMask = ms 492 | } 493 | ``` 494 | 495 | The explicit type signature on `umask` is needed because we're using 496 | `GADTs`, which implies `MonoLocalBinds`, which prevents the 497 | polymorphic type from being inferred. We could achieve the same 498 | effect by turning on `NoMonoLocalBinds`. 499 | 500 | ### Demo 501 | 502 | Now we have asynchronous exceptions, check it out: 503 | 504 | ```haskell 505 | example_async :: MiniFu m String 506 | example_async = do 507 | a <- newEmptyMVar 508 | tid <- fork (putMVar a "hello from the other thread") 509 | throwTo tid E.ThreadKilled 510 | readMVar a 511 | 512 | demo_async :: IO () 513 | demo_async = do 514 | g <- R.newStdGen 515 | print . fst =<< minifu randomSched g example_async 516 | ``` 517 | 518 | See: 519 | 520 | ``` 521 | λ> demo_async 522 | Just "hello from the other thread" 523 | λ> demo_async 524 | Just "hello from the other thread" 525 | λ> demo_async 526 | Nothing 527 | ``` 528 | 529 | Next time... 530 | ------------ 531 | 532 | We have come to the end of part 2! Again, I hope you enjoyed this 533 | post, any feedback is welcome. This is all on [GitHub][], and you can 534 | see the code we ended up with at the "post-02" tag. 535 | 536 | Once again, I have some homework for you. Your task, should you 537 | choose to accept it, is to implement: 538 | 539 | ```haskell 540 | tryPutMVar :: MVar m a -> a -> MiniFu m Bool 541 | 542 | tryTakeMVar :: MVar m a -> MiniFu m (Maybe a) 543 | 544 | tryReadMVar :: MVar m a -> MiniFu m (Maybe a) 545 | ``` 546 | 547 | Solutions will be up in a few days, as before, at the "homework-02" 548 | tag. 549 | 550 | Stay tuned because next time we're going to implement STM: all of it 551 | in one go. Then we can finally get on to the testing. 552 | 553 | --- 554 | 555 | Thanks to [Will Sewell][] for reading an earlier draft of this post. 556 | 557 | [Will Sewell]: https://twitter.com/willsewell_ 558 | --------------------------------------------------------------------------------