throwTo.hs

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