stable-haskell · angerman · Sep 9, 2025
diff --git a/compiler/CodeGen.Platform.h b/compiler/CodeGen.Platform.h
@@ -7,7 +7,7 @@ import GHC.Utils.Panic.Plain
 #endif
 import GHC.Platform.Reg
 
-#include "MachRegs.h"
+#include "stg/MachRegs.h"
 
 #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)
 

diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs
@@ -532,7 +532,7 @@ countSmall big x = count big False x
 
 
 -- Bring in all the bci_ bytecode constants.
-#include "Bytecodes.h"
+#include "rts/Bytecodes.h"
 
 largeArgInstr :: Word16 -> Word16
 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci

diff --git a/compiler/GHC/Driver/DynFlags.hs b/compiler/GHC/Driver/DynFlags.hs
@@ -64,6 +64,7 @@ module GHC.Driver.DynFlags (
 
         --
         baseUnitId,
+        rtsWayUnitId,
 
 
         -- * Include specifications
@@ -1474,6 +1475,17 @@ versionedFilePath platform = uniqueSubdir platform
 baseUnitId :: DynFlags -> UnitId
 baseUnitId dflags = unitSettings_baseUnitId (unitSettings dflags)
 
+rtsWayUnitId :: DynFlags -> UnitId
+rtsWayUnitId dflags | ways dflags `hasWay` WayThreaded
+                    , ways dflags `hasWay` WayDebug
+                    = stringToUnitId "rts:threaded-debug"
+                    | ways dflags `hasWay` WayThreaded
+                    = stringToUnitId "rts:threaded-nodebug"
+                    | ways dflags `hasWay` WayDebug
+                    = stringToUnitId "rts:nonthreaded-debug"
+                    | otherwise
+                    = stringToUnitId "rts:nonthreaded-nodebug"
+
 -- SDoc
 -------------------------------------------
 -- | Initialize the pretty-printing options

diff --git a/compiler/GHC/Iface/Errors/Ppr.hs b/compiler/GHC/Iface/Errors/Ppr.hs
@@ -42,6 +42,7 @@ import GHC.Utils.Outputable
 import GHC.Utils.Panic
 
 import GHC.Iface.Errors.Types
+import qualified Data.List as List
 
 defaultIfaceMessageOpts :: IfaceMessageOpts
 defaultIfaceMessageOpts = IfaceMessageOpts { ifaceShowTriedFiles = False
@@ -174,14 +175,12 @@ cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInst
           looks_like_srcpkgid =
      -- Unsafely coerce a unit id (i.e. an installed package component
      -- identifier) into a PackageId and see if it means anything.
-           case cands of
-             (pkg:pkgs) ->
-              parens (text "This unit ID looks like the source package ID;" $$
-                      text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$
-                     (if null pkgs then empty
-                                  else text "and" <+> int (length pkgs) <+> text "other candidate" <> plural pkgs))
+           case List.sortOn unitPackageNameString cands of
              -- Todo: also check if it looks like a package name!
              [] -> empty
+             pkgs ->
+              parens (text "This unit-id looks like a source package name-version;" <+>
+                      text "candidates real unit-ids are:" $$ vcat (map (quotes . ftext . unitIdFS . unitId)  pkgs))
 
       in hsep [ text "no unit id matching" <+> quotes (ppr pkg)
               , text "was found"] $$ looks_like_srcpkgid

diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs
@@ -85,7 +85,7 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
     --   WASM_DYLINK_NEEDED, otherwise dyld can't load it.
     --
     --
-    let pkgs_without_rts = filter ((/= rtsUnitId) . unitId) pkgs_with_rts
+    let pkgs_without_rts = filter ((/= PackageName (fsLit "rts")) . unitPackageName) pkgs_with_rts
         pkgs
          | ArchWasm32 <- arch      = pkgs_with_rts
          | OSMinGW32 <- os         = pkgs_with_rts

diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs
@@ -63,8 +63,17 @@ mkExtraObj logger tmpfs dflags unit_state extn xs
       -- we're compiling C or assembler. When compiling C, we pass the usual
       -- set of include directories and PIC flags.
       cOpts = map Option (picCCOpts dflags)
-                    ++ map (FileOption "-I" . ST.unpack)
-                            (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit)
+                    ++ map (FileOption "-I")
+                            (collectIncludeDirs $ depClosure unit_state [unsafeLookupUnit unit_state rtsUnit])
+      depClosure :: UnitState -> [UnitInfo] -> [UnitInfo]
+      depClosure us initial = go [] initial
+        where
+          go seen [] = seen
+          go seen (ui:uis)
+            | ui `elem` seen = go seen uis
+            | otherwise =
+                let deps = map (unsafeLookupUnitId us) (unitDepends ui)
+                in go (ui:seen) (deps ++ uis)
 
 -- When linking a binary, we need to create a C main() function that
 -- starts everything off.  This used to be compiled statically as part

diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
@@ -50,6 +50,7 @@ import GHC.Driver.Session
 import GHC.Driver.Ppr
 import GHC.Driver.Config.Diagnostic
 import GHC.Driver.Config.Finder
+import GHC.Driver.DynFlags (rtsWayUnitId)
 
 import GHC.Tc.Utils.Monad hiding (reportDiagnostic)
 
@@ -176,8 +177,8 @@ getLoaderState :: Interp -> IO (Maybe LoaderState)
 getLoaderState interp = readMVar (loader_state (interpLoader interp))
 
 
-emptyLoaderState :: LoaderState
-emptyLoaderState = LoaderState
+emptyLoaderState :: DynFlags -> LoaderState
+emptyLoaderState dflags = LoaderState
    { linker_env = LinkerEnv
      { closure_env = emptyNameEnv
      , itbl_env    = emptyNameEnv
@@ -197,7 +198,14 @@ emptyLoaderState = LoaderState
   --
   -- The linker's symbol table is populated with RTS symbols using an
   -- explicit list.  See rts/Linker.c for details.
-  where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet)
+  where init_pkgs = let addToUDFM' (k, v) m = addToUDFM m k v
+                    in foldr addToUDFM' emptyUDFM [
+                      (rtsUnitId, (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet))
+                    -- FIXME? Should this be the rtsWayUnitId of the current ghc, or the one
+                    --        for the target build? I think target-build seems right, but I'm
+                    --        not fully convinced.
+                    , (rtsWayUnitId dflags, (LoadedPkgInfo (rtsWayUnitId dflags) [] [] [] emptyUniqDSet))
+                    ]
 
 extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO ()
 extendLoadedEnv interp new_bindings =
@@ -337,7 +345,7 @@ initLoaderState interp hsc_env = do
 reallyInitLoaderState :: Interp -> HscEnv -> IO LoaderState
 reallyInitLoaderState interp hsc_env = do
   -- Initialise the linker state
-  let pls0 = emptyLoaderState
+  let pls0 = emptyLoaderState (hsc_dflags hsc_env)
 
   case platformArch (targetPlatform (hsc_dflags hsc_env)) of
     -- FIXME: we don't initialize anything with the JS interpreter.

diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs
@@ -289,7 +289,7 @@ linkStaticLib logger dflags unit_env o_files dep_units = do
         | gopt Opt_LinkRts dflags
         = pkg_cfgs_init
         | otherwise
-        = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init
+        = filter ((/= PackageName (fsLit "rts")) . unitPackageName) pkg_cfgs_init
 
   archives <- concatMapM (collectArchives namever ways_) pkg_cfgs
 

diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs
@@ -219,7 +219,7 @@ loadPlugin' occ_name plugin_name hsc_env mod_name
                           [ text "The value", ppr name
                           , text "with type", ppr actual_type
                           , text "did not have the type"
-                          , text "GHC.Plugins.Plugin"
+                          , ppr (mkTyConTy plugin_tycon)
                           , text "as required"])
             Right (plugin, links, pkgs) -> return (plugin, mod_iface, links, pkgs) } } } } }
 

diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs
@@ -205,14 +205,13 @@ libraryDirsForWay ws
   | otherwise        = map ST.unpack . unitLibraryDirs
 
 unitHsLibs :: GhcNameVersion -> Ways -> UnitInfo -> [String]
-unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p)
+unitHsLibs namever ways0 p = map (mkDynName . ST.unpack) (unitLibraries p)
   where
         ways1 = removeWay WayDyn ways0
         -- the name of a shared library is libHSfoo-ghc<version>.so
         -- we leave out the _dyn, because it is superfluous
 
         tag     = waysTag (fullWays ways1)
-        rts_tag = waysTag ways1
 
         mkDynName x
          | not (ways0 `hasWay` WayDyn) = x
@@ -225,19 +224,3 @@ unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibrar
          | otherwise
             = panic ("Don't understand library name " ++ x)
 
-        -- Add _thr and other rts suffixes to packages named
-        -- `rts` or `rts-1.0`. Why both?  Traditionally the rts
-        -- package is called `rts` only.  However the tooling
-        -- usually expects a package name to have a version.
-        -- As such we will gradually move towards the `rts-1.0`
-        -- package name, at which point the `rts` package name
-        -- will eventually be unused.
-        --
-        -- This change elevates the need to add custom hooks
-        -- and handling specifically for the `rts` package.
-        addSuffix rts@"HSrts"       = rts       ++ (expandTag rts_tag)
-        addSuffix rts@"HSrts-1.0.3" = rts       ++ (expandTag rts_tag)
-        addSuffix other_lib         = other_lib ++ (expandTag tag)
-
-        expandTag t | null t = ""
-                    | otherwise = '_':t
diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
@@ -112,6 +112,7 @@ import Data.Graph (stronglyConnComp, SCC(..))
 import Data.Char ( toUpper )
 import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn )
 import Data.Set (Set)
