Last active
June 23, 2020 17:34
-
-
Save barrucadu/c3e4384074f3c7dcc15cf9dbe4d1b53d to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| data ThreadId = ThreadId | |
| { realThreadId :: Int | |
| , exceptionVariable :: TVar (Maybe SomeException) | |
| , canBeThrownTo :: TVar Bool | |
| } | |
| -- when a thread is created: canBeThrownTo depends on the masking state (True for Unmasked, False otherwise) | |
| -- when a thread is killed: canBeThrownTo is True | |
| --- | |
| -- throwTo becomes this: | |
| throwTo :: Exception e => ThreadId e -> IO () | |
| throwTo t@(ThreadId _ ve vb) e = synchronised . atomicallyU $ readTVar vb >>= \case | |
| True -> writeTVar ve (Just (toException e)) | |
| False -> retry | |
| -- all actions are transformed into this: | |
| transform :: ThreadId -> MaskingState -> Bool -> IO a -> IO a | |
| tranasform (ThreadId _ ve vb) ms thisIsARepeatOfABlockingAction a = case ms of | |
| Unmasked -> allowException | |
| MaskedInterruptible -> if thisIsARepeatOfABlockingAction then allowException else a | |
| MaskedUninterruptible -> a | |
| where | |
| allowException = do | |
| atomicallyU (writeTVar vb True) | |
| atomicallyU (writeTVar vb False >> readTVar ve) >>= \case | |
| Just e -> throwAsync e -- throw an async exception in the current thread | |
| Nothing -> a | |
| -- 'atomicallyU' is just 'atomically', but doesn't enforce a memory barrier |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment