GitLab

Teo Camarasu pushed to branch wip/T25282 at Glasgow Haskell Compiler / GHC

Commits:

6d791567

by Teo Camarasu at 2025-06-20T17:43:18+01: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

ae14bd72

by Teo Camarasu at 2025-06-20T17:43:35+01:00

linters: lint-whitespace: bump upper-bound for containers

4 changed files:

compiler/GHC/Driver/Session.hs
compiler/Setup.hs
hadrian/src/Rules/Generate.hs
linters/lint-whitespace/lint-whitespace.cabal

Changes:

compiler/GHC/Driver/Session.hs

@@ -3460,6 +3460,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),
@@ -3513,6 +3514,23 @@ 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, splices refer to the Template Haskell
 +--   interface defined in `ghc-internal`, and must be linked against the same
 +--   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.
++
  {- -----------------------------------------------------------------------------
  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
@@ -22,6 +23,7 @@ import qualified Data.Map as Map
  import GHC.ResponseFile
  import System.Environment
++
  main :: IO ()
  main = defaultMainWithHooks ghcHooks
    where
@@ -56,7 +58,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 +98,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 +117,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 +135,7 @@ generateConfigHs cProjectUnitId settings = either error id $ do
          , "  , cBooterVersion"
          , "  , cStage"
          , "  , cProjectUnitId"
 +        , "  , cGhcInternalUnitId"
          , "  ) where"
          , ""
          , "import GHC.Prelude.Basic"
@@ -150,4 +159,7 @@ generateConfigHs cProjectUnitId settings = either error id $ do
          , ""
          , "cProjectUnitId :: String"
          , "cProjectUnitId = " ++ show cProjectUnitId
 +        , ""
 +        , "cGhcInternalUnitId :: String"
 +        , "cGhcInternalUnitId = " ++ show cGhcInternalUnitId
+         ]

hadrian/src/Rules/Generate.hs

@@ -601,6 +601,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"
@@ -610,6 +612,7 @@ generateConfigHs = do
          , "  , cBooterVersion"
          , "  , cStage"
          , "  , cProjectUnitId"
 +        , "  , cGhcInternalUnitId"
          , "  ) where"
          , ""
          , "import GHC.Prelude.Basic"
@@ -633,6 +636,9 @@ generateConfigHs = do
          , ""
          , "cProjectUnitId :: String"
          , "cProjectUnitId = " ++ show cProjectUnitId
 +        , ""
 +        , "cGhcInternalUnitId :: String"
 +        , "cGhcInternalUnitId = " ++ show cGhcInternalUnitId
+         ]
    where
      stageString (Stage0 InTreeLibs) = "1"

linters/lint-whitespace/lint-whitespace.cabal

@@ -24,7 +24,7 @@ executable lint-whitespace
      process
        ^>= 1.6,
      containers
 -      >= 0.6 && <0.8,
 +      >= 0.6 && <0.9,
      base
         >= 4.14 && < 5,
      text