Alan Zimmerman pushed to branch wip/az/epa-tidy-locatedxxx-27 at Glasgow Haskell Compiler / GHC Commits: b3b89d32 by mangoiv at 2026-10-05T22:03:32-04:00 hadrian: Persist the used flavour name in the build root (#20650) This executes the idea proposed in #20650, teaching Hadrian to persist the flavour used to build a build root. This both makes use of multiple build roots more ergonomic (as the user no longer needs to repeat themselves) and avoids a tiresome foot-gun (forgetting to specify a flavour, often wholly invalidating a build root). Closes #20650. Co-authored-by: Sylvain Henry <sylvain@haskus.fr> - - - - - f977837b by mangoiv at 2026-10-05T22:04:21-04:00 configure: fix sed script and subst tooldir script Fixes #27672 Adds sanity checking for SUBST_TOOLDIR Metric Decrease: LinkableUsage01 MultiLayerModulesTH_OneShot T10547 T12234 T12425 T13035 T13820 T18140 T18730 T18923 T9198 TcPlugin_RewritePerf mhu-perf - - - - - f1cb08be by Hannes Siebenhandl at 2026-10-05T22:05:03-04:00 Prepend in-memory unit database for backpack The packageDbFlags are stored in reverse order. Thus, prepending will ensure that the in-memory unit database is the last item on the unit database stack. Further, the in-memory unit database needs to be able to shadow units from earlier unit databases in the unit database stack. Moreover, a `-clear-package-db` would remove the in-memory database if it weren't the last item on the stack. Closes #27835 - - - - - ec341aeb by Alan Zimmerman at 2026-10-06T18:26:37+01:00 EPA: Start using vocurly as basis for AnnListLayout For the existing cases that populate AnnList. This uses AnnListBraces when braces are explicitly supplied, and AnnListLayout when vocurly is used The change also shows up AnnList usages that can never capture layout, these are cleared up later. - - - - - 13 changed files: - + changelog.d/hadrian-persist-flavour - changelog.d/unit-index - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Parser.y - distrib/configure.ac.in - hadrian/doc/flavours.md - hadrian/src/Rules.hs - hadrian/src/Settings.hs - m4/subst_tooldir.m4 - + testsuite/tests/backpack/should_compile/T27835.bkp - + testsuite/tests/backpack/should_compile/T27835.stderr - testsuite/tests/backpack/should_compile/all.T - testsuite/tests/parser/should_compile/DumpSemis.stderr Changes: ===================================== changelog.d/hadrian-persist-flavour ===================================== @@ -0,0 +1,7 @@ +section: packaging +synopsis: Hadrian now persists the flavour name in the build root. When + rebuilding, the previously used flavour is automatically restored, removing + the need to re-specify it on every invocation and avoiding accidental build + root invalidation. +issues: #20650 +mrs: !7017 ===================================== changelog.d/unit-index ===================================== @@ -1,7 +1,7 @@ section: compiler synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units -issues: #27500 #26423 #27748 #27834 -mrs: !16115 !16598 !16743 +issues: #27500 #26423 #27748 #27834 #27835 +mrs: !16115 !16598 !16743 !16748 description: { The ``UnitState`` used to be duplicated for all ``HomeUnitEnv``, not sharing any of the ``UnitInfo``s. ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -441,9 +441,11 @@ addInMemoryDatabase dflags u = do } let uic = hscUIC hsc_env liftIO $ cacheExternalUnitDatabase uic newdb - -- added at the end because ordering matters + -- Ordering matters here! We prepend the new unit database, because 'packageDBFlags' + -- works like a stack, where what's on top takes precedence over what's below (same as right-to-left when given at the CLI). + -- The new db needs highest precedence to overwrite any other in-memory units that potentially occur in the dbs below it. pure dflags - { packageDBFlags = packageDBFlags dflags ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))] + { packageDBFlags = PackageDB (PkgDbPath (unitDatabasePath newdb)) : packageDBFlags dflags } -- | Register a new virtual unit database containing a single unit ===================================== compiler/GHC/Parser.y ===================================== @@ -1797,10 +1797,10 @@ cvars1 :: { [RecordPatSynField GhcPs] } where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList) } : 'where' '{' decls '}' {% amsA' (sLL $1 $> (thdOf3 $ unLoc $3, epTok $1, - AnnList (AnnListLayout (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3))) } + AnnList AnnListBraces (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3))) } | 'where' vocurly decls close {% amsA' (sLL $1 $3 (thdOf3 $ unLoc $3, epTok $1, - AnnList (AnnListLayout (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3))) } + AnnList (AnnListLayout (glR $3)) ListNone (sndOf3 $ unLoc $3))) } pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype @@ -1936,7 +1936,7 @@ decls :: { Located (EpaLocation, [EpToken ";"], OrdList (LHsDecl GhcPs)) } | {- empty -} { noLoc (noAnn, [],nilOL) } decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) } - : '{' decls '}' { sLL $1 $> (AnnList (AnnListLayout (fstOf3 $ unLoc $2)) (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2) + : '{' decls '}' { sLL $1 $> (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2) ,sL1 $2 $ thdOf3 $ unLoc $2) } | vocurly decls close { sL1 $2 (AnnList (AnnListLayout (fstOf3 $ unLoc $2)) ListNone (sndOf3 $ unLoc $2) ,sL1 $2 $ thdOf3 $ unLoc $2) } @@ -1952,7 +1952,7 @@ binds :: { Located (HsLocalBinds GhcPs) } ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (AnnList la p s) cs, noEpTok) val_binds)} } | '{' dbinds '}' {% acs (comb3 $1 $2 $3) (\loc cs -> (L loc - $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (AnnListLayout$ glR $2) (ListBraces (epTok $1) (epTok $3)) []) cs, noEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } + $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) []) cs, noEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } | vocurly dbinds close {% acs (gl $2) (\loc cs -> (L loc $ HsIPBinds (EpAnn (glR $1) (AnnList (AnnListLayout $ glR $2) ListNone []) cs, noEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } @@ -3543,12 +3543,12 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList)) } : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsA' (sLL $1 $> (reverse (snd $ unLoc $2), - (AnnList (AnnListLayout $ glR $2) (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2)))) } + (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2)))) } | vocurly alts(PATS) close { $2 >>= \ $2 -> amsA' (L (getLoc $2) (reverse (snd $ unLoc $2), (AnnList (AnnListLayout $ glR $2) ListNone (fst $ unLoc $2)))) } - | '{' '}' { amsA' (sLL $1 $> ([], (AnnList AnnListNoLayout (ListBraces (epTok $1) (epTok $2)) []))) } - | vocurly close { return $ noLocA ([], noAnn) } + | '{' '}' { amsA' (sLL $1 $> ([], (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $2)) []))) } + | vocurly close { return $ noLocA ([], AnnList (AnnListLayout $ glR $1) ListNone []) } alts(PATS) :: { forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)])) } : alts1(PATS) { $1 >>= \ $1 -> return $ @@ -3657,7 +3657,7 @@ apat : aexp {% (checkPattern <=< runPV) (unECP $1) } stmtlist :: { forall b. DisambECP b => PV (LocatedA (AnnList, Located [LocatedA (Stmt GhcPs (LocatedA b))])) } : '{' stmts '}' { $2 >>= \ $2 -> - amsA' (sLL $1 $> (AnnList (AnnListLayout (spanAsAnchor $ stmtsLoc $2)) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) + amsA' (sLL $1 $> (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) , sL1 $2 $ reverse $ snd $ unLoc $2))} | vocurly stmts close { $2 >>= \ $2 -> amsA' (L (stmtsLoc $2) (AnnList (AnnListLayout (spanAsAnchor $ stmtsLoc $2)) ListNone (fromOL $ fst $ unLoc $2) ===================================== distrib/configure.ac.in ===================================== @@ -103,7 +103,7 @@ AC_ARG_ENABLE(distro-toolchain, AC_SUBST([EnableDistroToolchain]) if test "$HostOS" = "mingw32" -a "$EnableDistroToolchain" = "NO"; then - FP_SETUP_WINDOWS_TOOLCHAIN([$hardtop/mingw/], [\$\$topdir/../mingw/]) + FP_SETUP_WINDOWS_TOOLCHAIN([$hardtop/mingw/], [\$topdir/../mingw/]) fi ===================================== hadrian/doc/flavours.md ===================================== @@ -3,7 +3,14 @@ Hadrian supports a few predefined _build flavours_, i.e. collections of build settings that fully define a GHC build (see `src/Flavour.hs`). Users can add their own build flavours if need be, as described -[here](https://gitlab.haskell.org/ghc/ghc/blob/master/hadrian/doc/user-settings.md#...). +[here](https://gitlab.haskell.org/ghc/ghc/blob/master/hadrian/doc/user-settings.md#...) or modify existing flavours using the flavour transformers notion seem below. + +The flavour to be used for a build root can be specified on the command-line +via the `--flavour` flag. Moreover, this flavour name is saved in the build +root; future invocations of Hadrian without a `--flavour` flag will default to +the last-used flavour. + +See `Note [Persisting the flavour]` in `hadrian/src/Settings.hs` ## Arguments ===================================== hadrian/src/Rules.hs ===================================== @@ -129,6 +129,7 @@ packageRules = do buildRules :: Rules () buildRules = do + Settings.flavourFileRules Rules.BinaryDist.bindistRules Rules.Generate.copyRules Rules.Generate.generateRules ===================================== hadrian/src/Settings.hs ===================================== @@ -1,10 +1,14 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + module Settings ( getExtraArgs, getArgs, getLibraryWays, getRtsWays, flavour, knownPackages, findPackageByName, unsafeFindPackageByName, unsafeFindPackageByPath, isLibrary, stagePackages, getBignumBackend, completeSetting, queryBuildTarget, queryHostTarget, queryBuild, queryHost, - queryArch, queryOS, queryVendor + queryArch, queryOS, queryVendor, + flavourFileRules ) where import CommandLine @@ -58,6 +62,56 @@ hadrianFlavours = , ghcInGhciFlavour, validateFlavour, slowValidateFlavour ] +{- +Note [Persisting the flavour] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Passing the flavour on the command-line means the user must consistently pass +the same --flavour flag to all Hadrian invocations on a particular build root. +Forgetting even once can result in a full rebuild of the tree. + +To avoid this we persist the flavour name in the build root itself +(specifically, in `<build root>/flavour`). We refer to this file when looking +up the active flavour, defaulting to it if the user does not specify a flavour +name explicitly. +-} + +-- | Oracle query type for the active flavour name. +-- See Note [Persisting the flavour]. +newtype FlavourName = FlavourName () + deriving (Binary, Eq, Hashable, NFData, Show) +type instance RuleResult FlavourName = String + +flavourFileRules :: Rules () +flavourFileRules = do + root <- buildRootRules + + -- Cache the flavour name lookup for the whole Shake run. + -- alwaysRerun ensures the oracle re-executes on every new invocation so + -- that a changed --flavour flag is never ignored due to a stale cross-run + -- cache entry (CLI args are not tracked as Shake dependencies). + -- See Note [Persisting the flavour]. + void $ addOracleCache $ \(FlavourName _) -> do + alwaysRerun + let flavourFile = root -/- "flavour" + cmdFlavour >>= \case + Just nm -> do + putBuild $ "Flavour: " ++ nm + liftIO $ writeFile flavourFile nm + return nm + Nothing -> do + exists <- doesFileExist flavourFile + if exists + then do nm <- liftIO $ readFile flavourFile + putBuild $ "Flavour: " ++ nm ++ " (cached from last build, override by passing --flavour=... explicitly)" + return nm + else return userDefaultFlavour + +-- | Lookup the requested flavour name, referring to the persistent flavour +-- file saved from the previous Hadrian execution if not specified. +-- The result is cached for the whole Shake run via the 'FlavourName' oracle. +getFlavourName :: Action String +getFlavourName = askOracle (FlavourName ()) + -- | This action looks up a flavour with the name given on the -- command line with @--flavour@, defaulting to 'userDefaultFlavour' -- when no explicit @--flavour@ is passed. It then applies any @@ -66,7 +120,7 @@ hadrianFlavours = -- syntax. See Note [Hadrian settings] at the bottom of this file. flavour :: Action Flavour flavour = do - flavourName <- fromMaybe userDefaultFlavour <$> cmdFlavour + flavourName <- getFlavourName when ("quickest" `isPrefixOf` flavourName) $ fail $ "The `quickest` flavour has been deprecated. Use `quick` instead.\n" ++ "Skip building dynamic libraries with `quick+no_dynamic_libs`\n" ===================================== m4/subst_tooldir.m4 ===================================== @@ -41,5 +41,5 @@ dnl ghc-toolchain. # See Note [How we configure the bundled windows toolchain] AC_DEFUN([SUBST_TOOLDIR], [ - sed -i.bkp $1 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g' + sed -i.bkp 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g' $1 ]) ===================================== testsuite/tests/backpack/should_compile/T27835.bkp ===================================== @@ -0,0 +1,11 @@ +unit p where + module P where + p :: Int + p = 42 + +unit q where + dependency p + module Q where + import P + q :: Int + q = p + 1 ===================================== testsuite/tests/backpack/should_compile/T27835.stderr ===================================== @@ -0,0 +1,7 @@ +[1 of 2] Processing p + Instantiating p + [1 of 1] Compiling P ( p/P.hs, T27835.out/p/P.o ) +[2 of 2] Processing q + Instantiating q + [1 of 1] Including p + [1 of 1] Compiling Q ( q/Q.hs, T27835.out/q/Q.o ) ===================================== testsuite/tests/backpack/should_compile/all.T ===================================== @@ -61,3 +61,4 @@ test('T13250', normal, backpack_compile, ['']) test('T13323', normal, backpack_compile, ['']) test('T20396', normal, backpack_compile, ['']) test('T23424', [ignore_stdout, ignore_stderr], backpack_compile, ['-ddump-rn-trace -ddump-if-trace -ddump-tc-trace']) +test('T27835', normal, backpack_compile, ['-clear-package-db -global-package-db']) ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -364,8 +364,7 @@ ((,) (Right (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:11:8-13 })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:11:6 })) (EpTok (EpaSpan { DumpSemis.hs:11:15 }))) @@ -627,8 +626,7 @@ ((,) (Right (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:(16,5)-(18,5) })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:16:3 })) (EpTok (EpaSpan { DumpSemis.hs:19:3 }))) @@ -880,8 +878,7 @@ ((,) (Right (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:22:12-28 })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:22:10 })) (EpTok (EpaSpan { DumpSemis.hs:22:30 }))) @@ -1936,8 +1933,7 @@ (EpAnn (EpaSpan { DumpSemis.hs:34:13-31 }) (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:34:18-30 })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:34:13 })) (EpTok (EpaSpan { DumpSemis.hs:34:31 }))) @@ -2333,8 +2329,7 @@ ((,) (FromSource) (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:(38,6)-(43,13) })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:38:4 })) (EpTok (EpaSpan { DumpSemis.hs:44:4 }))) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbf72978dae224dce5a366cf0f1f748... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbf72978dae224dce5a366cf0f1f748... 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