Rodrigo Mesquita pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC Commits: 02b3b6ee by Rodrigo Mesquita at 2026-08-14T13:32:58+01:00 fixup: Add mask_ to parent forkIOWithUnmask - - - - - c65f7a6e by Rodrigo Mesquita at 2026-08-14T13:38:13+01:00 fixup: reduce transactions, put together sequentially together ones - - - - - b8695cd3 by Rodrigo Mesquita at 2026-08-14T13:56:58+01:00 fixup: keep track of worker threads - - - - - 2 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/MakeAction.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -1787,9 +1787,10 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do visited_var <- newTVarIO (fromMaybe Map.empty base_map) pending <- newTVarIO Set.empty worklist <- newTQueueIO + threads <- newTVarIO [] coord_tid <- forkIO $ - coordinator ds_env exc_var visited_var worklist pending + coordinator ds_env exc_var visited_var worklist pending threads `MC.catch` \case (e::MC.SomeException) -- exit cleanly when killed @@ -1798,11 +1799,12 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do -- signal the exc_var for the main thread to throw it | otherwise -> atomically (modifyTVar' exc_var (<|> Just e)) - mapM_ (atomically . writeTQueue worklist) roots + atomically $ mapM_ (writeTQueue worklist) roots mb_exc <- wait_done exc_var worklist pending `MC.finally` do killThread coord_tid + mapM_ killThread =<< readTVarIO threads case mb_exc of Just e -> throwIO e @@ -1820,7 +1822,7 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do unless (empty_worklist && empty_pending) retry return Nothing - coordinator ds_env exc_var visvar worklist pendvar = forever $ do + coordinator ds_env exc_var visvar worklist pendvar threads = forever $ do mb_node_to_expand <- atomically $ do node <- readTQueue worklist let k = key node @@ -1839,27 +1841,32 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do case mb_node_to_expand of Nothing -> return () - Just (k, node) -> void $ do - withLocalTmpFSMake (ds_make_env ds_env) $ \make_env -> - forkIOWithUnmask $ \unmask -> + Just (k, node) -> do + tid <- withLocalTmpFSMake (ds_make_env ds_env) $ \make_env -> + MC.mask_ $ forkIOWithUnmask $ \unmask -> unmask (worker ds_env{ds_make_env = make_env} visvar worklist pendvar k node) - -- write exception in the worker to the main thread - `MC.catch` \(e::MC.SomeException) -> - atomically (modifyTVar' exc_var (<|> Just e)) + `MC.catch` \case + e | Just (_ :: SomeAsyncException) <- fromException e + -> throwIO e -- async exceptions like KillThread get thrown + | otherwise -- exceptions in workers are written for main thread + -> atomically (modifyTVar' exc_var (<|> Just e)) + + atomically $ modifyTVar' threads (tid:) worker ds_env@DownsweepEnv{..} visvar worklist pendvar k node = withAbstractSem (compile_sem ds_make_env) $ do r <- runDownsweepM ds_env $ expand node -- do the main work! - case r of - NSkip -> - atomically $ modifyTVar' visvar (Map.insert k NSkip) - NSuccess (v,ns) -> do - atomically $ modifyTVar' visvar (Map.insert k (NSuccess v)) - mapM_ (atomically . writeTQueue worklist) ns + atomically $ do + case r of + NSkip -> + modifyTVar' visvar (Map.insert k NSkip) + NSuccess (v,ns) -> do + modifyTVar' visvar (Map.insert k (NSuccess v)) + mapM_ (writeTQueue worklist) ns - atomically $ modifyTVar' pendvar (Set.delete k) + modifyTVar' pendvar (Set.delete k) {- Note [Downsweep Control Flow and Caching] ===================================== compiler/GHC/Driver/MakeAction.hs ===================================== @@ -185,7 +185,8 @@ runLoop fork_thread env (MakeAction act res_var :acts) = do -- withLocalTmpFs has to occur outside of fork to remain deterministic new_thread <- withLocalTmpFSMake env $ \lcl_env -> - fork_thread $ \unmask -> (do + MC.mask_ $ + fork_thread $ \unmask -> (do mres <- (unmask $ run_pipeline lcl_env act) `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure. putMVar res_var mres) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d333bb06f7fd6603543ada4bf399167... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d333bb06f7fd6603543ada4bf399167... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help