+import Data.String (fromString)
 import Data.Monoid (First(..))
 import qualified Data.Semigroup as Semigroup
 import qualified Data.Set as Set
@@ -370,7 +371,7 @@ initUnitConfig dflags cached_dbs home_units =
          -- Since "base" is not wired in, then the unit-id is discovered
          -- from the settings file by default, but can be overriden by power-users
          -- by specifying `-base-unit-id` flag.
-         | otherwise = filter (hu_id /=) [baseUnitId dflags, ghcInternalUnitId, rtsUnitId]
+         | otherwise = filter (hu_id /=) [baseUnitId dflags, ghcInternalUnitId, rtsWayUnitId dflags, rtsUnitId]
 
        -- if the home unit is indefinite, it means we are type-checking it only
        -- (not producing any code). Hence we can use virtual units instantiated
@@ -644,7 +645,7 @@ initUnits logger dflags cached_dbs home_units = do
 
   (unit_state,dbs) <- withTiming logger (text "initializing unit database")
                    forceUnitInfoMap
-                 $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+                 $ mkUnitState logger dflags (initUnitConfig dflags cached_dbs home_units)
 
   putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
     FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1093,20 +1094,30 @@ type WiringMap = UniqMap UnitId UnitId
 
 findWiredInUnits
    :: Logger
+   -> [UnitId]            -- wired in unit ids
    -> UnitPrecedenceMap
    -> [UnitInfo]           -- database
    -> VisibilityMap             -- info on what units are visible
                                 -- for wired in selection
    -> IO ([UnitInfo],  -- unit database updated for wired in
           WiringMap)   -- map from unit id to wired identity
 
-findWiredInUnits logger prec_map pkgs vis_map = do
+findWiredInUnits logger unitIdsToFind prec_map pkgs vis_map = do
   -- Now we must find our wired-in units, and rename them to
   -- their canonical names (eg. base-1.0 ==> base), as described
   -- in Note [Wired-in units] in GHC.Unit.Types
   let
         matches :: UnitInfo -> UnitId -> Bool
