Cheng Shao pushed to branch wip/fix-cross-ghc-info-unit-id at Glasgow Haskell Compiler / GHC
Commits:
-
95f24e6b
by Cheng Shao at 2026-10-10T13:14:21+00:00
10 changed files:
- .gitlab/hello.hs
- + changelog.d/fix-cross-ghc-info-unit-id
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Settings/IO.hs
- distrib/configure.ac.in
- hadrian/bindist/Makefile
- hadrian/bindist/config.mk.in
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Rules/Generate.hs
Changes:
| ... | ... | @@ -27,7 +27,11 @@ fakeSettings = |
| 27 | 27 | sTargetPlatform =
|
| 28 | 28 | genericPlatform,
|
| 29 | 29 | sPlatformMisc = PlatformMisc {},
|
| 30 | - sUnitSettings = UnitSettings { unitSettings_baseUnitId = stringToUnitId "base" }
|
|
| 30 | + sUnitSettings = UnitSettings
|
|
| 31 | + { unitSettings_baseUnitId = stringToUnitId "base"
|
|
| 32 | + , unitSettings_ghcUnitId = stringToUnitId "ghc"
|
|
| 33 | + , unitSettings_ghcInternalUnitId = stringToUnitId "ghc-internal"
|
|
| 34 | + }
|
|
| 31 | 35 | }
|
| 32 | 36 | |
| 33 | 37 | fakeDynFlags :: DynFlags
|
| 1 | +section: compiler
|
|
| 2 | +synopsis: Fix a bug where unit ids in cross ghc --info output doesn't match ghc-pkg output, breaking cross ghc releases with cabal 3.18.
|
|
| 3 | +mrs: !16790
|
|
| 4 | +issues: #27919 |
| ... | ... | @@ -546,7 +546,8 @@ opt_i dflags= toolSettings_opt_i $ toolSettings dflags |
| 546 | 546 | |
| 547 | 547 | |
| 548 | 548 | setBaseUnitId :: String -> DynP ()
|
| 549 | -setBaseUnitId s = upd $ \d -> d { unitSettings = UnitSettings (stringToUnitId s) }
|
|
| 549 | +setBaseUnitId s = upd $ \d -> d
|
|
| 550 | + { unitSettings = (unitSettings d) { unitSettings_baseUnitId = stringToUnitId s } }
|
|
| 550 | 551 | |
| 551 | 552 | -----------------------------------------------------------------------------
|
| 552 | 553 | |
| ... | ... | @@ -3663,8 +3664,8 @@ compilerInfo dflags |
| 3663 | 3664 | ("Project Patch Level", cProjectPatchLevel),
|
| 3664 | 3665 | ("Project Patch Level1", cProjectPatchLevel1),
|
| 3665 | 3666 | ("Project Patch Level2", cProjectPatchLevel2),
|
| 3666 | - ("Project Unit Id", cProjectUnitId),
|
|
| 3667 | - ("ghc-internal Unit Id", cGhcInternalUnitId), -- See Note [Special unit-ids]
|
|
| 3667 | + ("Project Unit Id", unitIdString $ unitSettings_ghcUnitId $ unitSettings dflags),
|
|
| 3668 | + ("ghc-internal Unit Id", unitIdString $ unitSettings_ghcInternalUnitId $ unitSettings dflags), -- See Note [Special unit-ids]
|
|
| 3668 | 3669 | ("Booter version", cBooterVersion),
|
| 3669 | 3670 | ("Stage", cStage),
|
| 3670 | 3671 | ("Build platform", cBuildPlatformString),
|
| ... | ... | @@ -94,7 +94,11 @@ data Settings = Settings |
| 94 | 94 | , sRawTarget :: Target
|
| 95 | 95 | }
|
| 96 | 96 | |
| 97 | -data UnitSettings = UnitSettings { unitSettings_baseUnitId :: !UnitId }
|
|
| 97 | +data UnitSettings = UnitSettings
|
|
| 98 | + { unitSettings_baseUnitId :: !UnitId
|
|
| 99 | + , unitSettings_ghcUnitId :: !UnitId
|
|
| 100 | + , unitSettings_ghcInternalUnitId :: !UnitId
|
|
| 101 | + }
|
|
| 98 | 102 | |
| 99 | 103 | -- | Settings for other executables GHC calls.
|
| 100 | 104 | --
|
| ... | ... | @@ -142,6 +142,8 @@ initSettings top_dir = do |
| 142 | 142 | ghcWithInterpreter <- getBooleanSetting "Use interpreter"
|
| 143 | 143 | |
| 144 | 144 | baseUnitId <- getSetting_raw "base unit-id"
|
| 145 | + ghcUnitId <- getSetting_raw "ghc unit-id"
|
|
| 146 | + ghcInternalUnitId <- getSetting_raw "ghc-internal unit-id"
|
|
| 145 | 147 | |
| 146 | 148 | -- LibDir is optional. If not set, derive it from topDir. This allows
|
| 147 | 149 | -- bindists to work without explicitly setting LibDir, but gives us the
|
| ... | ... | @@ -174,6 +176,8 @@ initSettings top_dir = do |
| 174 | 176 | , sUnitSettings = UnitSettings
|
| 175 | 177 | {
|
| 176 | 178 | unitSettings_baseUnitId = stringToUnitId baseUnitId
|
| 179 | + , unitSettings_ghcUnitId = stringToUnitId ghcUnitId
|
|
| 180 | + , unitSettings_ghcInternalUnitId = stringToUnitId ghcInternalUnitId
|
|
| 177 | 181 | }
|
| 178 | 182 | |
| 179 | 183 | , sToolSettings = ToolSettings
|
| ... | ... | @@ -406,6 +406,12 @@ fi |
| 406 | 406 | |
| 407 | 407 | AC_SUBST(BaseUnitId)
|
| 408 | 408 | |
| 409 | +dnl The units supplied with the target libraries, as reported by ghc --info.
|
|
| 410 | +GhcUnitId=@GhcUnitId@
|
|
| 411 | +GhcInternalUnitId=@GhcInternalUnitId@
|
|
| 412 | +AC_SUBST(GhcUnitId)
|
|
| 413 | +AC_SUBST(GhcInternalUnitId)
|
|
| 414 | + |
|
| 409 | 415 | # We get caught by
|
| 410 | 416 | # http://savannah.gnu.org/bugs/index.php?1516
|
| 411 | 417 | # $(eval ...) inside conditionals causes errors
|
| ... | ... | @@ -90,6 +90,8 @@ lib/settings : config.mk |
| 90 | 90 | @echo ',("RTS ways", "$(GhcRTSWays)")' >> $@
|
| 91 | 91 | @echo ',("Relative Global Package DB", "package.conf.d")' >> $@
|
| 92 | 92 | @echo ',("base unit-id", "$(BaseUnitId)")' >> $@
|
| 93 | + @echo ',("ghc unit-id", "$(GhcUnitId)")' >> $@
|
|
| 94 | + @echo ',("ghc-internal unit-id", "$(GhcInternalUnitId)")' >> $@
|
|
| 93 | 95 | @echo "]" >> $@
|
| 94 | 96 | |
| 95 | 97 | lib/targets/default.target : config.mk default.target
|
| ... | ... | @@ -134,6 +134,8 @@ CrossCompilePrefix = @CrossCompilePrefix@ |
| 134 | 134 | GhcUnregisterised = @Unregisterised@
|
| 135 | 135 | EnableDistroToolchain = @EnableDistroToolchain@
|
| 136 | 136 | BaseUnitId = @BaseUnitId@
|
| 137 | +GhcUnitId = @GhcUnitId@
|
|
| 138 | +GhcInternalUnitId = @GhcInternalUnitId@
|
|
| 137 | 139 | |
| 138 | 140 | # The THREADED_RTS requires `BaseReg` to be in a register and the
|
| 139 | 141 | # `GhcUnregisterised` mode doesn't allow that.
|
| ... | ... | @@ -232,7 +232,7 @@ buildBinDistDir root conf@BindistConfig{..} = do |
| 232 | 232 | let bindistSettings = bindistFilesDir -/- "lib" -/- "settings"
|
| 233 | 233 | bindistContext = vanillaContext library_stage compiler
|
| 234 | 234 | bindistSettingsContent <- interpretInContext bindistContext $
|
| 235 | - generateSettings bindistSettings False "package.conf.d"
|
|
| 235 | + generateSettings library_stage bindistSettings False "package.conf.d"
|
|
| 236 | 236 | writeFileAtomic bindistSettings bindistSettingsContent
|
| 237 | 237 | |
| 238 | 238 | copyDirectory rtsIncludeDir bindistFilesDir
|
| ... | ... | @@ -7,6 +7,7 @@ module Rules.Generate ( |
| 7 | 7 | import Development.Shake.FilePath
|
| 8 | 8 | import qualified Data.Set as Set
|
| 9 | 9 | import Base
|
| 10 | +import BindistConfig
|
|
| 10 | 11 | import qualified Context
|
| 11 | 12 | import Expression
|
| 12 | 13 | import Hadrian.Oracles.TextFile (lookupStageBuildConfig)
|
| ... | ... | @@ -275,7 +276,7 @@ generateRules = do |
| 275 | 276 | then root -/- stageString stage' -/- "lib"
|
| 276 | 277 | else prefix
|
| 277 | 278 | relPkgDb = makeRelativeNoSysLink libTopDir pkgDb
|
| 278 | - go (generateSettings out True relPkgDb) out
|
|
| 279 | + go (generateSettings libStage out True relPkgDb) out
|
|
| 279 | 280 | (prefix -/- "targets" -/- "default.target") %> \out -> go (show <$> expr (targetStage (succStage stage))) out
|
| 280 | 281 | |
| 281 | 282 | where
|
| ... | ... | @@ -451,7 +452,9 @@ bindistRules = do |
| 451 | 452 | , interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised
|
| 452 | 453 | , interpolateVar "UseLibdw" $ fmap yesNo $ interp $ staged (fmap (isJust . tgtRTSWithLibdw) . targetStage)
|
| 453 | 454 | , interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors
|
| 454 | - , interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base
|
|
| 455 | + , interpolateVar "BaseUnitId" $ bindistUnitId base
|
|
| 456 | + , interpolateVar "GhcUnitId" $ bindistUnitId compiler
|
|
| 457 | + , interpolateVar "GhcInternalUnitId" $ bindistUnitId ghcInternal
|
|
| 455 | 458 | , interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP Stage2
|
| 456 | 459 | , interpolateVar "TargetPlatformFull" (setting TargetPlatformFull)
|
| 457 | 460 | , interpolateVar "BuildPlatformFull" (setting BuildPlatformFull)
|
| ... | ... | @@ -460,6 +463,9 @@ bindistRules = do |
| 460 | 463 | where
|
| 461 | 464 | interp = interpretInContext (semiEmptyTarget Stage2)
|
| 462 | 465 | getTarget = interp . queryTarget Stage2
|
| 466 | + bindistUnitId pkg = do
|
|
| 467 | + stage <- library_stage <$> implicitBindistConfig
|
|
| 468 | + pkgUnitId stage pkg
|
|
| 463 | 469 | |
| 464 | 470 | -- | Given a 'String' replace characters '.' and '-' by underscores ('_') so that
|
| 465 | 471 | -- the resulting 'String' is a valid C preprocessor identifier.
|
| ... | ... | @@ -485,18 +491,18 @@ ghcWrapper stage = do |
| 485 | 491 | -- "package.conf.d"). Callers supply the correct relative path. For bindists
|
| 486 | 492 | -- the layout is known statically; for in-tree builds callers compute it. For
|
| 487 | 493 | -- bindists, we omit @LibDir@ so it defaults to @topDir@ at runtime.
|
| 488 | -generateSettings :: FilePath -> Bool -> FilePath -> Expr String
|
|
| 489 | -generateSettings settingsFile includeLibDir rel_pkg_db = do
|
|
| 494 | +--
|
|
| 495 | +-- @libraryStage@: the stage containing the target package database.
|
|
| 496 | +generateSettings :: Stage -> FilePath -> Bool -> FilePath -> Expr String
|
|
| 497 | +generateSettings libraryStage settingsFile includeLibDir rel_pkg_db = do
|
|
| 490 | 498 | ctx <- getContext
|
| 491 | 499 | stage <- getStage
|
| 492 | 500 | |
| 493 | - -- The unit-id of the base package which is always linked against (#25382)
|
|
| 494 | - base_unit_id <- expr $ do
|
|
| 495 | - case stage of
|
|
| 496 | - Stage0 {} -> error "Unable to generate settings for stage0"
|
|
| 497 | - Stage1 -> pkgUnitId Stage1 base
|
|
| 498 | - Stage2 -> pkgUnitId Stage1 base
|
|
| 499 | - Stage3 -> pkgUnitId Stage2 base
|
|
| 501 | + -- These are the units supplied in the target package database, which can
|
|
| 502 | + -- differ from the host units linked into a cross compiler.
|
|
| 503 | + base_unit_id <- expr $ pkgUnitId libraryStage base
|
|
| 504 | + ghc_unit_id <- expr $ pkgUnitId libraryStage compiler
|
|
| 505 | + ghc_internal_unit_id <- expr $ pkgUnitId libraryStage ghcInternal
|
|
| 500 | 506 | |
| 501 | 507 | -- For cross compilers, LibDir points to the succeeding stage's lib dir
|
| 502 | 508 | -- (which contains the target architecture's libraries). For non-cross,
|
| ... | ... | @@ -519,6 +525,8 @@ generateSettings settingsFile includeLibDir rel_pkg_db = do |
| 519 | 525 | , ("RTS ways", unwords . map show . Set.toList <$> getRtsWays)
|
| 520 | 526 | , ("Relative Global Package DB", pure rel_pkg_db)
|
| 521 | 527 | , ("base unit-id", pure base_unit_id)
|
| 528 | + , ("ghc unit-id", pure ghc_unit_id)
|
|
| 529 | + , ("ghc-internal unit-id", pure ghc_internal_unit_id)
|
|
| 522 | 530 | ]
|
| 523 | 531 | ++ ([("LibDir", pure rel_lib_topDir) | includeLibDir])
|
| 524 | 532 | let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")"
|
| ... | ... | @@ -555,7 +563,6 @@ generateConfigHs = do |
| 555 | 563 | -- unit-id in both situations.
|
| 556 | 564 | cProjectUnitId <- expr . (`pkgUnitId` compiler) =<< getStage
|
| 557 | 565 | |
| 558 | - cGhcInternalUnitId <- expr . (`pkgUnitId` ghcInternal) =<< getStage
|
|
| 559 | 566 | return $ unlines
|
| 560 | 567 | [ "module GHC.Settings.Config"
|
| 561 | 568 | , " ( module GHC.Version"
|
| ... | ... | @@ -565,7 +572,6 @@ generateConfigHs = do |
| 565 | 572 | , " , cBooterVersion"
|
| 566 | 573 | , " , cStage"
|
| 567 | 574 | , " , cProjectUnitId"
|
| 568 | - , " , cGhcInternalUnitId"
|
|
| 569 | 575 | , " ) where"
|
| 570 | 576 | , ""
|
| 571 | 577 | , "import GHC.Prelude.Basic"
|
| ... | ... | @@ -589,9 +595,6 @@ generateConfigHs = do |
| 589 | 595 | , ""
|
| 590 | 596 | , "cProjectUnitId :: String"
|
| 591 | 597 | , "cProjectUnitId = " ++ show cProjectUnitId
|
| 592 | - , ""
|
|
| 593 | - , "cGhcInternalUnitId :: String"
|
|
| 594 | - , "cGhcInternalUnitId = " ++ show cGhcInternalUnitId
|
|
| 595 | 598 | ]
|
| 596 | 599 | where
|
| 597 | 600 | stageString (Stage0 InTreeLibs) = "1"
|