Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 6b3044a0 by David Eichmann at 2026-05-30T11:58:48-04:00 Add code comments to allocator code - - - - - f4e04210 by Matthew Pickering at 2026-05-30T11:59:34-04:00 hadrian: Refactor system-cxx-std-lib rules I noticed a few things wrong with the hadrian rules for `system-cxx-std-lib` rules. * For `text` there is an ad-hoc check to depend on `system-cxx-std-lib` outside of `configurePackage`. * The `system-cxx-std-lib` dependency is not read from cabal files. * Recache is not called on the packge database after the `.conf` file is generated, a more natural place for this rule is `registerRules`. Treating this uniformly like other packages is complicated by it not having any source code or a cabal file. However we can do a bit better by reporting the dependency firstly in `PackageData` and then needing the `.conf` file in the same place as every other package in `configurePackage`. This commit increases the `shakeVersion`, to provide backwards compatibility to previous builds with different PackageData. Fixes #25303 Co-authored-by: Sven Tennie - - - - - 2224e4eb by Simon Jakobi at 2026-06-02T00:13:09-04:00 compiler: use nubOrd from containers Address #27103 by replacing GHC.Utils.Misc.ordNub[On] with Data.Containers.ListUtils.nubOrd[On]. Note that nubOrd suffers from a small inefficiency, a fix for which will be included in the next containers release: https://github.com/haskell/containers/issues/1202 - - - - - 13652abf by David Eichmann at 2026-06-02T00:13:10-04:00 Hadrian: disable response files for GHC/Haddock builders on non-Windows This makes debugging build errors easier on non-windows hosts. See issue #27230 - - - - - 20 changed files: - + changelog.d/hadrian-system-cxx-std-lib-25303 - compiler/GHC/CmmToAsm/BlockLayout.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Linker/Unit.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Utils/Misc.hs - ghc/GHCi/UI.hs - hadrian/src/Builder.hs - hadrian/src/Hadrian/Haskell/Cabal/Parse.hs - hadrian/src/Hadrian/Haskell/Cabal/Type.hs - hadrian/src/Hadrian/Utilities.hs - hadrian/src/Main.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Register.hs - rts/sm/BlockAlloc.c - rts/sm/MBlock.c Changes: ===================================== changelog.d/hadrian-system-cxx-std-lib-25303 ===================================== @@ -0,0 +1,22 @@ +section: packaging +synopsis: Fix Hadrian rules for system-cxx-std-lib package dependency +issues: #25303 +mrs: !16013 +description: { + Hadrian's handling of the `system-cxx-std-lib` virtual package has been + fixed and made more uniform. + + Previously, `text` had an ad-hoc rule outside of `configurePackage` to + declare a dependency on `system-cxx-std-lib`, the dependency was not + discovered from cabal files, and the package database was not recached after + the `.conf` file was generated. + + The dependency is now read from cabal files via a new + `dependsOnSystemCxxStdLib` field in `PackageData`, and the `.conf` file + is needed inside `configurePackage` alongside all other package + dependencies, consistent with how every other package is handled. + + `shakeVersion` has been bumped to ensure existing build databases are + invalidated when upgrading, preventing binary deserialisation errors due to + the changed `PackageData` type. +} ===================================== compiler/GHC/CmmToAsm/BlockLayout.hs ===================================== @@ -36,6 +36,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import Data.Containers.ListUtils (nubOrd) import Data.List (sortOn, sortBy, nub) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE @@ -426,7 +427,7 @@ combineNeighbourhood edges chains applyEdges :: [CfgEdge] -> FrontierMap -> FrontierMap -> Set.Set (BlockId, BlockId) -> ([BlockChain], Set.Set (BlockId,BlockId)) applyEdges [] chainEnds _chainFronts combined = - (ordNub $ map snd $ mapElems chainEnds, combined) + (nubOrd $ map snd $ mapElems chainEnds, combined) applyEdges ((CfgEdge from to _w):edges) chainEnds chainFronts combined | Just (c1_e,c1) <- mapLookup from chainEnds , Just (c2_f,c2) <- mapLookup to chainFronts ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -76,6 +76,7 @@ import GHC.Data.FastString import qualified GHC.Data.EnumSet as EnumSet import qualified GHC.Data.ShortText as ST +import Data.Containers.ListUtils (nubOrd) import Data.List ( partition ) import System.Exit import Control.Monad @@ -763,14 +764,14 @@ hsunitModuleGraph do_link unit = do let inodes = instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env) -- TODO: Backpack mode does not properly support ExternalPackage nodes yet -- Module nodes do not get given package dependencies (see hsModuleToModSummary). - let pkg_nodes = ordNub $ map (\(_, iud) -> UnitNode [] (instUnitInstanceOf iud)) inodes + let pkg_nodes = nubOrd $ map (\(_, iud) -> UnitNode [] (instUnitInstanceOf iud)) inodes let graph_nodes = nodes ++ req_nodes ++ (map (uncurry InstantiationNode) $ inodes) ++ pkg_nodes key_nodes = map mkNodeKey graph_nodes all_nodes = graph_nodes ++ [LinkNode key_nodes (homeUnitId $ hsc_home_unit hsc_env) | do_link] -- This error message is not very good but .bkp mode is just for testing so -- better to be direct rather than pretty. when - (length key_nodes /= length (ordNub key_nodes)) + (length key_nodes /= length (nubOrd key_nodes)) (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes)) -- 3. Return the kaboodle ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -25,7 +25,6 @@ import qualified GHC.Unit.State as State import GHC.Types.SrcLoc import GHC.Types.SourceError -import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable as Outputable import GHC.Utils.Monad ( liftIO, mapMaybeM ) @@ -35,6 +34,7 @@ import System.IO import System.Exit import System.FilePath import Control.Monad +import Data.Containers.ListUtils (nubOrdOn) import Data.List ( partition, (\\) ) import qualified Data.Set as Set import GHC.Prelude @@ -204,7 +204,7 @@ checkDuplicateUnits dflags flags = where uids = map (second homeUnitId_) flags - deduplicated_uids = ordNubOn snd uids + deduplicated_uids = nubOrdOn snd uids duplicate_ids = Set.fromList (map snd uids \\ map snd deduplicated_uids) duplicate_flags = filter (flip Set.member duplicate_ids . snd) uids ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -32,6 +32,7 @@ import GHC.Unit.Module.Deps import GHC.Data.Maybe import GHC.Data.FastString +import Data.Containers.ListUtils (nubOrdOn) import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map @@ -180,7 +181,7 @@ the TH splice. -- modules and direct object files for pkg dependencies mkObjectUsage :: Plugins -> FinderCache -> [LinkableUsage] -> PkgsLoaded -> IO [Usage] mkObjectUsage plugins fc th_links_needed th_pkgs_needed = do - let ls = ordNubOn linkableModule (th_links_needed ++ plugins_links_needed) + let ls = nubOrdOn linkableModule (th_links_needed ++ plugins_links_needed) ds = concatMap loaded_pkg_hs_objs $ eltsUDFM (plusUDFM th_pkgs_needed plugin_pkgs_needed) -- TODO possibly record loaded_pkg_non_hs_objs as well (plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps plugins concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds) ===================================== compiler/GHC/Linker/Unit.hs ===================================== @@ -25,6 +25,7 @@ import qualified GHC.Data.ShortText as ST import GHC.Settings import Control.Monad +import Data.Containers.ListUtils (nubOrd) import Data.List (nub) import Data.Semigroup ( Semigroup(..) ) import System.Directory @@ -95,7 +96,7 @@ collectArchives namever ways pc = filterM doesFileExist [ searchPath ("lib" ++ lib ++ ".a") | searchPath <- searchPaths , lib <- libs ] - where searchPaths = ordNub . filter notNull . libraryDirsForWay ways $ pc + where searchPaths = nubOrd . filter notNull . libraryDirsForWay ways $ pc libs = unitHsLibs namever ways pc ++ (map ST.unpack . unitExtDepLibsStaticSys $ pc) getLibs :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO [(String,String)] ===================================== compiler/GHC/Rename/Pat.hs ===================================== @@ -79,6 +79,7 @@ import GHC.Core.TyCon ( isKindName ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad ( when, ap, guard, unless ) +import Data.Containers.ListUtils (nubOrdOn) import Data.Foldable import Data.Function ( on ) import Data.Functor.Identity ( Identity (..) ) @@ -667,7 +668,7 @@ rnPatAndThen mk (OrPat _ pats) ; pats' <- rnLPatsAndThen mk pats ; let bndrs = collectPatsBinders CollVarTyVarBinders (NE.toList pats') ; liftCps $ setSrcSpan loc $ checkErr (null bndrs) $ - TcRnOrPatBindsVariables (NE.fromList (ordNubOn getOccName bndrs)) + TcRnOrPatBindsVariables (NE.fromList (nubOrdOn getOccName bndrs)) ; return (OrPat noExtField pats') } rnPatAndThen mk (SumPat _ pat alt arity) ===================================== compiler/GHC/Unit/Info.hs ===================================== @@ -49,6 +49,7 @@ import GHC.Unit.Database import GHC.Settings +import Data.Containers.ListUtils (nubOrd) import Data.Version import Data.Bifunctor import Data.List (isPrefixOf, stripPrefix) @@ -185,7 +186,7 @@ mkUnitPprInfo ufs i = UnitPprInfo -- | Find all the include directories in the given units collectIncludeDirs :: [UnitInfo] -> [FilePath] -collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps)) +collectIncludeDirs ps = map ST.unpack $ nubOrd (filter (not . ST.null) (concatMap unitIncludeDirs ps)) -- | Find all the C-compiler options in the given units collectExtraCcOpts :: [UnitInfo] -> [String] @@ -193,7 +194,7 @@ collectExtraCcOpts ps = map ST.unpack (concatMap unitCcOptions ps) -- | Find all the library directories in the given units for the given ways collectLibraryDirs :: Ways -> [UnitInfo] -> [FilePath] -collectLibraryDirs ws = ordNub . filter notNull . concatMap (libraryDirsForWay ws) +collectLibraryDirs ws = nubOrd . filter notNull . concatMap (libraryDirsForWay ws) -- | Find all the frameworks in the given units collectFrameworks :: [UnitInfo] -> [String] @@ -201,7 +202,7 @@ collectFrameworks ps = map ST.unpack (concatMap unitExtDepFrameworks ps) -- | Find all the package framework paths in these and the preload packages collectFrameworksDirs :: [UnitInfo] -> [String] -collectFrameworksDirs ps = map ST.unpack (ordNub (filter (not . ST.null) (concatMap unitExtDepFrameworkDirs ps))) +collectFrameworksDirs ps = map ST.unpack (nubOrd (filter (not . ST.null) (concatMap unitExtDepFrameworkDirs ps))) -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. libraryDirsForWay :: Ways -> UnitInfo -> [String] ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -112,6 +112,7 @@ import GHC.Utils.Exception import System.Directory import System.FilePath as FilePath import Control.Monad +import Data.Containers.ListUtils (nubOrd) import Data.Graph (stronglyConnComp, SCC(..)) import Data.Char ( toUpper ) import Data.List ( intersperse, partition, sortBy, sortOn, sort ) @@ -1705,7 +1706,7 @@ mkUnitState logger cfg = do basicLinkedUnits = fmap (RealUnit . Definite) $ filter (flip elemUniqMap pkg_db) $ unitConfigAutoLink cfg - preload3 = ordNub $ (basicLinkedUnits ++ preload1) + preload3 = nubOrd $ (basicLinkedUnits ++ preload1) -- Close the preload packages with their dependencies dep_preload <- mayThrowUnitErr ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -59,7 +59,7 @@ module GHC.Utils.Misc ( replaceAt, dropTail, capitalise, -- * Sorting - sortWith, minWith, nubSort, ordNub, ordNubOn, + sortWith, minWith, nubSort, -- * Comparisons isEqual, @@ -570,23 +570,6 @@ minWith get_key xs = assert (not (null xs) ) nubSort :: Ord a => [a] -> [a] nubSort = Set.toAscList . Set.fromList --- | Remove duplicates but keep elements in order. --- O(n * log n) -ordNub :: Ord a => [a] -> [a] -ordNub xs = ordNubOn id xs - --- | Remove duplicates but keep elements in order. --- O(n * log n) -ordNubOn :: Ord b => (a -> b) -> [a] -> [a] -ordNubOn f xs - = go Set.empty xs - where - go _ [] = [] - go s (x:xs) - | Set.member (f x) s = go s xs - | otherwise = x : go (Set.insert (f x) s) xs - - {- ************************************************************************ * * ===================================== ghc/GHCi/UI.hs ===================================== @@ -128,6 +128,7 @@ import Control.Monad.Trans.Except import Data.Array import qualified Data.ByteString.Char8 as BS import Data.Char +import Data.Containers.ListUtils (nubOrd) import Data.Function import qualified Data.Foldable as Foldable import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) @@ -786,7 +787,7 @@ installInteractiveHomeUnits dflags = do -- This is mostly for a clear separation of concerns, -- to indicate we only care about unit dependencies from package dbs. & filter (not . selectHptFlag (HUG.allUnits $ hsc_HUG hsc_env)) - & ordNub + & nubOrd else packageFlags dflags0 @@ -871,7 +872,7 @@ installInteractiveHomeUnits dflags = do prefix = longestCommonPrefix stacks in - prefix ++ ordNub (concatMap (List.drop (length prefix)) stacks) + prefix ++ nubOrd (concatMap (List.drop (length prefix)) stacks) reportError :: GhciMonad m => GhciCommandMessage -> m () reportError err = do @@ -1249,7 +1250,7 @@ generatePromptFunctionFromString promptS modules_names line = processString ('%':'s':xs) = liftM2 (<>) (return modules_list) (processString xs) where - modules_list = hsep . map text . ordNub $ modules_names + modules_list = hsep . map text . nubOrd $ modules_names processString ('%':'l':xs) = liftM2 (<>) (return $ ppr line) (processString xs) processString ('%':'d':xs) = ===================================== hadrian/src/Builder.hs ===================================== @@ -39,7 +39,6 @@ import Packages import GHC.IO.Encoding (getFileSystemEncoding) import qualified Data.ByteString as BS import qualified GHC.Foreign as GHC -import GHC.ResponseFile import GHC.Toolchain (Target(..)) import qualified GHC.Toolchain as Toolchain @@ -346,7 +345,15 @@ instance H.Builder Builder where Haddock BuildPackage -> runHaddock path buildArgs buildInputs - Ghc _ _ -> runGhcWithResponse path buildArgs buildInputs buildOptions + Ghc _ _ -> + -- Use a response file for ghc invocations to avoid issues with command line + -- size limit on Windows (#26637). + -- NB: we can't put the buildArgs in a response file, because some flags require + -- empty arguments (such as the -dep-suffix flag), but that isn't supported + -- yet due to #26560. + withResponseFileOnWindows + (\buildInputs' -> cmd [path] buildArgs buildInputs' buildOptions) + buildInputs HsCpp -> captureStdout @@ -380,29 +387,15 @@ instance H.Builder Builder where _ -> cmd' [path] buildArgs buildOptions --- | Invoke @haddock@ given a path to it and a list of arguments. The arguments --- are passed in a response file. +-- | Invoke @haddock@ given a path to it and a list of arguments. On Windows, +-- the input file arguments are passed as a response file. runHaddock :: FilePath -- ^ path to @haddock@ -> [String] -> [FilePath] -- ^ input file paths -> Action () -runHaddock haddockPath flagArgs fileInputs = withResponseFile $ \tmp -> do - writeFile' tmp $ escapeArgs fileInputs - cmd [haddockPath] flagArgs ('@' : tmp) - --- | Use a response file for ghc invocations to avoid issues with command line --- size limit on Windows (#26637). -runGhcWithResponse :: FilePath -- ^ Path to ghc - -> [String] -- ^ Arguments passed on the command line - -> [FilePath] -- ^ Input file paths (passed via response file) - -> [CmdOption] - -> Action () -runGhcWithResponse ghcPath buildArgs buildInputs buildOptions = withResponseFile $ \tmp -> do - -- We can't put the buildArgs in a response file, because some flags require - -- empty arguments (such as the -dep-suffix flag), but that isn't supported - -- yet due to #26560. - writeFile' tmp (escapeArgs buildInputs) - cmd [ghcPath] buildArgs ('@' : tmp) buildOptions +runHaddock haddockPath flagArgs fileInputs = withResponseFileOnWindows + (cmd [haddockPath] flagArgs) + fileInputs -- TODO: Some builders are required only on certain platforms. For example, -- 'Objdump' is only required on OpenBSD and AIX. Add support for platform ===================================== hadrian/src/Hadrian/Haskell/Cabal/Parse.hs ===================================== @@ -81,10 +81,11 @@ parsePackageData pkg = do sorted = sort [ C.unPackageName p | C.Dependency p _ _ <- allDeps ] deps = nubOrd sorted \\ [name] depPkgs = mapMaybe findPackageByName deps + cxxStdLib = elem "system-cxx-std-lib" deps return $ PackageData name version (C.fromShortText (C.synopsis pd)) (C.fromShortText (C.description pd)) - depPkgs gpd + depPkgs cxxStdLib gpd where -- Collect an overapproximation of dependencies by ignoring conditionals collectDeps :: Maybe (C.CondTree v [C.Dependency] a) -> [C.Dependency] @@ -138,7 +139,9 @@ configurePackage :: Context -> Action () configurePackage context@Context {..} = do putProgressInfo $ "| Configure package " ++ quote (pkgName package) gpd <- pkgGenericDescription package - depPkgs <- packageDependencies <$> readPackageData package + pd <- readPackageData package + let depPkgs = packageDependencies pd + needSystemCxxStdLib = dependsOnSystemCxxStdLib pd -- Stage packages are those we have in this stage. stagePkgs <- stagePackages stage @@ -157,7 +160,12 @@ configurePackage context@Context {..} = do -- We'll need those packages in our package database. deps <- sequence [ pkgConfFile (context { package = pkg, iplace = forceBaseAfterGhcInternal pkg }) | pkg <- depPkgs, pkg `elem` stagePkgs ] - need $ extraPreConfigureDeps ++ deps + -- system-cxx-std-lib is magic.. it doesn't have a cabal file or source code, so we have + -- to treat it specially as `pkgConfFile` uses `readPackageData` to compute the version. + systemCxxStdLib <- sequence [ systemCxxStdLibConfPath (PackageDbLoc stage iplace) | needSystemCxxStdLib ] + need $ extraPreConfigureDeps + ++ deps + ++ systemCxxStdLib -- Figure out what hooks we need. let configureFile = replaceFileName (pkgCabalFile package) "configure" ===================================== hadrian/src/Hadrian/Haskell/Cabal/Type.hs ===================================== @@ -30,6 +30,7 @@ data PackageData = PackageData , synopsis :: String , description :: String , packageDependencies :: [Package] + , dependsOnSystemCxxStdLib :: Bool , genericPackageDescription :: GenericPackageDescription } deriving (Eq, Generic, Show) ===================================== hadrian/src/Hadrian/Utilities.hs ===================================== @@ -14,7 +14,7 @@ module Hadrian.Utilities ( -- * Paths BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource, - KeepResponseFiles (..), keepResponseFiles, withResponseFile, + KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileOnWindows, -- * File system operations copyFile, copyFileUntracked, createFileLink, fixFile, @@ -48,8 +48,11 @@ import Data.Typeable (TypeRep, typeOf) import Development.Shake hiding (Normal) import Development.Shake.Classes import Development.Shake.FilePath +import GHC.ResponseFile (escapeArgs) import System.Environment (lookupEnv) +import System.Info.Extra (isWindows) import System.IO (hClose, openTempFile) +import System.IO.Error (isPermissionError) import qualified Data.ByteString as BS import qualified Control.Exception.Base as IO @@ -57,8 +60,7 @@ import qualified Data.HashMap.Strict as Map import qualified System.Directory.Extra as IO import qualified System.Info.Extra as IO import qualified System.IO as IO -import System.IO.Error (isPermissionError) -import qualified System.FilePath.Posix as Posix +import qualified System.FilePath.Posix as Posix -- | Extract a value from a singleton list, or terminate with an error message -- if the list does not contain exactly one value. @@ -328,6 +330,21 @@ keepResponseFiles = do KeepResponseFiles keep <- userSetting (KeepResponseFiles False) return keep +-- | Run an action either with command arguments direcly or by, on Windows, +-- placing those arguments into a response file escaped with @GHC.ResponseFile.escapeArgs@. +-- +-- With @--keep-response-files@, the file is left on disk (if used) +withResponseFileOnWindows :: + ([String] -> Action a) -- ^ Action to perform given arguments (of the form @["\@reponseFilePath"]@ on Windows) + -> [String] -- ^ Command arguments + -> Action a +withResponseFileOnWindows action commandArgs = do + if isWindows + then withResponseFile $ \tmp -> do + writeFile' tmp (escapeArgs commandArgs) + action ['@' : tmp] + else action commandArgs + -- | Run an action with a response file path. -- -- With @--keep-response-files@, the file is left on disk. ===================================== hadrian/src/Main.hs ===================================== @@ -63,7 +63,13 @@ main = do shakeColor <- shouldUseColor let options :: ShakeOptions options = shakeOptions - { shakeChange = ChangeModtimeAndDigest + { -- Bump shakeVersion whenever a type stored in the Shake oracle + -- changes its Binary representation (e.g. fields added/removed + -- from PackageData or other oracle value types). This forces + -- Shake to wipe the stale database instead of crashing on + -- deserialisation. + shakeVersion = "2" + , shakeChange = ChangeModtimeAndDigest , shakeFiles = buildRoot -/- Base.shakeFilesDir , shakeProgress = Progress.hadrianProgress cwd , shakeRebuild = rebuild ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -242,9 +242,6 @@ copyRules = do prefix -/- "html/**" <~ return "utils/haddock/haddock-api/resources" prefix -/- "latex/**" <~ return "utils/haddock/haddock-api/resources" - forM_ [Inplace, Final] $ \iplace -> - root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- systemCxxStdLibConf %> \file -> do - copyFile ("mk" -/- "system-cxx-std-lib-1.0.conf") file generateRules :: Rules () generateRules = do ===================================== hadrian/src/Rules/Register.hs ===================================== @@ -6,7 +6,6 @@ module Rules.Register ( import Base import Context -import Flavour import Oracles.Setting import Hadrian.BuildPath import Hadrian.Expression @@ -48,14 +47,6 @@ configurePackageRules = do isGmp <- (== "gmp") <$> interpretInContext ctx getBignumBackend when isGmp $ need [buildP -/- "include/ghc-gmp.h"] - when (pkg == text) $ do - simdutf <- textWithSIMDUTF <$> flavour - when simdutf $ do - -- This is required, otherwise you get Error: hadrian: - -- Encountered missing or private dependencies: - -- system-cxx-std-lib ==1.0 - cxxStdLib <- systemCxxStdLibConfPath $ PackageDbLoc stage Inplace - need [cxxStdLib] Cabal.configurePackage ctx root -/- "**/autogen/cabal_macros.h" %> \out -> do @@ -105,6 +96,12 @@ registerPackageRules rs stage iplace = do target (Context stage compiler vanilla iplace) (GhcPkg Recache stage) [] [] writeFileLines stamp [] + -- Special rule for registering system-cxx-std-lib + root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- systemCxxStdLibConf %> \file -> do + copyFile ("mk" -/- "system-cxx-std-lib-1.0.conf") file + buildWithResources rs $ + target (Context stage compiler vanilla iplace) (GhcPkg Recache stage) [] [] + -- Register a package. root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- "*.conf" %> \conf -> do historyDisable ===================================== rts/sm/BlockAlloc.c ===================================== @@ -549,6 +549,8 @@ allocGroupOnNode (uint32_t node, W_ n) ln++; } + // If no free blocks exist then allocate a new megablock and keep just a + // chunk of it. if (ln == NUM_FREE_LISTS) { #if 0 /* useful for debugging fragmentation */ if ((W_)mblocks_allocated * BLOCKS_PER_MBLOCK * BLOCK_SIZE_W @@ -1020,6 +1022,9 @@ freeGroup(bdescr *p) } // coalesce backwards + // Note that p is not a megablock/megagroup, so there are still live blocks on + // this megablock. Hence we can't coalesce backwards past the first block + // descriptor of this megablock. if (p != FIRST_BDESCR(MBLOCK_ROUND_DOWN(p))) { bdescr *prev; ===================================== rts/sm/MBlock.c ===================================== @@ -95,6 +95,10 @@ typedef struct free_list { } free_list; static free_list *free_list_head; + +// The address in `mblock_address_space` just after the highest MBlock. This +// will be the address of the next new MBlock committed when the free list is +// empty. static W_ mblock_high_watermark; /* * it is quite important that these are in the same cache line as they @@ -103,22 +107,47 @@ static W_ mblock_high_watermark; */ struct mblock_address_range mblock_address_space = { 0, 0, {} }; +// Search for the first committed MBlock at or after startingAt. +// +// start_iter [in/out]: The free_list or a subset of it. Must contain all +// entries for MBlocks at or after startingAt. On return this is set to the +// free_list entry just after the returned MBlock. If no MBlock was found, This +// is set to NULL (the search will have reached the end of the free list). +// +// startingAt [in]: address from which to start searching. This must be to the +// start of an MBlock. +// +// return: The address of the committed MBlock. NULL if no committed MBLock was +// found. +// static void *getAllocatedMBlock(free_list **start_iter, W_ startingAt) { + // We simultaneously traverse the free list and the mblock_address_space. free_list *iter; W_ p = startingAt; for (iter = *start_iter; iter != NULL; iter = iter->next) { + // The current free MBlock, `iter`, is past the current MBlock, `p`. + // This means that `p` is committed (if it was free, then we would have + // found it on the free list). Stop searching. if (p < iter->address) break; + // Note that if `p > iter->address`, then we don't bump `p`. This just + // means we are skipping entries in the free list that correspond to + // MBlocks before `startingAt`. if (p == iter->address) + // Move to the next MBlock. The MBlock may be committed, + // uncommitted, or even past mblock_high_watermark. p += iter->size; } + // Output current free list entry. *start_iter = iter; + // If we reached mblock_high_watermark, then we didn't find any committed + // MBlocks. if (p >= mblock_high_watermark) return NULL; @@ -152,6 +181,11 @@ void * getNextMBlock(void **state STG_UNUSED, void *mblock) return getAllocatedMBlock(casted_state, (W_)mblock + MBLOCK_SIZE); } +// Used to implement getCommittedMBlocks. Search the free list for n contiguous +// free MBlocks, and commit those MBlocks, updating the free_list. Returns the +// address of the start of those MBlocks. Returns NULL if no n contiguous +// MBlocks were found in the free list. Unlike getFreshMBlocks, this doesn't +// attempt to allocate new MBlocks past mblock_high_watermark. static void *getReusableMBlocks(uint32_t n) { struct free_list *iter; @@ -163,7 +197,10 @@ static void *getReusableMBlocks(uint32_t n) if (iter->size < size) continue; + // We've found a large enough group of MBlocks. addr = (void*)iter->address; + + // Update the free list. iter->address += size; iter->size -= size; if (iter->size == 0) { @@ -190,6 +227,9 @@ static void *getReusableMBlocks(uint32_t n) return NULL; } +// Used to implement getCommittedMBlocks. Commit n new MBlocks starting at +// mblock_high_watermark. May exit with an out of memory error if we've passed +// mblock_address_space.end (this is unlikely). static void *getFreshMBlocks(uint32_t n) { W_ size = MBLOCK_SIZE * (W_)n; @@ -207,6 +247,8 @@ static void *getFreshMBlocks(uint32_t n) return addr; } +// Commit n new MBlocks. Tries to reuse freed MBlocks, else commits new +// MBlock(s) at mblock_high_watermark. static void *getCommittedMBlocks(uint32_t n) { void *p; @@ -220,6 +262,11 @@ static void *getCommittedMBlocks(uint32_t n) return p; } +// Decommit n contiguous MBlocks starting at the given address. +// +// addr [in]: address of the start of the n MBlocks (in mblock_address_space). +// +// n [in]: number of contiguous MBlocks to decommit. static void decommitMBlocks(char *addr, uint32_t n) { struct free_list *iter, *prev; @@ -228,17 +275,24 @@ static void decommitMBlocks(char *addr, uint32_t n) osDecommitMemory(addr, size); + // Update the free list. prev = NULL; for (iter = free_list_head; iter != NULL; iter = iter->next) { prev = iter; + // iter is still entirely behind and not contiguous with the MBlocks so + // continue traversing free_list. if (iter->address + iter->size < address) continue; + // The MBlocks are after and contiguous to iter. Simply modify the + // current entry to include n more MBlocks and possibly coalesce. if (iter->address + iter->size == address) { iter->size += size; + // If the current free_list entry now reaches mblock_high_watermark, + // remove the entry and decrement mblock_high_watermark. if (address + size == mblock_high_watermark) { mblock_high_watermark -= iter->size; if (iter->prev) { @@ -251,6 +305,8 @@ static void decommitMBlocks(char *addr, uint32_t n) return; } + // If the current free_list entry now reaches the next free_list + // entry, coalesce them. if (iter->next && iter->next->address == iter->address + iter->size) { struct free_list *next; @@ -269,6 +325,8 @@ static void decommitMBlocks(char *addr, uint32_t n) stgFree(next); } return; + + // The MBlocks are before and contiguous to iter. } else if (address + size == iter->address) { iter->address = address; iter->size += size; @@ -280,6 +338,9 @@ static void decommitMBlocks(char *addr, uint32_t n) ASSERT(iter->prev->address + iter->prev->size < iter->address); } return; + + // The MBlocks are before and not contiguous to iter. Insert a new entry + // just before iter. } else { struct free_list *new_iter; @@ -311,6 +372,7 @@ static void decommitMBlocks(char *addr, uint32_t n) if (address + size == mblock_high_watermark) { mblock_high_watermark -= size; } else { + // Add a new entry to the end of the free list. struct free_list *new_iter; new_iter = stgMallocBytes(sizeof(struct free_list), "freeMBlocks"); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c80f15faa8059f87825f586b3752084... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c80f15faa8059f87825f586b3752084... You're receiving this email because of your account on gitlab.haskell.org.