-        pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid)
+        pc `matches` pid | (pkg, comp) <- break (==':') (unitIdString pid)
+                         , not (null comp)
+          = unitPackageName pc == PackageName (fromString pkg)
+            -- note: GenericUnitInfo uses the same type for
+            --       unitPackageName and unitComponentName
+            && unitComponentName pc == Just (PackageName (fromString (drop 1 comp)))
+        pc `matches` pid
+          = unitPackageName pc == PackageName (unitIdFS pid)
+            && unitComponentName pc == Nothing
+
 
         -- find which package corresponds to each wired-in package
         -- delete any other packages with the same name
@@ -1126,7 +1137,8 @@ findWiredInUnits logger prec_map pkgs vis_map = do
         -- available.
         --
         findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
-        findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound]
+        findWiredInUnit pkgs wired_pkg = do
+            firstJustsM [try all_exposed_ps, try all_ps, notfound]
           where
                 all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
                 all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ]
@@ -1151,7 +1163,7 @@ findWiredInUnits logger prec_map pkgs vis_map = do
                         return (wired_pkg, pkg)
 
 
-  mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds
+  mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) unitIdsToFind
   let
         wired_in_pkgs = catMaybes mb_wired_in_pkgs
 
@@ -1239,8 +1251,10 @@ instance Outputable UnusableUnitReason where
     ppr IgnoredWithFlag = text "[ignored with flag]"
     ppr (BrokenDependencies uids)   = brackets (text "broken" <+> ppr uids)
     ppr (CyclicDependencies uids)   = brackets (text "cyclic" <+> ppr uids)
-    ppr (IgnoredDependencies uids)  = brackets (text "ignored" <+> ppr uids)
-    ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids)
+    ppr (IgnoredDependencies uids)  = brackets (text $ "unusable because the -ignore-package flag was used to " ++
+                                                       "ignore at least one of its dependencies:") $$
+                                        nest 2 (hsep (map ppr uids))
+    ppr (ShadowedDependencies uids) = brackets (text "unusable due to shadowed" <+> ppr uids)
 
 type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason)
 
@@ -1464,9 +1478,10 @@ validateDatabase cfg pkg_map1 =
 
 mkUnitState
     :: Logger
