| ... |
... |
@@ -62,7 +62,7 @@ import GHC.Data.OsPath ( OsPath, unsafeEncodeUtf ) |
|
62
|
62
|
import GHC.Data.StringBuffer
|
|
63
|
63
|
import GHC.Data.Graph.Directed.Reachability
|
|
64
|
64
|
|
|
65
|
|
-import GHC.Utils.Exception ( throwIO, SomeAsyncException )
|
|
|
65
|
+import GHC.Utils.Exception ( throwIO, SomeAsyncException, AsyncException (..) )
|
|
66
|
66
|
import GHC.Utils.Outputable
|
|
67
|
67
|
import GHC.Utils.Panic
|
|
68
|
68
|
import GHC.Utils.Misc
|
| ... |
... |
@@ -1786,7 +1786,12 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do |
|
1786
|
1786
|
worklist <- newTQueueIO
|
|
1787
|
1787
|
coord_tid <- forkIO $
|
|
1788
|
1788
|
coordinator ds_env exc_var visited_var worklist pending
|
|
1789
|
|
- `MC.catch` \(e::MC.SomeException) -> atomically (modifyTVar' exc_var (<|> Just e))
|
|
|
1789
|
+ `MC.catch` \case
|
|
|
1790
|
+ (e::MC.SomeException)
|
|
|
1791
|
+ -- exit cleanly when killed
|
|
|
1792
|
+ | Just ThreadKilled <- fromException e -> pure ()
|
|
|
1793
|
+ -- otherwise signal exc_var for the main thread to throw it
|
|
|
1794
|
+ | otherwise -> atomically (modifyTVar' exc_var (<|> Just e))
|
|
1790
|
1795
|
mapM_ (atomically . writeTQueue worklist) roots
|
|
1791
|
1796
|
mb_exc <- atomically $ do
|
|
1792
|
1797
|
readTVar exc_var >>= \case
|
| ... |
... |
@@ -1794,8 +1799,7 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do |
|
1794
|
1799
|
-- exit if there's an exception
|
|
1795
|
1800
|
return (Just e)
|
|
1796
|
1801
|
Nothing -> do
|
|
1797
|
|
- -- otherwise, exit only when pending and worklist are both empty,
|
|
1798
|
|
- -- *atomically*; else, `retry`.
|
|
|
1802
|
+ -- or exit when pending and worklist are both empty atomically; else, `retry`.
|
|
1799
|
1803
|
empty_worklist <- isEmptyTQueue worklist
|
|
1800
|
1804
|
empty_pending <- Set.null <$> readTVar pending
|
|
1801
|
1805
|
unless (empty_worklist && empty_pending) retry
|
| ... |
... |
@@ -1829,6 +1833,7 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do |
|
1829
|
1833
|
forkIO $
|
|
1830
|
1834
|
worker ds_env{ds_make_env = make_env} exc_var visvar
|
|
1831
|
1835
|
worklist pendvar k node
|
|
|
1836
|
+ `MC.catch` \(e::MC.SomeException) -> atomically (modifyTVar' exc_var (<|> Just e))
|
|
1832
|
1837
|
return ()
|
|
1833
|
1838
|
|
|
1834
|
1839
|
worker ds_env@DownsweepEnv{..} exc_var visvar worklist pendvar k node =
|