Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 8965cb76 by Marc Scholten at 2026-06-12T04:53:22-04:00 haddock: render modules concurrently - - - - - 6 changed files: - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-api/src/Haddock/Options.hs - utils/haddock/haddock-api/src/Haddock/Utils.hs Changes: ===================================== utils/haddock/haddock-api/haddock-api.cabal ===================================== @@ -97,6 +97,7 @@ library , filepath , ghc-boot , mtl + , semaphore-compat , transformers , text ===================================== utils/haddock/haddock-api/src/Haddock.hs ===================================== @@ -29,6 +29,7 @@ module Haddock ( withGhc ) where +import Control.Concurrent.MVar (modifyMVar, modifyMVar_, newMVar) import Control.DeepSeq (force) import Control.Monad hiding (forM_) import Control.Monad.IO.Class (MonadIO(..)) @@ -41,6 +42,7 @@ import Data.Maybe import Data.IORef import Data.Map.Strict (Map) import Data.Version (makeVersion) +import GHC.Conc (getNumProcessors) import GHC.Parser.Lexer (ParserOpts) import qualified GHC.Driver.Config.Parser as Parser import qualified Data.Map.Strict as Map @@ -84,11 +86,55 @@ import Haddock.Options import Haddock.Utils import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) import Haddock.Compat (getProcessID) +import System.Semaphore (AbstractSem(..), openSemaphore, releaseSemaphoreToken, waitOnSemaphore) -------------------------------------------------------------------------------- -- * Exception handling -------------------------------------------------------------------------------- +concSemChoiceFromFlags :: [Flag] -> Maybe (Either FilePath (Maybe Int)) +concSemChoiceFromFlags = + List.foldl' step Nothing + where + step _ (Flag_ParCount n) = Just (Right n) + step _ (Flag_ParSemaphore sem) = Just (Left sem) + step acc _ = acc + +-- | Build the render concurrency semaphore selected by Haddock's parallelism flags. +-- Without an explicit flag, render sequentially; @-j@ uses the host processor +-- count, @-jN@ uses a local bounded semaphore, and @-jsem@ joins the external +-- semaphore used for GHC jobserver coordination. +concSemFromChoice :: Maybe (Either FilePath (Maybe Int)) -> IO AbstractSem +concSemFromChoice choice = + case choice of + Nothing -> newBoundedSem 1 + Just (Right Nothing) -> newBoundedSem =<< getNumProcessors + Just (Right (Just n)) -> newBoundedSem n + Just (Left semName) -> do + openSemaphore semName >>= \case + Left err -> throwIO err + Right sem -> do + tokens <- newMVar [] + pure + AbstractSem + { acquireSem = mask $ \restore -> do + token <- restore (waitOnSemaphore sem) + modifyMVar_ tokens $ \held -> pure (token : held) + , releaseSem = mask_ $ do + token <- modifyMVar tokens $ \case + [] -> pure ([], Nothing) + heldToken : heldTokens -> pure (heldTokens, Just heldToken) + forM_ token releaseSemaphoreToken + } + +injectParFlags :: Maybe (Either FilePath (Maybe Int)) -> [Flag] -> [Flag] +injectParFlags choice flags = + case choice of + Nothing -> flags + Just (Right Nothing) -> Flag_OptGhc "-j" : flags + Just (Right (Just n)) -> Flag_OptGhc ("-j" ++ show n) : flags + Just (Left sem) -> Flag_OptGhc "-jsem" : Flag_OptGhc sem : flags + handleTopExceptions :: IO a -> IO a handleTopExceptions = @@ -177,11 +223,12 @@ haddockWithGhc ghc args = handleTopExceptions $ do Just "YES" | not noCompilation -> return $ Flag_OptGhc "-dynamic-too" : flags _ -> return flags - -- Inject `-j` into ghc options, if given to Haddock - flags' <- pure $ case optParCount flags'' of - Nothing -> flags'' - Just Nothing -> Flag_OptGhc "-j" : flags'' - Just (Just n) -> Flag_OptGhc ("-j" ++ show n) : flags'' + let parChoice = concSemChoiceFromFlags flags'' + + -- Inject parallelism flags into ghc options, if given to Haddock + flags' <- pure $ injectParFlags parChoice flags'' + + concSem <- concSemFromChoice parChoice -- Whether or not to bypass the interface version check let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags @@ -238,7 +285,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages ifaces + liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual concSem packages ifaces -- If we were not given any input files, error if documentation was -- requested @@ -251,7 +298,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages [] + liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual concSem packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a @@ -311,10 +358,11 @@ renderStep -> [Flag] -> SinceQual -> QualOption + -> AbstractSem -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs interfaces = do +renderStep dflags parserOpts logger unit_state flags sinceQual nameQual concSem pkgs interfaces = do updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) -> ( case baseUrl flags of Nothing -> docPathsHtml docPath @@ -330,7 +378,7 @@ renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs int (DocPaths {docPathsSources=Just path}, _, _, ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags parserOpts logger unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap + render dflags parserOpts logger unit_state flags sinceQual nameQual concSem interfaces installedIfaces extSrcMap where -- get package name from unit-id packageName :: Unit -> String @@ -348,11 +396,12 @@ render -> [Flag] -> SinceQual -> QualOption + -> AbstractSem -> [Interface] -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO () -render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages extSrcMap = do +render dflags parserOpts logger unit_state flags sinceQual qual concSem ifaces packages extSrcMap = do let packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty) $ optPackageName flags @@ -516,7 +565,7 @@ render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url opt_contents_url opt_index_url unicode sincePkg packageInfo - qual pretty withQuickjump + qual pretty concSem withQuickjump return () unless (withBaseURL || isJust (optOneShot flags)) $ do copyHtmlBits odir libDir themes withQuickjump @@ -555,7 +604,7 @@ render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do withTiming logger "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-} - ppHyperlinkedSource (verbosity flags) (isJust (optOneShot flags)) odir libDir opt_source_css pretty srcMap ifaces + ppHyperlinkedSource (verbosity flags) (isJust (optOneShot flags)) odir libDir opt_source_css pretty concSem srcMap ifaces return () @@ -842,4 +891,3 @@ getPrologue parserOpts flags = rightOrThrowE :: Either String b -> IO b rightOrThrowE (Left msg) = throwE msg rightOrThrowE (Right x) = pure x - ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs ===================================== @@ -31,7 +31,8 @@ import Haddock.Backends.Hyperlinker.Utils import Haddock.Backends.Xhtml.Utils (renderToBuilder) import Haddock.InterfaceFile import Haddock.Types -import Haddock.Utils (Verbosity, out, verbose) +import Haddock.Utils (Verbosity, out, verbose, mapConcurrentlyWith_) +import System.Semaphore (AbstractSem) import qualified Data.ByteString.Builder as Builder -- | Generate hyperlinked source for given interfaces. @@ -51,19 +52,21 @@ ppHyperlinkedSource -- ^ Custom CSS file path -> Bool -- ^ Flag indicating whether to pretty-print HTML + -> AbstractSem + -- ^ Concurrency semaphore for module renders -> M.Map Module SrcPath -- ^ Paths to sources -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource verbosity isOneShot outdir libdir mstyle pretty srcs' ifaces = do +ppHyperlinkedSource verbosity isOneShot outdir libdir mstyle pretty concSem srcs' ifaces = do createDirectoryIfMissing True srcdir unless isOneShot $ do let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir </> srcCssFile copyFile (libdir </> "html" </> highlightScript) $ srcdir </> highlightScript - mapM_ (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces + mapConcurrentlyWith_ concSem (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces where srcdir = outdir </> hypSrcDir srcs = (srcs', M.mapKeys moduleName srcs') ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs ===================================== @@ -69,6 +69,7 @@ import Haddock.ModuleTree import Haddock.Options (Visibility (..)) import Haddock.Types import Haddock.Utils +import System.Semaphore (AbstractSem) import Haddock.Utils.Json import Haddock.Version @@ -115,6 +116,8 @@ ppHtml -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) + -> AbstractSem + -- ^ Concurrency semaphore for module renders -> Bool -- ^ Also write Quickjump index -> IO () @@ -138,6 +141,7 @@ ppHtml packageInfo qual debug + concSem withQuickjump = do let visible_ifaces = filter visible ifaces @@ -192,7 +196,7 @@ ppHtml visible_ifaces [] - mapM_ + mapConcurrentlyWith_ concSem ( ppHtmlModule odir doctitle ===================================== utils/haddock/haddock-api/src/Haddock/Options.hs ===================================== @@ -29,6 +29,7 @@ module Haddock.Options , wikiUrls , baseUrl , optParCount + , optParSemaphore , optDumpInterfaceFile , optShowInterfaceFile , optLaTeXStyle @@ -48,7 +49,7 @@ module Haddock.Options import Control.Applicative import qualified Data.Char as Char -import Data.List (dropWhileEnd) +import Data.List (dropWhileEnd, isPrefixOf) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -122,6 +123,7 @@ data Flag | Flag_SinceQualification String | Flag_IgnoreLinkSymbol String | Flag_ParCount (Maybe Int) + | Flag_ParSemaphore FilePath | Flag_TraceArgs | Flag_OneShot String | Flag_NoCompilation @@ -406,6 +408,11 @@ options backwardsCompat = [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n") "load modules in parallel" + , Option + [] + ["jsem"] + (ReqArg Flag_ParSemaphore "SEM") + "use semaphore SEM to limit parallelism" , Option [] ["trace-args"] @@ -423,7 +430,7 @@ getUsage = do parseHaddockOpts :: [String] -> IO ([Flag], [String]) parseHaddockOpts params = - case getOpt Permute (options True) params of + case getOpt Permute (options True) (normalizeJsemArgs params) of (flags, args, []) -> return (flags, args) (_, _, errors) -> do usage <- getUsage @@ -498,6 +505,18 @@ optMathjax flags = optLast [str | Flag_Mathjax str <- flags] optParCount :: [Flag] -> Maybe (Maybe Int) optParCount flags = optLast [n | Flag_ParCount n <- flags] +optParSemaphore :: [Flag] -> Maybe FilePath +optParSemaphore flags = optLast [s | Flag_ParSemaphore s <- flags] + +normalizeJsemArgs :: [String] -> [String] +normalizeJsemArgs = map rewrite + where + rewrite arg + | arg == "-jsem" = "--jsem" + | "-jsem=" `isPrefixOf` arg = "--jsem=" ++ drop 6 arg + | "-jsem" `isPrefixOf` arg = "--jsem=" ++ drop 5 arg + | otherwise = arg + qualification :: [Flag] -> Either String QualOption qualification flags = case map (map Char.toLower) [str | Flag_Qualification str <- flags] of ===================================== utils/haddock/haddock-api/src/Haddock/Utils.hs ===================================== @@ -54,6 +54,10 @@ module Haddock.Utils , replace , spanWith + -- * Concurrency utilities + , mapConcurrentlyWith_ + , newBoundedSem + -- * Logging , parseVerbosity , Verbosity (..) @@ -86,6 +90,13 @@ import Haddock.Types import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as LText +import Control.Concurrent (forkFinally) +import Control.Concurrent.QSem (newQSem, signalQSem, waitQSem) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Exception (throwIO) +import Control.Monad (void) +import System.Semaphore (AbstractSem (..)) + -------------------------------------------------------------------------------- -- * Logging @@ -334,6 +345,43 @@ html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) html_xrefs' :: Map ModuleName FilePath html_xrefs' = unsafePerformIO (readIORef html_xrefs_ref') +-- * Concurrency utilities + +-------------------------------------------------------------------------------- + +mapConcurrentlyWith_ :: AbstractSem -> (a -> IO ()) -> [a] -> IO () +mapConcurrentlyWith_ _ _ [] = return () +mapConcurrentlyWith_ concSem f xs = do + -- Create MVars to wait for completion and collect results + resultMVars <- mapM (const newEmptyMVar) xs + + -- Fork a thread for each element + mapM_ (forkThread concSem) (zip xs resultMVars) + + -- Wait for all threads and collect any errors + results <- mapM takeMVar resultMVars + + -- Re-throw the first exception if any + case [err | Left err <- results] of + (err:_) -> throwIO err + [] -> return () + where + forkThread concSem' (x, resultMVar) = do + acquireSem concSem' + void $ forkFinally (f x) $ \res -> do + releaseSem concSem' + putMVar resultMVar res + +newBoundedSem :: Int -> IO AbstractSem +newBoundedSem maxThreads = do + sem <- newQSem (max 1 maxThreads) + pure + AbstractSem + { acquireSem = waitQSem sem + , releaseSem = signalQSem sem + } + + ----------------------------------------------------------------------------- -- * List utils View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8965cb762bb0478f2cb7377522ef39ee... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8965cb762bb0478f2cb7377522ef39ee... You're receiving this email because of your account on gitlab.haskell.org.