+    -> DynFlags
     -> UnitConfig
     -> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger dflags cfg = do
 {-
    Plan.
 
@@ -1621,8 +1636,72 @@ mkUnitState logger cfg = do
   -- it modifies the unit ids of wired in packages, but when we process
   -- package arguments we need to key against the old versions.
   --
-  (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
-  let pkg_db = mkUnitInfoMap pkgs2
+  (pkgs2, wired_map) <- findWiredInUnits logger (rtsWayUnitId dflags:wiredInUnitIds) prec_map pkgs1 vis_map2
+
+  --
+  -- Sanity check. If the rtsWayUnitId is not in the database, then we have a
+  -- problem.  The RTS is effectively missing.
+  unless (null pkgs1 || gopt Opt_NoRts dflags || anyUniqMap (== rtsWayUnitId dflags) wired_map) $ do
+    pprPanic "mkUnitState" $
+      vcat
+        [ text "debug details:"
+        , nest 2 $ vcat
+            [ text "pkgs1_count =" <+> ppr (length pkgs1)
+            , text "Opt_NoRts   =" <+> ppr (gopt Opt_NoRts dflags)
+            , text "ghcLink     =" <+> text (show (ghcLink dflags))
+            , text "platform    =" <+> text (show (targetPlatform dflags))
+            , text "rtsWayUnitId=" <+> ppr (rtsWayUnitId dflags)
+            , text "has_rts     =" <+> ppr (anyUniqMap (== rtsWayUnitId dflags) wired_map)
+            , text "wired_map   =" <+> ppr wired_map
+            , text "pkgs1 units (pre-wiring):" $$ nest 2 (pprWithCommas (\p -> ppr (unitId p) <+> parens (ppr (unitPackageName p))) pkgs1)
+            , text "pkgs2 units (post-wiring):" $$ nest 2 (pprWithCommas (\p -> ppr (unitId p) <+> parens (ppr (unitPackageName p))) pkgs2)
+            ]
+        ]
+      <> text "; The RTS for " <> ppr (rtsWayUnitId dflags)
+      <> text " is missing from the package database while building unit "
+      <> ppr (homeUnitId_ dflags)
+      <> text " (home units: " <> ppr (Set.toList (unitConfigHomeUnits cfg)) <> text ")."
+      <> text " Please check your installation."
+      <> text " If this target doesn't need the RTS (e.g. building a shared library), you can add -no-rts to the relevant package's ghc-options in cabal.project to bypass this check."
+
+  let pkgs3 = if gopt Opt_NoRts dflags && not (anyUniqMap (== ghcInternalUnitId) wired_map)
+              then pkgs2
+              else
+              -- At this point we should have `ghcInternalUnitId`, and the `rtsWiredUnitId dflags`.
+              -- The graph looks something like this:
+              --  ghc-internal
+              --    '- rtsWayUnitId dflags
+              --       '- rts ...
+              -- Notably the rtsWayUnitId is chosen by GHC _after_ the build plan by e.g. cabal
+              -- has been constructed.  We still need to ensure that ordering when linking
+              -- is correct. As such we'll manually make rtsWayUnitId dflags a dependency
+              -- of ghcInternalUnitId.
+
+              -- pkgs2: [UnitInfo] = [GenUnitInfo UnitId] = [GenericUnitInfo PackageId PackageName UnitId ModuleName (GenModule (GenUnit UnitId))]
+              -- GenericUnitInfo { unitId: UnitId, ..., unitAbiHash: ShortText, unitDepends: [UnitId], unitAbiDepends: [(UnitId, ShortText)], ... }
+              -- ghcInternalUnitId: UnitId
+              -- rtsWayUnitId dflags: UnitId
+                let rtsWayUnitIdHash = case [ unitAbiHash pkg | pkg <- pkgs2
+                                            , unitId pkg == rtsWayUnitId dflags] of
+                                            [] -> panic "rtsWayUnitId not found in wired-in packages"
+                                            [x] -> x
+                                            _ -> panic "rtsWayUnitId found multiple times in wired-in packages"
+                    ghcInternalUnit = case [ pkg | pkg <- pkgs2
+                                          , unitId pkg == ghcInternalUnitId ] of
+                                          [] -> panic "ghcInternalUnitId not found in wired-in packages"
+                                          [x] -> x
+                                          _ -> panic "ghcInternalUnitId found multiple times in wired-in packages"
+
+                    -- update ghcInternalUnit to depend on rtsWayUnitId dflags
+                    ghcInternalUnit' = ghcInternalUnit
+                      { unitDepends = rtsWayUnitId dflags : unitDepends ghcInternalUnit
+                      , unitAbiDepends = (rtsWayUnitId dflags, rtsWayUnitIdHash) : unitAbiDepends ghcInternalUnit
+                      }
+                in map (\pkg -> if unitId pkg == ghcInternalUnitId
+                                  then ghcInternalUnit'
+                                  else pkg) pkgs2
+
+  let pkg_db = mkUnitInfoMap pkgs3
 
   -- Update the visibility map, so we treat wired packages as visible.
   let vis_map = updateVisibilityMap wired_map vis_map2
@@ -1656,7 +1735,7 @@ mkUnitState logger cfg = do
                 return (updateVisibilityMap wired_map plugin_vis_map2)
 
   let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
-                              | p <- pkgs2
+                              | p <- pkgs3
                               ]
   -- The explicitUnits accurately reflects the set of units we have turned
   -- on; as such, it also is the only way one can come up with requirements.