GitLab

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

49f44e52

by Teo Camarasu at 2025-06-26T04:19:51-04:00

Expose ghc-internal unit id through the settings file

This in combination with the unit id of the compiler library allows
cabal to know of the two unit ids that should not be reinstalled (in
specific circumstances) as:
- when using plugins, we want to link against exactly the compiler unit
id
- when using TemplateHaskell we want to link against exactly the package
that contains the TemplateHaskell interfaces, which is `ghc-internal`

See: <https://github.com/haskell/cabal/issues/10087>

Resolves #25282

3 changed files:

compiler/GHC/Driver/Session.hs
compiler/Setup.hs
hadrian/src/Rules/Generate.hs

Changes:

compiler/GHC/Driver/Session.hs

@@ -3463,6 +3463,7 @@ compilerInfo dflags
         ("Project Patch Level1",        cProjectPatchLevel1),
         ("Project Patch Level2",        cProjectPatchLevel2),
         ("Project Unit Id",             cProjectUnitId),
 +       ("ghc-internal Unit Id",        cGhcInternalUnitId), -- See Note [Special unit-ids]
         ("Booter version",              cBooterVersion),
         ("Stage",                       cStage),
         ("Build platform",              cBuildPlatformString),
@@ -3516,6 +3517,26 @@ compilerInfo dflags
      expandDirectories :: FilePath -> Maybe FilePath -> String -> String
      expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd
 +-- Note [Special unit-ids]
 +-- ~~~~~~~~~~~~~~~~~~~~~~~
 +-- Certain units are special to the compiler:
 +-- - Wired-in identifiers reference a specific unit-id of `ghc-internal`.
 +-- - GHC plugins must be linked against a specific unit-id of `ghc`,
 +--   namely the same one as the compiler.
 +-- - When using Template Haskell, the result of executing splices refer to
 +--   the Template Haskell ASTs created using constructors from `ghc-internal`,
 +--   and must be linked against the same `ghc-internal` unit-id as the compiler.
 +--
 +-- We therefore expose the unit-id of `ghc-internal` ("ghc-internal Unit Id") and
 +-- ghc ("Project Unit Id") through `ghc --info`.
 +--
 +-- This allows build tools to act accordingly, eg, if a user wishes to build a
 +-- GHC plugin, `cabal-install` might force them to use the exact `ghc` unit
 +-- that the compiler was linked against.
 +-- See:
 +--  - https://github.com/haskell/cabal/issues/10087
 +--  - https://github.com/commercialhaskell/stack/issues/6749
++
  {- -----------------------------------------------------------------------------
  Note [DynFlags consistency]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~

compiler/Setup.hs

@@ -11,6 +11,7 @@ import Distribution.Verbosity
  import Distribution.Simple.Program
  import Distribution.Simple.Utils
  import Distribution.Simple.Setup
 +import Distribution.Simple.PackageIndex
  import System.IO
  import System.Process
@@ -56,7 +57,7 @@ primopIncls =
+     ]
  ghcAutogen :: Verbosity -> LocalBuildInfo -> IO ()
 -ghcAutogen verbosity lbi@LocalBuildInfo{pkgDescrFile,withPrograms,componentNameMap}
 +ghcAutogen verbosity lbi@LocalBuildInfo{pkgDescrFile,withPrograms,componentNameMap,installedPkgs}
    = do
    -- Get compiler/ root directory from the cabal file
    let Just compilerRoot = takeDirectory <$> pkgDescrFile
@@ -96,9 +97,14 @@ ghcAutogen verbosity lbi@LocalBuildInfo{pkgDescrFile,withPrograms,componentNameM
                           Just [LibComponentLocalBuildInfo{componentUnitId}] -> unUnitId componentUnitId
                           _ -> error "Couldn't find unique cabal library when building ghc"
 +  let cGhcInternalUnitId = case lookupPackageName installedPkgs (mkPackageName "ghc-internal")  of
 +          -- We assume there is exactly one copy of `ghc-internal` in our dependency closure
 +        [(_,[packageInfo])] -> unUnitId $ installedUnitId packageInfo
 +        _ -> error "Couldn't find unique ghc-internal library when building ghc"
++
    -- Write GHC.Settings.Config
        configHsPath = autogenPackageModulesDir lbi </> "GHC/Settings/Config.hs"
 -      configHs = generateConfigHs cProjectUnitId settings
 +      configHs = generateConfigHs cProjectUnitId cGhcInternalUnitId settings
    createDirectoryIfMissingVerbose verbosity True (takeDirectory configHsPath)
    rewriteFileEx verbosity configHsPath configHs
@@ -110,8 +116,9 @@ getSetting settings kh kr = go settings kr
        Just v -> Right v
  generateConfigHs :: String -- ^ ghc's cabal-generated unit-id, which matches its package-id/key
 +                 -> String -- ^ ghc-internal's cabal-generated unit-id, which matches its package-id/key
                   -> [(String,String)] -> String
 -generateConfigHs cProjectUnitId settings = either error id $ do
 +generateConfigHs cProjectUnitId cGhcInternalUnitId settings = either error id $ do
      let getSetting' = getSetting $ (("cStage","2"):) settings
      buildPlatform  <- getSetting' "cBuildPlatformString" "Host platform"
      hostPlatform   <- getSetting' "cHostPlatformString" "Target platform"
@@ -127,6 +134,7 @@ generateConfigHs cProjectUnitId settings = either error id $ do
          , "  , cBooterVersion"
          , "  , cStage"
          , "  , cProjectUnitId"
 +        , "  , cGhcInternalUnitId"
          , "  ) where"
          , ""
          , "import GHC.Prelude.Basic"
@@ -150,4 +158,7 @@ generateConfigHs cProjectUnitId settings = either error id $ do
          , ""
          , "cProjectUnitId :: String"
          , "cProjectUnitId = " ++ show cProjectUnitId
 +        , ""
 +        , "cGhcInternalUnitId :: String"
 +        , "cGhcInternalUnitId = " ++ show cGhcInternalUnitId
+         ]

hadrian/src/Rules/Generate.hs

@@ -607,6 +607,8 @@ generateConfigHs = do
      -- 'pkgUnitId' on 'compiler' (the ghc-library package) to create the
      -- unit-id in both situations.
      cProjectUnitId <- expr . (`pkgUnitId` compiler) =<< getStage
++
 +    cGhcInternalUnitId <- expr . (`pkgUnitId` ghcInternal) =<< getStage
      return $ unlines
          [ "module GHC.Settings.Config"
          , "  ( module GHC.Version"
@@ -616,6 +618,7 @@ generateConfigHs = do
          , "  , cBooterVersion"
          , "  , cStage"
          , "  , cProjectUnitId"
 +        , "  , cGhcInternalUnitId"
          , "  ) where"
          , ""
          , "import GHC.Prelude.Basic"
@@ -639,6 +642,9 @@ generateConfigHs = do
          , ""
          , "cProjectUnitId :: String"
          , "cProjectUnitId = " ++ show cProjectUnitId
 +        , ""
 +        , "cGhcInternalUnitId :: String"
 +        , "cGhcInternalUnitId = " ++ show cGhcInternalUnitId
+         ]
    where
      stageString (Stage0 InTreeLibs) = "1"