Rodrigo Mesquita pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC Commits: e53ad1ff by Rodrigo Mesquita at 2026-08-13T16:52:56+01:00 mroe fixes - - - - - 1 changed file: - compiler/GHC/Driver/Downsweep.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -179,8 +179,9 @@ incrementally constructing a ModuleGraph using the GHC API; See #27054). So `downsweep` takes a `Maybe ModuleGraph` as one of its arguments. Downsweep iteratively *expands* each so-called 'DownsweepNode' into a list of -its dependencies, and recursively traverses all reachable nodes in a -depth-first order using 'dfsBuild'. A 'DownsweepNode' is *expanded* by 'dsNodeExpand': +its dependencies, and recursively traverses all reachable nodes in a parallel +non-det-depth-first order using 'parDfsBuild'. A 'DownsweepNode' is *expanded* +by 'dsNodeExpand': dsNodeExpand :: DownsweepNode -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode])) @@ -576,8 +577,8 @@ addModSummaryCache ms pr fe = upd_fe fe modifySummCache :: ModSummaryCache -> (ModSummaryCacheMap -> ModSummaryCacheMap) -> IO () modifyImpsCache :: ImportsCache -> (ImportsCacheMap -> ImportsCacheMap) -> IO () -modifySummCache r f = modifyMVar r (\c -> let !r = f c in pure (r, ())) -modifyImpsCache r f = modifyMVar r (\c -> let !r = f c in pure (r, ())) +modifySummCache v f = modifyMVar v (\c -> let !r = f c in pure (r, ())) +modifyImpsCache v f = modifyMVar v (\c -> let !r = f c in pure (r, ())) -- | A cache from a module import (in given home unit context, with a package -- qualifier, and the imported module name (with or without SOURCE)) to the @@ -1728,10 +1729,10 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do return PreprocessedImports {..} -------------------------------------------------------------------------------- --- * Generic traversal of iteratively-built graph: dfsBuild +-- * Generic traversal of iteratively-built graph: parDfsBuild -------------------------------------------------------------------------------- --- | The result of expanding a node in 'dfsBuild'. +-- | The result of expanding a node in 'parDfsBuild'. data NodeRes v -- | Computed the node payload successfully = NSuccess v @@ -1744,7 +1745,7 @@ data NodeRes v -- abort. | NSkip --- | In a parallel depth-first order, and starting from the given roots, traverse a +-- | In a parallel non-det-depth-first order, and starting from the given roots, traverse a -- graph by iteratively expanding a node into a payload and a list of children -- nodes to visit next. -- @@ -1757,7 +1758,7 @@ data NodeRes v -- The result is a mapping from the key of every node transitively reachable -- from the root nodes (inclusively) to the payload returned by expanding that -- node. The result includes the previously visited nodes given in @base_map@, --- s.t. @dfsBuild base_map [] _ _ == base_map@. +-- s.t. @parDfsBuild base_map [] _ _ == base_map@. -- -- The @expand@ function returns an 'NResult'. See the 'NResult' documentation -- for more information about each result type. @@ -1784,30 +1785,34 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do visited_var <- newTVarIO (fromMaybe Map.empty base_map) pending <- newTVarIO Set.empty worklist <- newTQueueIO + coord_tid <- forkIO $ coordinator ds_env exc_var visited_var worklist pending `MC.catch` \case (e::MC.SomeException) -- exit cleanly when killed - | Just ThreadKilled <- fromException e -> pure () - -- otherwise signal exc_var for the main thread to throw it + | Just ThreadKilled <- fromException e -> return () + -- if the coordinator somehow else crashes, + -- signal the exc_var for the main thread to throw it | otherwise -> atomically (modifyTVar' exc_var (<|> Just e)) + mapM_ (atomically . writeTQueue worklist) roots + + -- this txn retries until all work is done mb_exc <- atomically $ do readTVar exc_var >>= \case - Just e -> - -- exit if there's an exception - return (Just e) + Just e -> return (Just e) Nothing -> do - -- or exit when pending and worklist are both empty atomically; else, `retry`. empty_worklist <- isEmptyTQueue worklist empty_pending <- Set.null <$> readTVar pending unless (empty_worklist && empty_pending) retry return Nothing + killThread coord_tid case mb_exc of Just e -> throwIO e Nothing -> readTVarIO visited_var + where coordinator ds_env exc_var visvar worklist pendvar = forever $ do mb_node_to_expand <- atomically $ do @@ -1828,40 +1833,35 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do case mb_node_to_expand of Nothing -> return () - Just (k, node) -> do + Just (k, node) -> void $ do + let i = 1 -- tODO: not 1 withLocalTmpFSMake (ds_make_env ds_env) $ \make_env -> forkIO $ - worker ds_env{ds_make_env = make_env} exc_var visvar - worklist pendvar k node - `MC.catch` \(e::MC.SomeException) -> atomically (modifyTVar' exc_var (<|> Just e)) - return () + worker i 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)) - worker ds_env@DownsweepEnv{..} exc_var visvar worklist pendvar k node = + worker i ds_env@DownsweepEnv{..} visvar worklist pendvar k node = withAbstractSem (compile_sem ds_make_env) $ -- acquire -j par token - withLoggerHsc 1{- TODO: seq numb-} ds_make_env \ lcl_hsc_env -> do + withLoggerHsc i ds_make_env \ lcl_hsc_env -> do - r <- MC.try $ runDownsweepM ds_env{ds_hsc_env = lcl_hsc_env} $ + r <- runDownsweepM ds_env{ds_hsc_env = lcl_hsc_env} $ expand node -- do the main work! case r of - Left (e :: MC.SomeException) -> - -- signal exception in this thread for the main thread to throw it - atomically $ modifyTVar' exc_var (<|> Just e) - Right NSkip -> - -- write node skip; nothing new to queue + NSkip -> atomically $ modifyTVar' visvar (Map.insert k NSkip) - Right (NSuccess (v,ns)) -> do - -- write success result; queue the next nodes + NSuccess (v,ns) -> do atomically $ modifyTVar' visvar (Map.insert k (NSuccess v)) mapM_ (atomically . writeTQueue worklist) ns - -- no longer pending: atomically $ modifyTVar' pendvar (Set.delete k) {- Note [Downsweep Control Flow and Caching] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The control flow of downsweep is extracted into a single function `dfsBuild`, +The control flow of downsweep is extracted into a single function `parDfsBuild`, which takes care of iteratively expanding and traversing all nodes of the in-construction module graph necessary to build a full `ModuleGraph` at the end. @@ -1870,7 +1870,7 @@ There are three levels of caching going on, all of which are necessary to make sure we don't do repeated work (notably, we NEVER summarise the same module twice). -1. `dfsBuild` accumulates the final module graph and never revisits the +1. `parDfsBuild` accumulates the final module graph and never revisits the same node of the module graph. Cache is keyed by the final `ModuleGraph`s `NodeKey`s. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e53ad1ffb0bc4268d7cdb10dc7cb4f11... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e53ad1ffb0bc4268d7cdb10dc7cb4f11... 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