[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: interpreter: Fix INTERP_STATS profiling code

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
66c7f656 by Matthew Pickering at 2025-02-06T17:15:25-05:00
interpreter: Fix INTERP_STATS profiling code

The profiling code had slightly bitrotted since the last time it was
used. This just fixes things so that if you toggle the INTERP_STATS
macro then it just works and prints out the stats.

Fixes #25695

- - - - -
f71c2835 by Matthew Pickering at 2025-02-06T17:16:02-05:00
perf: Key the interpreter symbol cache by Name rather than FastString

Profiles showed that about 0.2s was being spend constructing the keys
before looking up values in the old symbol cache.

The performance of this codepath is critical as it translates directly
to a delay when a user evaluates a function like `main` in the
interpreter.

Therefore we implement a solution which keys the cache(s) by `Name`
rather than the symbol directly, so the cache can be consulted before
the symbol is constructed.

Fixes #25731

- - - - -
4bbdceb9 by Ben Gamari at 2025-02-07T09:25:03-05:00
base: Label threads forked by IO operations

Addresses part of #25452.

Addresses core-libraries-committee#305.

- - - - -
aa387b37 by Ben Gamari at 2025-02-07T09:25:03-05:00
base: Label threads forked by System.Timeout

Addresses part of #25452.

Addresses core-libraries-committee#305.

- - - - -
c4b4feea by Ben Gamari at 2025-02-07T09:25:03-05:00
base: Label signal handling threads

Addresses part of #25452.

Addresses core-libraries-committee#305.

- - - - -
695e7584 by Ben Gamari at 2025-02-07T09:25:03-05:00
base: Label Windows console event handling threads

Addresses part of #25452.

Addresses core-libraries-committee#305.

- - - - -
e3ecf5a7 by Ben Gamari at 2025-02-07T09:25:03-05:00
ghci: Label evaluation sandbox thread

Addresses part of #25452.

Addresses core-libraries-committee#305.

- - - - -
d21db194 by Ben Gamari at 2025-02-07T09:25:04-05:00
base: Add changelog entry for addition of thread labels

Addresses #25452.

Addresses core-libraries-committee#305.

- - - - -
288178d3 by Ben Gamari at 2025-02-07T09:25:04-05:00
gen-ci: Clean up style

This cleans up a number of stylistic inconsistencies although it's still
far from perfect.

- - - - -
50fdf33f by Ben Gamari at 2025-02-07T09:25:04-05:00
gen-ci: Properly encapsulate GitLab predicates

- - - - -


22 changed files:

- .gitlab/generate-ci/gen_ci.hs
- compiler/GHC.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Runtime/Interpreter/Types.hs
- + compiler/GHC/Runtime/Interpreter/Types/SymbolCache.hs
- compiler/ghc.cabal.in
- libraries/base/changelog.md
- libraries/base/src/Control/Concurrent.hs
- libraries/base/src/System/Timeout.hs
- libraries/ghc-internal/src/GHC/Internal/Conc/Signal.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Windows/ConsoleEvent.hsc
- libraries/ghci/GHCi/Run.hs
- rts/Interpreter.c
- rts/Interpreter.h
- rts/RtsMain.c
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32


Changes:

=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -5,6 +5,12 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ViewPatterns #-}
 
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use newtype instead of data" #-}
+{-# HLINT ignore "Use camelCase" #-}
+{-# LANGUAGE DerivingStrategies #-}
+
 import Data.Aeson as A
 import qualified Data.Map as Map
 import Data.Map (Map)
@@ -199,7 +205,7 @@ data FlavourTrans =
 data BaseFlavour = Release | Validate | SlowValidate deriving Eq
 
 -----------------------------------------------------------------------------
--- Build Configs
+-- Build Configurations
 -----------------------------------------------------------------------------
 
 -- | A standard build config
@@ -244,7 +250,7 @@ releaseConfig = vanilla { buildFlavour = Release }
 debug :: BuildConfig
 debug = vanilla { buildFlavour = SlowValidate
                 , withAssertions = True
-                -- WithNuma so at least one job tests Numa
+                  -- WithNuma so at least one job tests Numa
                 , withNuma = True
                 }
 
@@ -280,21 +286,21 @@ usePerfProfilingTestsuite :: BuildConfig -> BuildConfig
 usePerfProfilingTestsuite bc = bc { testsuiteUsePerf = True }
 
 -----------------------------------------------------------------------------
--- Platform specific variables
+-- Identifying Platforms
 -----------------------------------------------------------------------------
 
 -- | These tags have to match what we call the runners on gitlab
 runnerTag :: Arch -> Opsys -> String
 runnerTag arch (Linux _) =
   case arch of
-    Amd64   -> "x86_64-linux"
-    AArch64 -> "aarch64-linux"
-    I386    -> "x86_64-linux"
-runnerTag AArch64 Darwin = "aarch64-darwin"
-runnerTag Amd64 Darwin = "x86_64-darwin-m1"
-runnerTag Amd64 Windows = "new-x86_64-windows"
+    Amd64                -> "x86_64-linux"
+    AArch64              -> "aarch64-linux"
+    I386                 -> "x86_64-linux"
+runnerTag AArch64 Darwin  = "aarch64-darwin"
+runnerTag Amd64 Darwin    = "x86_64-darwin-m1"
+runnerTag Amd64 Windows   = "new-x86_64-windows"
 runnerTag Amd64 FreeBSD14 = "x86_64-freebsd14"
-runnerTag _ _ = error "Invalid arch/opsys"
+runnerTag _ _             = error "Invalid arch/opsys"
 
 tags :: Arch -> Opsys -> BuildConfig -> [String]
 tags arch opsys _bc = [runnerTag arch opsys] -- Tag for which runners we can use
@@ -305,34 +311,34 @@ runnerPerfTag arch sys = runnerTag arch sys ++ "-perf"
 -- These names are used to find the docker image so they have to match what is
 -- in the docker registry.
 distroName :: LinuxDistro -> String
-distroName Debian12   = "deb12"
-distroName Debian11   = "deb11"
-distroName Debian11Js = "deb11-emsdk-closure"
+distroName Debian12      = "deb12"
+distroName Debian11      = "deb11"
+distroName Debian11Js    = "deb11-emsdk-closure"
 distroName Debian12Riscv = "deb12-riscv"
-distroName Debian10   = "deb10"
-distroName Debian9    = "deb9"
-distroName Fedora33   = "fedora33"
-distroName Fedora38   = "fedora38"
-distroName Ubuntu1804 = "ubuntu18_04"
-distroName Ubuntu2004 = "ubuntu20_04"
-distroName Ubuntu2204 = "ubuntu22_04"
-distroName Centos7    = "centos7"
-distroName Alpine312  = "alpine3_12"
-distroName Alpine318  = "alpine3_18"
-distroName Alpine320  = "alpine3_20"
-distroName AlpineWasm = "alpine3_20-wasm"
-distroName Rocky8     = "rocky8"
+distroName Debian10      = "deb10"
+distroName Debian9       = "deb9"
+distroName Fedora33      = "fedora33"
+distroName Fedora38      = "fedora38"
+distroName Ubuntu1804    = "ubuntu18_04"
+distroName Ubuntu2004    = "ubuntu20_04"
+distroName Ubuntu2204    = "ubuntu22_04"
+distroName Centos7       = "centos7"
+distroName Alpine312     = "alpine3_12"
+distroName Alpine318     = "alpine3_18"
+distroName Alpine320     = "alpine3_20"
+distroName AlpineWasm    = "alpine3_20-wasm"
+distroName Rocky8        = "rocky8"
 
 opsysName :: Opsys -> String
 opsysName (Linux distro) = "linux-" ++ distroName distro
-opsysName Darwin = "darwin"
-opsysName FreeBSD14 = "freebsd14"
-opsysName Windows = "windows"
+opsysName Darwin         = "darwin"
+opsysName FreeBSD14      = "freebsd14"
+opsysName Windows        = "windows"
 
 archName :: Arch -> String
-archName Amd64 = "x86_64"
+archName Amd64   = "x86_64"
 archName AArch64 = "aarch64"
-archName I386  = "i386"
+archName I386    = "i386"
 
 binDistName :: Arch -> Opsys -> BuildConfig -> String
 binDistName arch opsys bc = "ghc-" ++ testEnv arch opsys bc
@@ -341,16 +347,18 @@ binDistName arch opsys bc = "ghc-" ++ testEnv arch opsys bc
 -- Either the change is reflected by modifying the flavourString or directly (as is
 -- the case for settings which affect environment variables)
 testEnv :: Arch -> Opsys -> BuildConfig -> String
-testEnv arch opsys bc = intercalate "-" $
-                        [ archName arch
-                        , opsysName opsys ]
-                        ++ ["int_" ++ bignumString (bignumBackend bc) | bignumBackend bc /= Gmp]
-                        ++ ["unreg" | unregisterised bc ]
-                        ++ ["numa"  | withNuma bc ]
-                        ++ ["zstd"  | withZstd bc ]
-                        ++ ["no_tntc"  | not (tablesNextToCode bc) ]
-                        ++ ["cross_"++triple  | Just triple <- pure $ crossTarget bc ]
-                        ++ [flavourString (mkJobFlavour bc)]
+testEnv arch opsys bc =
+  intercalate "-" $ concat
+    [ [ archName arch
+      , opsysName opsys ]
+    , ["int_" ++ bignumString (bignumBackend bc) | bignumBackend bc /= Gmp]
+    , ["unreg" | unregisterised bc ]
+    , ["numa"  | withNuma bc ]
+    , ["zstd"  | withZstd bc ]
+    , ["no_tntc"  | not (tablesNextToCode bc) ]
+    , ["cross_"++triple  | Just triple <- pure $ crossTarget bc ]
+    , [flavourString (mkJobFlavour bc)]
+    ]
 
 -- | The hadrian flavour string we are going to use for this build
 flavourString :: Flavour -> String
@@ -384,7 +392,7 @@ dockerImage arch (Linux distro) =
 dockerImage _ _ = Nothing
 
 -----------------------------------------------------------------------------
--- Platform specific variables
+-- Platform-specific variables
 -----------------------------------------------------------------------------
 
 -- The variables map is a monoidal map so that we don't ever accidentally lose
@@ -438,35 +446,36 @@ opsysVariables _ FreeBSD14 = mconcat
   , "CABAL_INSTALL_VERSION" =: "3.10.3.0"
   ]
 opsysVariables arch (Linux distro) = distroVariables arch distro
-opsysVariables AArch64 (Darwin {}) =
-  mconcat [ "NIX_SYSTEM" =: "aarch64-darwin"
-          , "MACOSX_DEPLOYMENT_TARGET" =: "11.0"
-          , "LANG" =: "en_US.UTF-8"
-          , "CONFIGURE_ARGS" =: "--with-intree-gmp --with-system-libffi"
-          -- Fonts can't be installed on darwin
-          , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
-          ]
-opsysVariables Amd64 (Darwin {}) =
-  mconcat [ "NIX_SYSTEM" =: "x86_64-darwin"
-          , "MACOSX_DEPLOYMENT_TARGET" =: "11.0"
-          -- "# Only Sierra and onwards supports clock_gettime. See #12858"
-          , "ac_cv_func_clock_gettime" =: "no"
-          -- # Only newer OS Xs support utimensat. See #17895
-          , "ac_cv_func_utimensat" =: "no"
-          -- # Only newer OS Xs support futimens. See #22938
-          , "ac_cv_func_futimens" =: "no"
-          , "LANG" =: "en_US.UTF-8"
-          , "CONFIGURE_ARGS" =: "--with-intree-gmp --with-system-libffi"
-          -- Fonts can't be installed on darwin
-          , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
+opsysVariables AArch64 (Darwin {}) = mconcat
+  [ "NIX_SYSTEM" =: "aarch64-darwin"
+  , "MACOSX_DEPLOYMENT_TARGET" =: "11.0"
+  , "LANG" =: "en_US.UTF-8"
+  , "CONFIGURE_ARGS" =: "--with-intree-gmp --with-system-libffi"
+    -- Fonts can't be installed on darwin
+  , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
+  ]
+opsysVariables Amd64 (Darwin {}) = mconcat
+  [ "NIX_SYSTEM" =: "x86_64-darwin"
+  , "MACOSX_DEPLOYMENT_TARGET" =: "11.0"
+    -- Only Sierra and onwards supports clock_gettime. See #12858
+  , "ac_cv_func_clock_gettime" =: "no"
+    -- Only newer OS Xs support utimensat. See #17895
+  , "ac_cv_func_utimensat" =: "no"
+    -- Only newer OS Xs support futimens. See #22938
+  , "ac_cv_func_futimens" =: "no"
+  , "LANG" =: "en_US.UTF-8"
+  , "CONFIGURE_ARGS" =: "--with-intree-gmp --with-system-libffi"
+    -- Fonts can't be installed on darwin
+  , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
 
-          ]
-opsysVariables _ (Windows {}) =
-  mconcat [ "MSYSTEM" =: "CLANG64"
-          , "LANG" =: "en_US.UTF-8"
-          , "CABAL_INSTALL_VERSION" =: "3.10.2.0"
-          , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
-          , "GHC_VERSION" =: "9.6.4" ]
+  ]
+opsysVariables _ (Windows {}) = mconcat
+  [ "MSYSTEM" =: "CLANG64"
+  , "LANG" =: "en_US.UTF-8"
+  , "CABAL_INSTALL_VERSION" =: "3.10.2.0"
+  , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
+  , "GHC_VERSION" =: "9.6.4"
+  ]
 opsysVariables _ _ = mempty
 
 alpineVariables :: Arch -> Variables
@@ -481,7 +490,7 @@ alpineVariables arch = mconcat $
   | I386 <- [arch]
   ] ++
   [ brokenTest "T22033" "#25497" | I386 <- [arch] ] ++
-  [-- Bootstrap compiler has incorrectly configured target triple #25200
+  [ -- Bootstrap compiler has incorrectly configured target triple #25200
     "CONFIGURE_ARGS" =: "--enable-ignore-build-platform-mismatch --build=aarch64-unknown-linux --host=aarch64-unknown-linux --target=aarch64-unknown-linux"
   | AArch64 <- [arch]
   ]
@@ -491,15 +500,14 @@ distroVariables :: Arch -> LinuxDistro -> Variables
 distroVariables arch Alpine312 = alpineVariables arch
 distroVariables arch Alpine318 = alpineVariables arch
 distroVariables arch Alpine320 = alpineVariables arch
-distroVariables _ Centos7 = mconcat [
-    "HADRIAN_ARGS" =: "--docs=no-sphinx"
-  , brokenTest "T22012" "#23979"
-  ]
-distroVariables _ Fedora33 = mconcat
+distroVariables _    Centos7   = mconcat [ "HADRIAN_ARGS" =: "--docs=no-sphinx"
+                                         , brokenTest "T22012" "#23979"
+                                         ]
+distroVariables _    Fedora33  = mconcat
   -- LLC/OPT do not work for some reason in our fedora images
   -- These tests fail with this error: T11649 T5681 T7571 T8131b
   -- +/opt/llvm/bin/opt: /lib64/libtinfo.so.5: no version information available (required by /opt/llvm/bin/opt)
--- +/opt/llvm/bin/llc: /lib64/libtinfo.so.5: no version information available (required by /opt/llvm/bin/llc)
+  -- +/opt/llvm/bin/llc: /lib64/libtinfo.so.5: no version information available (required by /opt/llvm/bin/llc)
   [ "LLC" =: "/bin/false"
   , "OPT" =: "/bin/false"
   ]
@@ -510,7 +518,7 @@ distroVariables _ _ = mempty
 -----------------------------------------------------------------------------
 
 data Cache
-  = Cache { cacheKey :: String
+  = Cache { cacheKey   :: String
           , cachePaths :: [String]
           }
 
@@ -550,25 +558,27 @@ data ArtifactsWhen = ArtifactsOnSuccess | ArtifactsOnFailure | ArtifactsAlways
 instance ToJSON ArtifactsWhen where
   toJSON ArtifactsOnSuccess = "on_success"
   toJSON ArtifactsOnFailure = "on_failure"
-  toJSON ArtifactsAlways = "always"
+  toJSON ArtifactsAlways    = "always"
 
------------------------------------------------------------------------------
+---------------------------------------------------------------------
 -- Rules, when do we run a job
------------------------------------------------------------------------------
+---------------------------------------------------------------------
 
--- Data structure which records the condition when a job is run.
-data OnOffRules = OnOffRules { rule_set :: Rule -- ^ The enabled rules
-                             , when :: ManualFlag   -- ^ The additional condition about when to run this job.
-                             }
+-- | Data structure which records the condition when a job is run.
+data OnOffRules
+  = OnOffRules { rule_set :: Rule -- ^ The enabled rules
+               , when     :: ManualFlag   -- ^ The additional condition about when to run this job.
+               }
 
 -- The initial set of rules, which assumes a Validate pipeline which is run with FullCI.
 emptyRules :: String -> OnOffRules
 emptyRules jobName = OnOffRules (ValidateOnly jobName (S.fromList [FullCI])) OnSuccess
 
 -- When to run the job
-data ManualFlag = Manual -- ^ Only run the job when explicitly triggered by a user
-                | OnSuccess -- ^ Always run it, if the rules pass (the default)
-                deriving Eq
+data ManualFlag
+  = Manual -- ^ Only run the job when explicitly triggered by a user
+  | OnSuccess -- ^ Always run it, if the rules pass (the default)
+  deriving Eq
 
 setRule :: Rule -> OnOffRules -> OnOffRules
 setRule r (OnOffRules _ m) = OnOffRules r m
@@ -595,18 +605,23 @@ manualRule rules = rules { when = Manual }
 enumRules :: OnOffRules -> [OnOffRule]
 enumRules (OnOffRules r _) = rulesList
   where
-    rulesList = case r of
-                  ValidateOnly s rs -> [OnOffRule On (ValidateOnly s rs)
-                                    , OnOffRule Off ReleaseOnly
-                                    , OnOffRule Off Nightly ]
-                  Nightly -> [ OnOffRule Off (ValidateOnly "" S.empty)
-                             , OnOffRule Off ReleaseOnly
-                             , OnOffRule On Nightly ]
-                  ReleaseOnly -> [ OnOffRule Off (ValidateOnly "" S.empty)
-                                 , OnOffRule On ReleaseOnly
-                                 , OnOffRule Off Nightly ]
-
-
+    rulesList =
+      case r of
+        ValidateOnly s rs ->
+          [ OnOffRule On (ValidateOnly s rs)
+          , OnOffRule Off ReleaseOnly
+          , OnOffRule Off Nightly
+          ]
+        Nightly ->
+          [ OnOffRule Off (ValidateOnly "" S.empty)
+          , OnOffRule Off ReleaseOnly
+          , OnOffRule On Nightly
+          ]
+        ReleaseOnly ->
+          [ OnOffRule Off (ValidateOnly "" S.empty)
+          , OnOffRule On ReleaseOnly
+          , OnOffRule Off Nightly
+          ]
 
 data OnOffRule = OnOffRule OnOff Rule
 
@@ -617,102 +632,135 @@ instance ToJSON ManualFlag where
   toJSON OnSuccess = "on_success"
 
 instance ToJSON OnOffRules where
-  toJSON rules = toJSON [object ([
-    "if" A..= and_all (map one_rule (enumRules rules))
-    , "when" A..= toJSON (when rules)]
-    -- Necessary to stop manual jobs stopping pipeline progress
-    -- https://docs.gitlab.com/ee/ci/yaml/#rulesallow_failure
-    ++
-    ["allow_failure" A..= True | when rules == Manual ])]
-
+  toJSON rules = toJSON
+      [object $
+        [ "if" A..= and_all (map one_rule (enumRules rules))
+        , "when" A..= toJSON (when rules)
+        ] ++
+        -- Necessary to stop manual jobs stopping pipeline progress
+        -- https://docs.gitlab.com/ee/ci/yaml/#rulesallow_failure
+        [ "allow_failure" A..= True | when rules == Manual ]
+      ]
     where
-      one_rule (OnOffRule onoff r) = ruleString onoff r
+      one_rule (OnOffRule onoff r) = ruleToCond onoff r
 
+---------------------------------------------------------------------
+-- Rule conditions
+---------------------------------------------------------------------
 
-parens :: [Char] -> [Char]
-parens s = "(" ++ s ++ ")"
-and_all :: [[Char]] -> [Char]
-and_all rs = intercalate " && " (map parens rs)
-or_all :: [[Char]] -> [Char]
-or_all rs = intercalate " || " (map parens rs)
+-- | A predicate in GitLab's rules language.
+newtype Cond = Cond { getCond :: String }
+  deriving newtype (ToJSON)
 
--- | A Rule corresponds to some condition which must be satisifed in order to
--- run the job.
-data Rule = ReleaseOnly  -- ^ Only run this job in a release pipeline
-          | Nightly      -- ^ Only run this job in the nightly pipeline
-          | ValidateOnly String (S.Set ValidateRule) -- ^ Only run this job in a validate pipeline, when any of these rules are enabled.
-          deriving (Show, Ord, Eq)
-
-data ValidateRule =
-            FullCI       -- ^ Run this job when the "full-ci" label is present.
-          | FastCI       -- ^ Run this job on every validation pipeline
-          | LLVMBackend  -- ^ Run this job when the "LLVM backend" label is present
-          | JSBackend    -- ^ Run this job when the "javascript" label is present
-          | RiscV        -- ^ Run this job when the "RISC-V" label is present
-          | WasmBackend  -- ^ Run this job when the "wasm" label is present
-          | FreeBSDLabel -- ^ Run this job when the "FreeBSD" label is set.
-          | NonmovingGc  -- ^ Run this job when the "non-moving GC" label is set.
-          | IpeData      -- ^ Run this job when the "IPE" label is set
-          | TestPrimops  -- ^ Run this job when "test-primops" label is set
-          | I386Backend  -- ^ Run this job when the "i386" label is set
-          deriving (Show, Ord, Eq)
-
--- A constant evaluating to True because gitlab doesn't support "true" in the
+parens :: Cond -> Cond
+parens (Cond s) = Cond $ "(" ++ s ++ ")"
+
+and_all :: [Cond] -> Cond
+and_all =
+  Cond . intercalate " && " . map (getCond . parens)
+
+or_all :: [Cond] -> Cond
+or_all =
+  Cond . intercalate " || " . map (getCond . parens)
+
+type Var = String
+
+varIsSet :: Var -> Cond
+varIsSet var =
+  Cond $ "$" <> var
+
+-- | A constant evaluating to True because gitlab doesn't support "true" in the
 -- expression language.
-true :: String
-true =  "\"true\" == \"true\""
--- A constant evaluating to False because gitlab doesn't support "true" in the
+true :: Cond
+true = Cond "\"true\" == \"true\""
+
+-- | A constant evaluating to False because gitlab doesn't support "true" in the
 -- expression language.
-_false :: String
-_false = "\"disabled\" != \"disabled\""
-
--- Convert the state of the rule into a string that gitlab understand.
-ruleString :: OnOff -> Rule -> String
-ruleString On (ValidateOnly only_job_name vs) =
-  let conds = S.toList vs
-      empty_only_job = envVarNull "ONLY_JOBS"
-      run_cond = case conds of
-                  [] -> _false
-                  cs -> or_all (map validateRuleString conds)
-      escape :: String -> String
-      escape = concatMap (\c -> if c == '+' then "\\+" else [c])
-
-  in
-    or_all  [
-    -- 1. Case when ONLY_JOBS is set
-      and_all [ "$ONLY_JOBS", "$ONLY_JOBS =~ /.*\\b" ++  escape only_job_name ++ "(\\s|$).*/" ]
-    -- 2. Case when ONLY_JOBS is null
-    , and_all [ empty_only_job, run_cond ]
-    ]
-ruleString Off (ValidateOnly {}) = true
-ruleString On ReleaseOnly = "$RELEASE_JOB == \"yes\""
-ruleString Off ReleaseOnly = "$RELEASE_JOB != \"yes\""
-ruleString On Nightly = "$NIGHTLY"
-ruleString Off Nightly = envVarNull "NIGHTLY"
+_false :: Cond
+_false = Cond "\"disabled\" != \"disabled\""
+
+labelString :: String -> Cond
+labelString s =
+  Cond $ "$CI_MERGE_REQUEST_LABELS =~ /.*" ++ s ++ ".*/"
 
-labelString :: String -> String
-labelString s =  "$CI_MERGE_REQUEST_LABELS =~ /.*" ++ s ++ ".*/"
+branchStringExact :: String -> Cond
+branchStringExact =
+  varEqString "CI_COMMIT_BRANCH"
 
-branchStringExact :: String -> String
-branchStringExact s = envVarString "CI_COMMIT_BRANCH" s
+branchStringLike :: String -> Cond
+branchStringLike s =
+  Cond $ "$CI_COMMIT_BRANCH =~ /" ++ s ++ "/"
 
-branchStringLike :: String -> String
-branchStringLike s = "$CI_COMMIT_BRANCH =~ /" ++ s ++ "/"
+varEqString :: String -> String -> Cond
+varEqString var s =
+  Cond $ "$" ++ var ++ " == \"" ++ s ++ "\""
 
-envVarString :: String -> String -> String
-envVarString var s = "$" ++ var ++ " == \"" ++ s ++ "\""
+varNeString :: String -> String -> Cond
+varNeString var s =
+  Cond $ "$" ++ var ++ " != \"" ++ s ++ "\""
 
-envVarNull :: String ->  String
-envVarNull var = "$" ++ var ++ " == null"
+varIsNull :: String -> Cond
+varIsNull var =
+  Cond $ "$" ++ var ++ " == null"
 
+---------------------------------------------------------------------
+-- Our Rules
+---------------------------------------------------------------------
 
-validateRuleString :: ValidateRule -> String
-validateRuleString FullCI = or_all ([ labelString "full-ci"
-                                    , labelString "marge_bot_batch_merge_job"
-                                    , branchStringExact "master"
-                                    , branchStringLike "ghc-[0-9]+\\.[0-9]+"
-                                    ])
-validateRuleString FastCI = true
+-- | A Rule corresponds to some condition which must be satisifed in order to
+-- run the job.
+data Rule
+  = ReleaseOnly  -- ^ Only run this job in a release pipeline
+  | Nightly      -- ^ Only run this job in the nightly pipeline
+  | ValidateOnly String (S.Set ValidateRule) -- ^ Only run this job in a validate pipeline, when any of these rules are enabled.
+  deriving (Show, Ord, Eq)
+
+data ValidateRule
+  = FullCI       -- ^ Run this job when the "full-ci" label is present.
+  | FastCI       -- ^ Run this job on every validation pipeline
+  | LLVMBackend  -- ^ Run this job when the "LLVM backend" label is present
+  | JSBackend    -- ^ Run this job when the "javascript" label is present
+  | RiscV        -- ^ Run this job when the "RISC-V" label is present
+  | WasmBackend  -- ^ Run this job when the "wasm" label is present
+  | FreeBSDLabel -- ^ Run this job when the "FreeBSD" label is set.
+  | NonmovingGc  -- ^ Run this job when the "non-moving GC" label is set.
+  | IpeData      -- ^ Run this job when the "IPE" label is set
+  | TestPrimops  -- ^ Run this job when "test-primops" label is set
+  | I386Backend  -- ^ Run this job when the "i386" label is set
+  deriving (Show, Ord, Eq)
+
+-- | Convert the state of the rule into a string that gitlab understand.
+ruleToCond :: OnOff -> Rule -> Cond
+ruleToCond On (ValidateOnly only_job_name vs) =
+    or_all
+    [ -- 1. Case when ONLY_JOBS is set
+      and_all [ varIsSet "ONLY_JOBS"
+              , Cond $ "$ONLY_JOBS =~ /.*\\b" ++ escape only_job_name ++ "(\\s|$).*/"
+              ]
+      -- 2. Case when ONLY_JOBS is null
+    , and_all [ varIsNull "ONLY_JOBS"
+              , case S.toList vs of
+                  [] -> _false
+                  cs -> or_all (map validateRuleString cs)
+              ]
+    ]
+  where
+    escape :: String -> String
+    escape = concatMap (\c -> if c == '+' then "\\+" else [c])
+ruleToCond Off (ValidateOnly {}) = true
+ruleToCond On  ReleaseOnly       = "RELEASE_JOB" `varEqString` "yes"
+ruleToCond Off ReleaseOnly       = "RELEASE_JOB" `varNeString` "yes"
+ruleToCond On  Nightly           = varIsSet "NIGHTLY"
+ruleToCond Off Nightly           = varIsNull "NIGHTLY"
+
+
+validateRuleString :: ValidateRule -> Cond
+validateRuleString FullCI       = or_all [ labelString "full-ci"
+                                         , labelString "marge_bot_batch_merge_job"
+                                         , branchStringExact "master"
+                                         , branchStringLike "ghc-[0-9]+\\.[0-9]+"
+                                         ]
+validateRuleString FastCI       = true
 
 validateRuleString LLVMBackend  = labelString "LLVM backend"
 validateRuleString JSBackend    = labelString "javascript"
@@ -724,6 +772,10 @@ validateRuleString IpeData      = labelString "IPE"
 validateRuleString TestPrimops  = labelString "test-primops"
 validateRuleString I386Backend  = labelString "i386"
 
+---------------------------------------------------------------------
+-- The Job type
+---------------------------------------------------------------------
+
 -- | A 'Job' is the description of a single job in a gitlab pipeline. The
 -- job contains all the information about how to do the build but can be further
 -- modified with information about when to run jobs, which variables to set for
@@ -747,15 +799,15 @@ data Job
 instance ToJSON Job where
   toJSON Job{..} = object
     [ "stage" A..= jobStage
-    -- Convoluted to avoid download artifacts from ghci job
-    -- https://docs.gitlab.com/ee/ci/yaml/#needsartifacts
+      -- Convoluted to avoid download artifacts from ghci job
+      -- https://docs.gitlab.com/ee/ci/yaml/#needsartifacts
     , "needs" A..= map (\j -> object [ "job" A..= j, "artifacts" A..= False ]) jobNeeds
     , "dependencies" A..= jobDependencies
     , "image" A..= jobDockerImage
     , "tags" A..= jobTags
     , "allow_failure" A..= jobAllowFailure
-    -- Joining up variables like this may well be the wrong thing to do but
-    -- at least it doesn't lose information silently by overriding.
+      -- Joining up variables like this may well be the wrong thing to do but
+      -- at least it doesn't lose information silently by overriding.
     , "variables" A..= fmap unwords jobVariables
     , "artifacts" A..= jobArtifacts
     , "cache" A..= jobCache
@@ -783,7 +835,8 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} }
       = [ "bash .gitlab/ci.sh setup"
         , "bash .gitlab/ci.sh configure"
         , "bash .gitlab/ci.sh build_hadrian"
-        , "bash .gitlab/ci.sh test_hadrian" ]
+        , "bash .gitlab/ci.sh test_hadrian"
+        ]
       | otherwise
       = [ "find libraries -name config.sub -exec cp config.sub {} \\;" | Darwin == opsys ] ++
         [ "sudo chown ghc:ghc -R ." | Linux {} <- [opsys]] ++
@@ -803,7 +856,8 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} }
       [ ".gitlab/ci.sh save_cache"
       , ".gitlab/ci.sh save_test_output"
       , ".gitlab/ci.sh clean"
-      , "cat ci_timings" ]
+      , "cat ci_timings"
+      ]
 
     jobFlavour = mkJobFlavour buildConfig
 
@@ -819,9 +873,11 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} }
       , maybe mempty ("CONFIGURE_WRAPPER" =:) (configureWrapper buildConfig)
       , maybe mempty ("CROSS_TARGET" =:) (crossTarget buildConfig)
       , case crossEmulator buildConfig of
-          NoEmulator       -> case crossTarget buildConfig of
-            Nothing -> mempty
-            Just _  -> "CROSS_EMULATOR" =: "NOT_SET" -- we need an emulator but it isn't set. Won't run the testsuite
+          NoEmulator
+            -- we need an emulator but it isn't set. Won't run the testsuite
+            | Just _ <- crossTarget buildConfig
+                           -> "CROSS_EMULATOR" =: "NOT_SET"
+            | otherwise    -> mempty
           Emulator s       -> "CROSS_EMULATOR" =: s
           NoEmulatorNeeded -> mempty
       , if withNuma buildConfig then "ENABLE_NUMA" =: "1" else mempty
@@ -901,8 +957,10 @@ setVariable k v j = j { jobVariables = MonoidalMap $ Map.insert k [v] $ unMonoid
 delVariable :: String -> Job -> Job
 delVariable k j = j { jobVariables = MonoidalMap $ Map.delete k $ unMonoidalMap $ jobVariables j }
 
+---------------------------------------------------------------------
 -- Building the standard jobs
---
+---------------------------------------------------------------------
+
 -- | Make a normal validate CI job
 validate :: Arch -> Opsys -> BuildConfig -> NamedJob Job
 validate = job
@@ -919,15 +977,27 @@ releaseRule = setJobRule ReleaseOnly
 nightly :: Arch -> Opsys -> BuildConfig -> NamedJob Job
 nightly arch opsys bc =
   let NamedJob n j = job arch opsys bc
-  in NamedJob { name = "nightly-" ++ n, jobInfo = nightlyRule . keepArtifacts "8 weeks" . highCompression $ j}
+  in NamedJob { name = "nightly-" ++ n
+              , jobInfo = nightlyRule
+                        . keepArtifacts "8 weeks"
+                        . highCompression $ j
+              }
 
 -- | Make a normal release CI job
 release :: Arch -> Opsys -> BuildConfig -> NamedJob Job
 release arch opsys bc =
   let NamedJob n j = job arch opsys (bc { buildFlavour = Release })
-  in NamedJob { name = "release-" ++ n, jobInfo = releaseRule . keepArtifacts "1 year" . ignorePerfFailures . useHashUnitIds . highCompression $ j}
+  in NamedJob { name = "release-" ++ n
+              , jobInfo = releaseRule
+                        . keepArtifacts "1 year"
+                        . ignorePerfFailures
+                        . useHashUnitIds
+                        . highCompression $ j
+              }
 
+---------------------------------------------------------------------
 -- Specific job modification functions
+---------------------------------------------------------------------
 
 -- | Mark a job as requiring a manual trigger.
 manual :: Job -> Job
@@ -984,6 +1054,10 @@ onlyRule t = modifyValidateJobs (onlyValidateJobRule t)
 disableValidate :: JobGroup Job -> JobGroup Job
 disableValidate = modifyValidateJobs (removeValidateJobRule FastCI . removeValidateJobRule FullCI)
 
+---------------------------------------------------------------------
+-- NamedJob
+---------------------------------------------------------------------
+
 data NamedJob a = NamedJob { name :: String, jobInfo :: a } deriving (Show, Functor)
 
 renameJob :: (String -> String) -> NamedJob a -> NamedJob a
@@ -994,14 +1068,18 @@ instance ToJSON a => ToJSON (NamedJob a) where
     [ "name" A..= name nj
     , "jobInfo" A..= jobInfo nj ]
 
-
---data NamedJobGroup a = NamedJobGroup { platform :: String, jg :: JobGroup a }
+---------------------------------------------------------------------
+-- JobGroup
+---------------------------------------------------------------------
 
 -- Jobs are grouped into either triples or pairs depending on whether the
 -- job is just validate and nightly, or also release.
-data JobGroup a = StandardTriple { v :: Maybe (NamedJob a)
-                                 , n :: Maybe (NamedJob a)
-                                 , r :: Maybe (NamedJob a) } deriving (Functor, Show)
+data JobGroup a
+  = StandardTriple { v :: Maybe (NamedJob a)
+                   , n :: Maybe (NamedJob a)
+                   , r :: Maybe (NamedJob a)
+                   }
+  deriving (Functor, Show)
 
 instance ToJSON a => ToJSON (JobGroup a) where
   toJSON StandardTriple{..} = object
@@ -1039,16 +1117,19 @@ flattenJobGroup (StandardTriple a b c) = map flattenNamedJob (catMaybes [a,b,c])
 flattenNamedJob :: NamedJob a -> (String, a)
 flattenNamedJob (NamedJob n i) = (n, i)
 
-
 -- | Specification for all the jobs we want to build.
 jobs :: Map String Job
-jobs = Map.fromList $ concatMap (flattenJobGroup) job_groups
+jobs = Map.fromList $ concatMap flattenJobGroup job_groups
+
+---------------------------------------------------------------------
+-- Job definitions
+---------------------------------------------------------------------
 
 debian_x86 :: [JobGroup Job]
 debian_x86 =
   [ -- Release configurations
-  -- We still build Deb9 bindists for now due to Ubuntu 18 and Linux Mint 19
-  -- not being at EOL until April 2023 and they still need tinfo5.
+    -- We still build Deb9 bindists for now due to Ubuntu 18 and Linux Mint 19
+    -- not being at EOL until April 2023 and they still need tinfo5.
     disableValidate (standardBuildsWithConfig Amd64 (Linux Debian9) (splitSectionsBroken vanilla))
   , disableValidate (standardBuilds Amd64 (Linux Debian10))
   , disableValidate (standardBuildsWithConfig Amd64 (Linux Debian10) dwarf)
@@ -1056,15 +1137,15 @@ debian_x86 =
   , disableValidate (standardBuilds Amd64 (Linux Debian12))
 
 
-  -- Validate only builds
+    -- Validate only builds
   , fastCI (validateBuilds Amd64 (Linux validate_debian) debug)
   , validateBuilds Amd64 (Linux validate_debian) nativeInt
   , validateBuilds Amd64 (Linux validate_debian) unreg
-   -- More work is needed to address TSAN failures: #22520
+    -- More work is needed to address TSAN failures: #22520
   , modifyNightlyJobs allowFailure (modifyValidateJobs (allowFailure . manual) tsan_jobs)
   , -- Nightly allowed to fail: #22343
     modifyNightlyJobs allowFailure (modifyValidateJobs manual (validateBuilds Amd64 (Linux validate_debian) noTntc))
-  -- Run the 'perf' profiling nightly job in the release config.
+    -- Run the 'perf' profiling nightly job in the release config.
   , perfProfilingJob Amd64 (Linux Debian12) releaseConfig
 
   , onlyRule LLVMBackend (validateBuilds Amd64 (Linux validate_debian) llvm)
@@ -1095,7 +1176,7 @@ debian_aarch64 =
   [
      disableValidate (standardBuildsWithConfig AArch64 (Linux Debian10) (splitSectionsBroken vanilla))
    , fastCI (standardBuildsWithConfig AArch64 (Linux Debian12) (splitSectionsBroken vanilla))
-   -- LLVM backend bootstrap
+     -- LLVM backend bootstrap
    , onlyRule LLVMBackend (validateBuilds AArch64 (Linux Debian12) llvm)
   ]
 
@@ -1120,11 +1201,10 @@ rhel_x86 =
 
 fedora_x86 :: [JobGroup Job]
 fedora_x86 =
-  [
-  -- Fedora33 job is always built with perf so there's one job in the normal
-  -- validate pipeline which is built with perf.
+  [ -- Fedora33 job is always built with perf so there's one job in the normal
+    -- validate pipeline which is built with perf.
     fastCI (standardBuildsWithConfig Amd64 (Linux Fedora33) releaseConfig)
-  -- This job is only for generating head.hackage docs
+    -- This job is only for generating head.hackage docs
   , hackage_doc_job (disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora33) releaseConfig))
   , disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora33) dwarf)
   , disableValidate (standardBuilds Amd64 (Linux Fedora38))
@@ -1154,7 +1234,7 @@ alpine_x86 =
   [ -- Fully static build, in theory usable on any linux distribution.
     fullyStaticBrokenTests (standardBuildsWithConfig Amd64 (Linux Alpine312) (splitSectionsBroken static))
   , fullyStaticBrokenTests (disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine312) staticNativeInt)))
-  -- Dynamically linked build, suitable for building your own static executables on alpine
+    -- Dynamically linked build, suitable for building your own static executables on alpine
   , disableValidate (standardBuildsWithConfig Amd64 (Linux Alpine312) (splitSectionsBroken vanilla))
   , disableValidate (standardBuildsWithConfig Amd64 (Linux Alpine320) (splitSectionsBroken vanilla))
   , allowFailureGroup (standardBuildsWithConfig I386 (Linux Alpine320) (splitSectionsBroken vanilla))
@@ -1173,16 +1253,16 @@ alpine_aarch64 = [
 
 cross_jobs :: [JobGroup Job]
 cross_jobs = [
-  -- x86 -> aarch64
+    -- x86 -> aarch64
     validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing)
 
-  -- x86_64 -> riscv
+    -- x86_64 -> riscv
   , addValidateRule RiscV (validateBuilds Amd64 (Linux Debian12Riscv) (crossConfig "riscv64-linux-gnu" (Emulator "qemu-riscv64 -L /usr/riscv64-linux-gnu") Nothing))
 
-  -- Javascript
+    -- Javascript
   , addValidateRule JSBackend (validateBuilds Amd64 (Linux Debian11Js) javascriptConfig)
 
-  -- Wasm
+    -- Wasm
   , make_wasm_jobs wasm_build_config
   , modifyValidateJobs manual $
       make_wasm_jobs wasm_build_config {bignumBackend = Native}
@@ -1203,10 +1283,9 @@ cross_jobs = [
 
     wasm_build_config =
       (crossConfig "wasm32-wasi" NoEmulatorNeeded Nothing)
-        {
-          hostFullyStatic = True
-          , buildFlavour     = Release -- TODO: This needs to be validate but wasm backend doesn't pass yet
-          , textWithSIMDUTF = True
+        { hostFullyStatic = True
+        , buildFlavour    = Release -- TODO: This needs to be validate but wasm backend doesn't pass yet
+        , textWithSIMDUTF = True
         }
 
 job_groups :: [JobGroup Job]
@@ -1224,6 +1303,9 @@ job_groups =
   ++ cross_jobs
   ++ freebsd_jobs
 
+---------------------------------------------------------------------
+-- Platform mapping for GHCup metadata
+---------------------------------------------------------------------
 
 mkPlatform :: Arch -> Opsys -> String
 mkPlatform arch opsys = archName arch <> "-" <> opsysName opsys
@@ -1267,7 +1349,11 @@ platform_mapping = Map.map go combined_result
                 , "release-x86_64-windows-release"
                 ]
 
-    process sel = Map.fromListWith combine [ (uncurry mkPlatform (jobPlatform (jobInfo $ j)), j) | (sel -> Just j) <- job_groups  ]
+    process sel =
+      Map.fromListWith combine
+      [ (uncurry mkPlatform (jobPlatform (jobInfo j)), j)
+      | (sel -> Just j) <- job_groups
+      ]
 
     vs = process v
     ns = process n
@@ -1275,10 +1361,13 @@ platform_mapping = Map.map go combined_result
 
     all_platforms = Map.keysSet vs <> Map.keysSet ns <> Map.keysSet rs
 
-    combined_result = Map.fromList [ (p, StandardTriple { v = Map.lookup p vs
-                                                        , n = Map.lookup p ns
-                                                        , r = Map.lookup p rs })
-                                   | p <- S.toList all_platforms ]
+    combined_result =
+      Map.fromList
+      [ (p, StandardTriple { v = Map.lookup p vs
+                           , n = Map.lookup p ns
+                           , r = Map.lookup p rs })
+      | p <- S.toList all_platforms
+      ]
 
     combine a b
       | name a `elem` whitelist = a -- Explicitly selected
@@ -1293,6 +1382,9 @@ data BindistInfo = BindistInfo { bindistName :: String } deriving Show
 instance ToJSON BindistInfo where
   toJSON (BindistInfo n) = object [ "bindistName" A..= n ]
 
+---------------------------------------------------------------------
+-- Main entrypoint
+---------------------------------------------------------------------
 
 main :: IO ()
 main = do


=====================================
compiler/GHC.hs
=====================================
@@ -420,7 +420,6 @@ import GHC.Types.Name.Ppr
 import GHC.Types.TypeEnv
 import GHC.Types.Breakpoint
 import GHC.Types.PkgQual
-import GHC.Types.Unique.FM
 
 import GHC.Unit
 import GHC.Unit.Env as UnitEnv
@@ -705,7 +704,7 @@ setTopSessionDynFlags :: GhcMonad m => DynFlags -> m ()
 setTopSessionDynFlags dflags = do
   hsc_env <- getSession
   logger  <- getLogger
-  lookup_cache  <- liftIO $ newMVar emptyUFM
+  lookup_cache  <- liftIO $ mkInterpSymbolCache
 
   -- Interpreter
   interp <- if


=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -2,6 +2,7 @@
 {-# LANGUAGE MagicHash             #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE DataKinds             #-}
 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
 --
 --  (c) The University of Glasgow 2002-2006
@@ -12,7 +13,6 @@ module GHC.ByteCode.Linker
   ( linkBCO
   , lookupStaticPtr
   , lookupIE
-  , nameToCLabel
   , linkFail
   )
 where
@@ -26,7 +26,6 @@ import GHCi.ResolvedBCO
 
 import GHC.Builtin.PrimOps
 import GHC.Builtin.PrimOps.Ids
-import GHC.Builtin.Names
 
 import GHC.Unit.Types
 
@@ -43,8 +42,6 @@ import GHC.Types.Name.Env
 import qualified GHC.Types.Id as Id
 import GHC.Types.Unique.DFM
 
-import Language.Haskell.Syntax.Module.Name
-
 -- Standard libraries
 import Data.Array.Unboxed
 import Foreign.Ptr
@@ -92,30 +89,30 @@ lookupLiteral interp pkgs_loaded le ptr = case ptr of
 
 lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
 lookupStaticPtr interp addr_of_label_string = do
-  m <- lookupSymbol interp addr_of_label_string
+  m <- lookupSymbol interp (IFaststringSymbol addr_of_label_string)
   case m of
     Just ptr -> return ptr
     Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"
-                  (unpackFS addr_of_label_string)
+                  (ppr addr_of_label_string)
 
 lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())
 lookupIE interp pkgs_loaded ie con_nm =
   case lookupNameEnv ie con_nm of
     Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
     Nothing -> do -- try looking up in the object files.
-       let sym_to_find1 = nameToCLabel con_nm "con_info"
-       m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info"
+       let sym_to_find1 = IConInfoSymbol con_nm
+       m <- lookupHsSymbol interp pkgs_loaded sym_to_find1
        case m of
           Just addr -> return addr
           Nothing
              -> do -- perhaps a nullary constructor?
-                   let sym_to_find2 = nameToCLabel con_nm "static_info"
-                   n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info"
+                   let sym_to_find2 = IStaticInfoSymbol con_nm
+                   n <- lookupHsSymbol interp pkgs_loaded sym_to_find2
                    case n of
                       Just addr -> return addr
                       Nothing   -> linkFail "GHC.ByteCode.Linker.lookupIE"
-                                      (unpackFS sym_to_find1 ++ " or " ++
-                                       unpackFS sym_to_find2)
+                                      (ppr sym_to_find1 <> " or " <>
+                                       ppr sym_to_find2)
 
 -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
 lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())
@@ -123,21 +120,21 @@ lookupAddr interp pkgs_loaded ae addr_nm = do
   case lookupNameEnv ae addr_nm of
     Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)
     Nothing -> do -- try looking up in the object files.
-      let sym_to_find = nameToCLabel addr_nm "bytes"
+      let sym_to_find = IBytesSymbol addr_nm
                           -- see Note [Bytes label] in GHC.Cmm.CLabel
-      m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes"
+      m <- lookupHsSymbol interp pkgs_loaded sym_to_find
       case m of
         Just ptr -> return ptr
         Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr"
-                     (unpackFS sym_to_find)
+                     (ppr sym_to_find)
 
 lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())
 lookupPrimOp interp pkgs_loaded primop = do
   let sym_to_find = primopToCLabel primop "closure"
-  m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure"
+  m <- lookupHsSymbol interp pkgs_loaded (IClosureSymbol (Id.idName $ primOpId primop))
   case m of
     Just p -> return (toRemotePtr p)
-    Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find
+    Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" (text sym_to_find)
 
 resolvePtr
   :: Interp
@@ -157,11 +154,11 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
     | otherwise
     -> assertPpr (isExternalName nm) (ppr nm) $
        do
-          let sym_to_find = nameToCLabel nm "closure"
-          m <- lookupHsSymbol interp pkgs_loaded nm "closure"
+          let sym_to_find = IClosureSymbol nm
+          m <- lookupHsSymbol interp pkgs_loaded sym_to_find
           case m of
             Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
-            Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
+            Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (ppr sym_to_find)
 
   BCOPtrPrimOp op
     -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op
@@ -176,11 +173,10 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
 -- loaded units.
 --
 -- See Note [Looking up symbols in the relevant objects].
-lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
-lookupHsSymbol interp pkgs_loaded nm sym_suffix = do
-  massertPpr (isExternalName nm) (ppr nm)
-  let sym_to_find = nameToCLabel nm sym_suffix
-      pkg_id = moduleUnitId $ nameModule nm
+lookupHsSymbol :: Interp -> PkgsLoaded -> InterpSymbol (Suffix s) -> IO (Maybe (Ptr ()))
+lookupHsSymbol interp pkgs_loaded sym_to_find = do
+  massertPpr (isExternalName (interpSymbolName sym_to_find)) (ppr sym_to_find)
+  let pkg_id = moduleUnitId $ nameModule (interpSymbolName sym_to_find)
       loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id
 
       go (dll:dlls) = do
@@ -194,12 +190,12 @@ lookupHsSymbol interp pkgs_loaded nm sym_suffix = do
 
   go loaded_dlls
 
-linkFail :: String -> String -> IO a
+linkFail :: String -> SDoc -> IO a
 linkFail who what
    = throwGhcExceptionIO (ProgramError $
         unlines [ "",who
                 , "During interactive linking, GHCi couldn't find the following symbol:"
-                , ' ' : ' ' : what
+                , ' ' : ' ' : showSDocUnsafe what
                 , "This may be due to you not asking GHCi to load extra object files,"
                 , "archives or DLLs needed by your current session.  Restart GHCi, specifying"
                 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
@@ -210,28 +206,8 @@ linkFail who what
                 ])
 
 
-nameToCLabel :: Name -> String -> FastString
-nameToCLabel n suffix = mkFastStringByteString label
-  where
-    encodeZ = fastZStringToByteString . zEncodeFS
-    (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of
-        -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers
-        -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.
-        mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS
-        mod -> mod
-    packagePart = encodeZ (unitFS pkgKey)
-    modulePart  = encodeZ (moduleNameFS modName)
-    occPart     = encodeZ $ occNameMangledFS (nameOccName n)
-
-    label = mconcat $
-        [ packagePart `mappend` "_" | pkgKey /= mainUnit ]
-        ++
-        [modulePart
-        , "_"
-        , occPart
-        , "_"
-        , fromString suffix
-        ]
+
+
 
 
 -- See Note [Primop wrappers] in GHC.Builtin.PrimOps


=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2901,7 +2901,7 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do
     jsLinkObject logger tmpfs tmp_dir js_config unit_env inst out_obj roots
 
   -- look up "id_sym" closure and create a StablePtr (HValue) from it
-  href <- lookupClosure interp (unpackFS id_sym) >>= \case
+  href <- lookupClosure interp (IFaststringSymbol id_sym) >>= \case
     Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym)
     Just r  -> pure r
 


=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -217,12 +217,12 @@ loadName interp hsc_env name = do
     case lookupNameEnv (closure_env (linker_env pls)) name of
       Just (_,aa) -> return (pls,(aa, links, pkgs))
       Nothing     -> assertPpr (isExternalName name) (ppr name) $
-                     do let sym_to_find = nameToCLabel name "closure"
-                        m <- lookupClosure interp (unpackFS sym_to_find)
+                     do let sym_to_find = IClosureSymbol name
+                        m <- lookupClosure interp sym_to_find
                         r <- case m of
                           Just hvref -> mkFinalizedHValue interp hvref
                           Nothing -> linkFail "GHC.Linker.Loader.loadName"
-                                       (unpackFS sym_to_find)
+                                       (ppr sym_to_find)
                         return (pls,(r, links, pkgs))
 
 loadDependencies
@@ -909,7 +909,7 @@ dynLoadObjs interp hsc_env pls at LoaderState{..} objs = do
     m <- loadDLL interp soFile
     case m of
       Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
-      Left err -> linkFail msg err
+      Left err -> linkFail msg (text err)
   where
     msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed"
 


=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 -- | Interacting with the iserv interpreter, whether it is running on an
 -- external process or in the current process.
@@ -83,7 +84,6 @@ import GHC.Data.Maybe
 import GHC.Data.FastString
 
 import GHC.Types.SrcLoc
-import GHC.Types.Unique.FM
 import GHC.Types.Basic
 
 import GHC.Utils.Panic
@@ -116,6 +116,12 @@ import GHC.Stack.CCS (CostCentre,CostCentreStack)
 import System.Directory
 import System.Process
 
+import GHC.Builtin.Names
+import GHC.Types.Name
+
+-- Standard libraries
+import GHC.Exts
+
 {- Note [Remote GHCi]
    ~~~~~~~~~~~~~~~~~~
 When the flag -fexternal-interpreter is given to GHC, interpreted code
@@ -457,38 +463,65 @@ handleSeqHValueStatus interp unit_env eval_status =
 initObjLinker :: Interp -> IO ()
 initObjLinker interp = interpCmd interp InitLinker
 
-lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ()))
 lookupSymbol interp str = withSymbolCache interp str $
   case interpInstance interp of
 #if defined(HAVE_INTERNAL_INTERPRETER)
-    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
+    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
 #endif
     ExternalInterp ext -> case ext of
       ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
         uninterruptibleMask_ $
-          sendMessage inst (LookupSymbol (unpackFS str))
+          sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
       ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
       ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do
         uninterruptibleMask_ $
-          sendMessage inst (LookupSymbol (unpackFS str))
+          sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
 
-lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ()))
 lookupSymbolInDLL interp dll str = withSymbolCache interp str $
   case interpInstance interp of
 #if defined(HAVE_INTERNAL_INTERPRETER)
-    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str))
+    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
 #endif
     ExternalInterp ext -> case ext of
       ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
         uninterruptibleMask_ $
-          sendMessage inst (LookupSymbolInDLL dll (unpackFS str))
+          sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
       ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
       -- wasm dyld doesn't track which symbol comes from which .so
       ExtWasm {} -> lookupSymbol interp str
 
-lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
+interpSymbolToCLabel :: forall s . InterpSymbol s -> FastString
+interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is ->
+  let
+    n = interpSymbolName is
+    suffix = interpSymbolSuffix is
+
+    encodeZ = fastZStringToByteString . zEncodeFS
+    (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of
+        -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers
+        -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.
+        mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS
+        mod -> mod
+    packagePart = encodeZ (unitFS pkgKey)
+    modulePart  = encodeZ (moduleNameFS modName)
+    occPart     = encodeZ $ occNameMangledFS (nameOccName n)
+
+    label = mconcat $
+        [ packagePart `mappend` "_" | pkgKey /= mainUnit ]
+        ++
+        [modulePart
+        , "_"
+        , occPart
+        , "_"
+        , fromString suffix
+        ]
+  in mkFastStringByteString label
+
+lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef)
 lookupClosure interp str =
-  interpCmd interp (LookupClosure str)
+  interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str)))
 
 -- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'
 -- which maps symbols to the address where they are loaded.
@@ -496,7 +529,7 @@ lookupClosure interp str =
 -- a miss we run the action which determines the symbol's address and populate
 -- the cache with the answer.
 withSymbolCache :: Interp
-                -> FastString
+                -> InterpSymbol s
                 -- ^ The symbol we are looking up in the cache
                 -> IO (Maybe (Ptr ()))
                 -- ^ An action which determines the address of the symbol we
@@ -513,21 +546,19 @@ withSymbolCache interp str determine_addr = do
   -- The analysis in #23415 further showed this cache should also benefit the
   -- internal interpreter's loading times, and needn't be used by the external
   -- interpreter only.
-  cache <- readMVar (interpLookupSymbolCache interp)
-  case lookupUFM cache str of
-    Just p -> return (Just p)
+  cached_val <- lookupInterpSymbolCache str (interpSymbolCache interp)
+  case cached_val of
+    Just {} -> return cached_val
     Nothing -> do
-
       maddr <- determine_addr
       case maddr of
         Nothing -> return Nothing
         Just p -> do
-          let upd_cache cache' = addToUFM cache' str p
-          modifyMVar_ (interpLookupSymbolCache interp) (pure . upd_cache)
-          return (Just p)
+          updateInterpSymbolCache str (interpSymbolCache interp) p
+          return maddr
 
 purgeLookupSymbolCache :: Interp -> IO ()
-purgeLookupSymbolCache interp = modifyMVar_ (interpLookupSymbolCache interp) (const (pure emptyUFM))
+purgeLookupSymbolCache interp = purgeInterpSymbolCache (interpSymbolCache interp)
 
 -- | loadDLL loads a dynamic library using the OS's native linker
 -- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either


=====================================
compiler/GHC/Runtime/Interpreter/Types.hs
=====================================
@@ -1,4 +1,6 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RecordWildCards #-}
 
 -- | Types used by the runtime interpreter
 module GHC.Runtime.Interpreter.Types
@@ -10,6 +12,20 @@ module GHC.Runtime.Interpreter.Types
    , ExtInterpInstance (..)
    , ExtInterpState (..)
    , InterpStatus(..)
+   -- * InterpSymbolCache
+   , InterpSymbolCache(..)
+   , mkInterpSymbolCache
+   , lookupInterpSymbolCache
+   , updateInterpSymbolCache
+   , purgeInterpSymbolCache
+   , InterpSymbol(..)
+   , SuffixOrInterpreted(..)
+   , interpSymbolName
+   , interpSymbolSuffix
+   , eliminateInterpSymbol
+   , interpretedInterpSymbol
+
+
    -- * IServ
    , IServ
    , IServConfig(..)
@@ -30,9 +46,6 @@ import GHC.Linker.Types
 
 import GHCi.RemoteTypes
 import GHCi.Message         ( Pipe )
-import GHC.Types.Unique.FM
-import GHC.Data.FastString ( FastString )
-import Foreign
 
 import GHC.Platform
 import GHC.Utils.TmpFs
@@ -42,6 +55,7 @@ import GHC.Unit.State
 import GHC.Unit.Types
 import GHC.StgToJS.Types
 import GHC.StgToJS.Linker.Types
+import GHC.Runtime.Interpreter.Types.SymbolCache
 
 import Control.Concurrent
 import System.Process   ( ProcessHandle, CreateProcess )
@@ -56,7 +70,7 @@ data Interp = Interp
   , interpLoader   :: !Loader
       -- ^ Interpreter loader
 
-  , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))
+  , interpSymbolCache :: !InterpSymbolCache
       -- ^ LookupSymbol cache
   }
 


=====================================
compiler/GHC/Runtime/Interpreter/Types/SymbolCache.hs
=====================================
@@ -0,0 +1,142 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | The SymbolCache is used to cache lookups for specific symbols when using
+-- the interpreter.
+module GHC.Runtime.Interpreter.Types.SymbolCache (
+     InterpSymbolCache(..)
+   , mkInterpSymbolCache
+   , lookupInterpSymbolCache
+   , updateInterpSymbolCache
+   , purgeInterpSymbolCache
+   , InterpSymbol(..)
+   , SuffixOrInterpreted(..)
+   , interpSymbolName
+   , interpSymbolSuffix
+   , eliminateInterpSymbol
+   , interpretedInterpSymbol
+   ) where
+
+import GHC.Prelude
+
+import GHC.Types.Unique.FM
+import GHC.Types.Name
+import GHC.Data.FastString
+import Foreign
+
+import Control.Concurrent
+import GHC.Utils.Outputable
+import GHC.TypeLits
+
+
+-- The symbols records the suffix which each cache deals with.
+newtype SymbolCache (s :: Symbol) = SymbolCache { _getSymbolCache :: UniqFM Name (Ptr ()) }
+
+-- Each cache is keyed by Name, there is one cache for each type of symbol we will
+-- potentially lookup. The caches are keyed by 'Name' so that it is not necessary to consult
+-- a complicated `FastString` each time.
+data InterpSymbolCache = InterpSymbolCache {
+        interpClosureCache :: MVar (SymbolCache "closure")
+      , interpConInfoCache :: MVar (SymbolCache "con_info")
+      , interpStaticInfoCache :: MVar (SymbolCache "static_info")
+      , interpBytesCache   :: MVar (SymbolCache "bytes")
+      , interpFaststringCache   :: MVar (UniqFM FastString (Ptr ()))
+      }
+
+data SuffixOrInterpreted = Suffix Symbol | Interpreted
+
+data InterpSymbol (s :: SuffixOrInterpreted) where
+  IClosureSymbol :: Name -> InterpSymbol (Suffix "closure")
+  IConInfoSymbol :: Name -> InterpSymbol (Suffix "con_info")
+  IStaticInfoSymbol :: Name -> InterpSymbol (Suffix "static_info")
+  IBytesSymbol   :: Name -> InterpSymbol (Suffix "bytes")
+  IFaststringSymbol   :: FastString -> InterpSymbol Interpreted
+
+instance Outputable (InterpSymbol s) where
+  ppr s = eliminateInterpSymbol s
+            (\(IFaststringSymbol s) -> text "interpreted:" <> ppr s)
+            (\s -> text (interpSymbolSuffix s) <> colon <> ppr (interpSymbolName s))
+
+eliminateInterpSymbol :: InterpSymbol s -> (InterpSymbol Interpreted -> r)
+                                        -> (forall x . InterpSymbol (Suffix x) -> r)
+                                        -> r
+eliminateInterpSymbol s k1 k2 =
+  case s of
+    IFaststringSymbol {} -> k1 s
+    IBytesSymbol {}      -> k2 s
+    IStaticInfoSymbol {} -> k2 s
+    IConInfoSymbol {}    -> k2 s
+    IClosureSymbol {}    -> k2 s
+
+
+interpSymbolName :: InterpSymbol (Suffix s) -> Name
+interpSymbolName (IClosureSymbol n) = n
+interpSymbolName (IConInfoSymbol n) = n
+interpSymbolName (IStaticInfoSymbol n) = n
+interpSymbolName (IBytesSymbol n) = n
+
+interpretedInterpSymbol :: InterpSymbol Interpreted -> FastString
+interpretedInterpSymbol (IFaststringSymbol s) = s
+
+interpSymbolSuffix :: InterpSymbol (Suffix s) -> String
+interpSymbolSuffix (IClosureSymbol {}) = "closure"
+interpSymbolSuffix (IConInfoSymbol {}) = "con_info"
+interpSymbolSuffix (IStaticInfoSymbol {}) = "static_info"
+interpSymbolSuffix (IBytesSymbol {})      = "bytes"
+
+emptySymbolCache :: SymbolCache s
+emptySymbolCache = SymbolCache emptyUFM
+
+lookupSymbolCache :: InterpSymbol (Suffix s) -> SymbolCache s -> Maybe (Ptr ())
+lookupSymbolCache s (SymbolCache cache) = lookupUFM cache (interpSymbolName s)
+
+insertSymbolCache :: InterpSymbol (Suffix s) -> Ptr () -> SymbolCache s -> SymbolCache s
+insertSymbolCache s v (SymbolCache cache) = SymbolCache (addToUFM cache (interpSymbolName s) v)
+
+lookupInterpSymbolCache :: InterpSymbol s -> InterpSymbolCache -> IO (Maybe (Ptr ()))
+lookupInterpSymbolCache = withInterpSymbolCache
+                            (\(IFaststringSymbol f) mvar_var -> (\cache -> lookupUFM cache f) <$> readMVar mvar_var)
+                            (\s mvar_var -> lookupSymbolCache s <$> readMVar mvar_var)
+
+
+updateInterpSymbolCache :: InterpSymbol s
+                                 -> InterpSymbolCache -> Ptr () -> IO ()
+updateInterpSymbolCache = withInterpSymbolCache
+                            (\(IFaststringSymbol f) mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ addToUFM cache f v))
+                            (\s mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ insertSymbolCache s v cache))
+
+withInterpSymbolCache ::
+                (InterpSymbol Interpreted -> MVar (UniqFM FastString (Ptr ())) -> r)
+                -> (forall x . InterpSymbol (Suffix x) -> MVar (SymbolCache x) -> r)
+                -> InterpSymbol s
+                -> InterpSymbolCache
+                -> r
+withInterpSymbolCache k1 k2 key InterpSymbolCache{..} =
+  case key of
+    IClosureSymbol {} -> k2 key interpClosureCache
+    IConInfoSymbol {} -> k2 key interpConInfoCache
+    IStaticInfoSymbol {} -> k2 key interpStaticInfoCache
+    IBytesSymbol {} -> k2 key interpBytesCache
+    IFaststringSymbol {} -> k1 key interpFaststringCache
+
+-- | Clear all symbol caches.
+purgeInterpSymbolCache :: InterpSymbolCache -> IO ()
+purgeInterpSymbolCache (InterpSymbolCache a b c d e) = do
+  modifyMVar_ a (\_ ->  do
+    modifyMVar_ b (\_ -> do
+      modifyMVar_ c (\_ -> do
+        modifyMVar_ d (\_ -> do
+          modifyMVar_ e (\_ -> pure emptyUFM)
+          pure emptySymbolCache)
+        pure emptySymbolCache)
+      pure emptySymbolCache)
+    pure emptySymbolCache)
+
+mkInterpSymbolCache :: IO InterpSymbolCache
+mkInterpSymbolCache = do
+  InterpSymbolCache <$> newMVar emptySymbolCache
+                    <*> newMVar emptySymbolCache
+                    <*> newMVar emptySymbolCache
+                    <*> newMVar emptySymbolCache
+                    <*> newMVar emptyUFM


=====================================
compiler/ghc.cabal.in
=====================================
@@ -699,6 +699,7 @@ Library
         GHC.Runtime.Interpreter.JS
         GHC.Runtime.Interpreter.Process
         GHC.Runtime.Interpreter.Types
+        GHC.Runtime.Interpreter.Types.SymbolCache
         GHC.Runtime.Interpreter.Wasm
         GHC.Runtime.Loader
         GHC.Runtime.Utils


=====================================
libraries/base/changelog.md
=====================================
@@ -10,6 +10,13 @@
   * `Data.List.NonEmpty` functions now have the same laziness as their `Data.List` counterparts (i.e. make them more strict than they currently are) ([CLC proposal #107](https://github.com/haskell/core-libraries-committee/issues/107))
   * `instance Functor NonEmpty` is now specified using `map` (rather than duplicating code). ([CLC proposal #300](https://github.com/haskell/core-libraries-committee/issues/300))
   * The `Data.Enum.enumerate` function was introduced ([CLC #306](https://github.com/haskell/core-libraries-committee/issues/306))
+  * Worker threads used by various `base` facilities are now labelled with descriptive thread labels ([CLC proposal #305](https://github.com/haskell/core-libraries-committee/issues/305), [GHC #25452](https://gitlab.haskell.org/ghc/ghc/-/issues/25452)). Specifically, these include:
+    * `Control.Concurrent.threadWaitRead`
+    * `Control.Concurrent.threadWaitWrite`
+    * `Control.Concurrent.threadWaitReadSTM`
+    * `Control.Concurrent.threadWaitWriteSTM`
+    * `System.Timeout.timeout`
+    * `GHC.Conc.Signal.runHandlers`
 
 ## 4.21.0.0 *TBA*
   * Change `SrcLoc` to be a strict and unboxed (finishing [CLC proposal #55](https://github.com/haskell/core-libraries-committee/issues/55))


=====================================
libraries/base/src/Control/Concurrent.hs
=====================================
@@ -265,7 +265,7 @@ threadWaitRead fd
   -- fdReady does the right thing, but we have to call it in a
   -- separate thread, otherwise threadWaitRead won't be interruptible,
   -- and this only works with -threaded.
-  | threaded  = withThread (waitFd fd False)
+  | threaded  = withThread "threadWaitRead worker" (waitFd fd False)
   | otherwise = case fd of
                   0 -> do _ <- hWaitForInput stdin (-1)
                           return ()
@@ -286,7 +286,7 @@ threadWaitRead fd
 threadWaitWrite :: Fd -> IO ()
 threadWaitWrite fd
 #if defined(mingw32_HOST_OS)
-  | threaded  = withThread (waitFd fd True)
+  | threaded  = withThread "threadWaitWrite worker" (waitFd fd True)
   | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows"
 #else
   = Conc.threadWaitWrite fd
@@ -302,8 +302,11 @@ threadWaitReadSTM :: Fd -> IO (STM (), IO ())
 threadWaitReadSTM fd
 #if defined(mingw32_HOST_OS)
   | threaded = do v <- newTVarIO Nothing
-                  mask_ $ void $ forkIO $ do result <- try (waitFd fd False)
-                                             atomically (writeTVar v $ Just result)
+                  mask_ $ void $ forkIO $ do
+                    tid <- myThreadId
+                    labelThread tid "threadWaitReadSTM worker"
+                    result <- try (waitFd fd False)
+                    atomically (writeTVar v $ Just result)
                   let waitAction = do result <- readTVar v
                                       case result of
                                         Nothing         -> retry
@@ -326,8 +329,11 @@ threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
 threadWaitWriteSTM fd
 #if defined(mingw32_HOST_OS)
   | threaded = do v <- newTVarIO Nothing
-                  mask_ $ void $ forkIO $ do result <- try (waitFd fd True)
-                                             atomically (writeTVar v $ Just result)
+                  mask_ $ void $ forkIO $ do
+                    tid <- myThreadId
+                    labelThread tid "threadWaitWriteSTM worker"
+                    result <- try (waitFd fd True)
+                    atomically (writeTVar v $ Just result)
                   let waitAction = do result <- readTVar v
                                       case result of
                                         Nothing         -> retry
@@ -343,10 +349,14 @@ threadWaitWriteSTM fd
 #if defined(mingw32_HOST_OS)
 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
 
-withThread :: IO a -> IO a
-withThread io = do
+withThread :: String -> IO a -> IO a
+withThread label io = do
   m <- newEmptyMVar
-  _ <- mask_ $ forkIO $ try io >>= putMVar m
+  _ <- mask_ $ forkIO $ do
+    tid <- myThreadId
+    labelThread tid label
+    result <- try io
+    putMVar m result
   x <- takeMVar m
   case x of
     Right a -> return a


=====================================
libraries/base/src/System/Timeout.hs
=====================================
@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 
 -------------------------------------------------------------------------------
 -- |
@@ -29,6 +29,7 @@ import GHC.Internal.Control.Exception   (Exception(..), handleJust, bracket,
                             asyncExceptionToException,
                             asyncExceptionFromException)
 import GHC.Internal.Data.Unique         (Unique, newUnique)
+import GHC.Conc (labelThread)
 import Prelude
 
 -- $setup
@@ -119,7 +120,9 @@ timeout n f
         let handleTimeout = do
                 v <- isEmptyMVar lock
                 when v $ void $ forkIOWithUnmask $ \unmask -> unmask $ do
-                    v2 <- tryPutMVar lock =<< myThreadId
+                    tid <- myThreadId
+                    labelThread tid "timeout worker"
+                    v2 <- tryPutMVar lock tid
                     when v2 $ throwTo pid ex
             cleanupTimeout key = uninterruptibleMask_ $ do
                 v <- tryPutMVar lock undefined
@@ -136,7 +139,9 @@ timeout n f
         ex  <- fmap Timeout newUnique
         handleJust (\e -> if e == ex then Just () else Nothing)
                    (\_ -> return Nothing)
-                   (bracket (forkIOWithUnmask $ \unmask ->
+                   (bracket (forkIOWithUnmask $ \unmask -> do
+                                 tid <- myThreadId
+                                 labelThread tid "timeout worker"
                                  unmask $ threadDelay n >> throwTo pid ex)
                             (uninterruptibleMask_ . killThread)
                             (\_ -> fmap Just f))


=====================================
libraries/ghc-internal/src/GHC/Internal/Conc/Signal.hs
=====================================
@@ -19,7 +19,7 @@ import GHC.Internal.Foreign.Ptr (Ptr, castPtr)
 import GHC.Internal.Foreign.Marshal.Alloc (finalizerFree)
 import GHC.Internal.Arr (inRange)
 import GHC.Internal.Base
-import GHC.Internal.Conc.Sync (forkIO)
+import GHC.Internal.Conc.Sync (myThreadId, labelThread, forkIO)
 import GHC.Internal.IO (mask_, unsafePerformIO)
 import GHC.Internal.IOArray (IOArray, boundsIOArray, newIOArray,
                     unsafeReadIOArray, unsafeWriteIOArray)
@@ -69,7 +69,10 @@ runHandlers p_info sig = do
       else do handler <- unsafeReadIOArray arr int
               case handler of
                 Nothing -> return ()
-                Just (f,_)  -> do _ <- forkIO (f p_info)
+                Just (f,_)  -> do _ <- forkIO $ do
+                                    tid <- myThreadId
+                                    labelThread tid "signal handler"
+                                    f p_info
                                   return ()
 
 -- It is our responsibility to free the memory buffer, so we create a


=====================================
libraries/ghc-internal/src/GHC/Internal/Event/Windows/ConsoleEvent.hsc
=====================================
@@ -53,7 +53,10 @@ start_console_handler :: Word32 -> IO ()
 start_console_handler r =
   case toWin32ConsoleEvent r of
     Just x  -> withMVar win32ConsoleHandler $ \handler -> do
-                 _ <- forkIO (handler x)
+                 _ <- forkIO $ do
+                     tid <- myThreadId
+                     labelThread tid "console event handler"
+                     handler x
                  return ()
     Nothing -> return ()
 


=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -226,7 +226,10 @@ sandboxIO opts io = do
     let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io
     if useSandboxThread opts
        then do
-         tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar
+         tid <- forkIO $ do
+           tid <- myThreadId
+           labelThread tid "GHCi sandbox"
+           unsafeUnmask runIt >>= putMVar statusMVar
                                 -- empty: can't block
          redirectInterrupts tid $ unsafeUnmask $ takeMVar statusMVar
        else


=====================================
rts/Interpreter.c
=====================================
@@ -182,6 +182,8 @@ int rts_stop_on_exception = 0;
 
 #if defined(INTERP_STATS)
 
+#define N_CODES 128
+
 /* Hacky stats, for tuning the interpreter ... */
 int it_unknown_entries[N_CLOSURE_TYPES];
 int it_total_unknown_entries;
@@ -195,8 +197,8 @@ int it_slides;
 int it_insns;
 int it_BCO_entries;
 
-int it_ofreq[27];
-int it_oofreq[27][27];
+int it_ofreq[N_CODES];
+int it_oofreq[N_CODES][N_CODES];
 int it_lastopc;
 
 
@@ -210,9 +212,9 @@ void interp_startup ( void )
    for (i = 0; i < N_CLOSURE_TYPES; i++)
       it_unknown_entries[i] = 0;
    it_slides = it_insns = it_BCO_entries = 0;
-   for (i = 0; i < 27; i++) it_ofreq[i] = 0;
-   for (i = 0; i < 27; i++)
-     for (j = 0; j < 27; j++)
+   for (i = 0; i < N_CODES; i++) it_ofreq[i] = 0;
+   for (i = 0; i < N_CODES; i++)
+     for (j = 0; j < N_CODES; j++)
         it_oofreq[i][j] = 0;
    it_lastopc = 0;
 }
@@ -234,14 +236,14 @@ void interp_shutdown ( void )
    }
    debugBelch("%d insns, %d slides, %d BCO_entries\n",
                    it_insns, it_slides, it_BCO_entries);
-   for (i = 0; i < 27; i++)
+   for (i = 0; i < N_CODES; i++)
       debugBelch("opcode %2d got %d\n", i, it_ofreq[i] );
 
    for (k = 1; k < 20; k++) {
       o_max = 0;
       i_max = j_max = 0;
-      for (i = 0; i < 27; i++) {
-         for (j = 0; j < 27; j++) {
+      for (i = 0; i < N_CODES; i++) {
+         for (j = 0; j < N_CODES; j++) {
             if (it_oofreq[i][j] > o_max) {
                o_max = it_oofreq[i][j];
                i_max = i; j_max = j;
@@ -259,6 +261,12 @@ void interp_shutdown ( void )
 
 #else // !INTERP_STATS
 
+void interp_startup( void ){
+}
+
+void interp_shutdown( void ){
+}
+
 #define INTERP_TICK(n) /* nothing */
 
 #endif
@@ -419,7 +427,7 @@ eval:
 
 eval_obj:
     obj = UNTAG_CLOSURE(tagged_obj);
-    INTERP_TICK(it_total_evals);
+    INTERP_TICK(it_total_entries);
 
     IF_DEBUG(interpreter,
              debugBelch(
@@ -1098,7 +1106,7 @@ run_BCO:
         INTERP_TICK(it_insns);
 
 #if defined(INTERP_STATS)
-        ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
+        ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < N_CODES );
         it_ofreq[ (int)instrs[bciPtr] ] ++;
         it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
         it_lastopc = (int)instrs[bciPtr];


=====================================
rts/Interpreter.h
=====================================
@@ -9,3 +9,5 @@
 #pragma once
 
 RTS_PRIVATE Capability *interpretBCO (Capability* cap);
+void interp_startup ( void );
+void interp_shutdown ( void );


=====================================
rts/RtsMain.c
=====================================
@@ -17,6 +17,7 @@
 #include "Prelude.h"
 #include "Task.h"
 #include "Excn.h"
+#include "Interpreter.h"
 
 #if defined(DEBUG)
 # include "Printer.h"   /* for printing        */
@@ -56,6 +57,8 @@ int hs_main ( int argc, char *argv[],       // program args
 
     hs_init_ghc(&argc, &argv, rts_config);
 
+    interp_startup();
+
     BEGIN_WINDOWS_VEH_HANDLER
 
     // kick off the computation by creating the main thread with a pointer
@@ -96,6 +99,8 @@ int hs_main ( int argc, char *argv[],       // program args
 
     END_WINDOWS_VEH_HANDLER
 
+    interp_shutdown();
+
     shutdownHaskellAndExit(exit_status, 0 /* !fastExit */);
     // No code beyond this point. Dead code elimination will remove it
 }


=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -10619,7 +10619,7 @@ module System.Posix.Types where
 
 
 module System.Timeout where
-  -- Safety: Safe
+  -- Safety: Trustworthy
   type Timeout :: *
   newtype Timeout = ...
   timeout :: forall a. GHC.Internal.Types.Int -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe a)
@@ -11736,7 +11736,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Int
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance forall a. GHC.Internal.Classes.Ord a => GHC.Internal.Classes.Ord (GHC.Internal.Base.NonEmpty a) -- Defined in ‘GHC.Internal.Base’
@@ -12349,7 +12349,7 @@ instance GHC.Internal.Exception.Type.Exception GHC.Internal.Control.Exception.Ba
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.Data.Dynamic.Dynamic -- Defined in ‘GHC.Internal.Data.Dynamic’
 instance [safe] GHC.Internal.Exception.Type.Exception ghc-internal-9.1300.0:GHC.Internal.IO.Handle.Lock.Common.FileLockingNotSupported -- Defined in ‘ghc-internal-9.1300.0:GHC.Internal.IO.Handle.Lock.Common’
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.IOPort.IOPortException -- Defined in ‘GHC.Internal.IOPort’
-instance [safe] GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance forall a k (b :: k). GHC.Internal.Float.Floating a => GHC.Internal.Float.Floating (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’
 instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Float.Floating (Data.Complex.Complex a) -- Defined in ‘Data.Complex’
 instance forall k1 k2 (f :: k1 -> *) (g :: k2 -> k1) (a :: k2). GHC.Internal.Float.Floating (f (g a)) => GHC.Internal.Float.Floating (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’
@@ -13204,7 +13204,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Show.Show (GHC.Inte
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Show.Show (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance [safe] forall a b. GHC.Internal.Show.Show (a -> b) -- Defined in ‘Text.Show.Functions’


=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -13664,7 +13664,7 @@ module System.Posix.Types where
 
 
 module System.Timeout where
-  -- Safety: Safe
+  -- Safety: Trustworthy
   type Timeout :: *
   newtype Timeout = ...
   timeout :: forall a. GHC.Internal.Types.Int -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe a)
@@ -14770,7 +14770,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Int
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance forall a. GHC.Internal.Classes.Ord a => GHC.Internal.Classes.Ord (GHC.Internal.Base.NonEmpty a) -- Defined in ‘GHC.Internal.Base’
@@ -15385,7 +15385,7 @@ instance [safe] GHC.Internal.Exception.Type.Exception ghc-internal-9.1300.0:GHC.
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.IOPort.IOPortException -- Defined in ‘GHC.Internal.IOPort’
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.JS.Prim.JSException -- Defined in ‘GHC.Internal.JS.Prim’
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.JS.Prim.WouldBlockException -- Defined in ‘GHC.Internal.JS.Prim’
-instance [safe] GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance forall a k (b :: k). GHC.Internal.Float.Floating a => GHC.Internal.Float.Floating (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’
 instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Float.Floating (Data.Complex.Complex a) -- Defined in ‘Data.Complex’
 instance forall k1 k2 (f :: k1 -> *) (g :: k2 -> k1) (a :: k2). GHC.Internal.Float.Floating (f (g a)) => GHC.Internal.Float.Floating (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’
@@ -16235,7 +16235,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Show.Show (GHC.Inte
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Show.Show (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance [safe] forall a b. GHC.Internal.Show.Show (a -> b) -- Defined in ‘Text.Show.Functions’


=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -10881,7 +10881,7 @@ module System.Posix.Types where
 
 
 module System.Timeout where
-  -- Safety: Safe
+  -- Safety: Trustworthy
   type Timeout :: *
   newtype Timeout = ...
   timeout :: forall a. GHC.Internal.Types.Int -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe a)
@@ -11992,7 +11992,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Int
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance forall a. GHC.Internal.Classes.Ord a => GHC.Internal.Classes.Ord (GHC.Internal.Base.NonEmpty a) -- Defined in ‘GHC.Internal.Base’
@@ -12608,7 +12608,7 @@ instance GHC.Internal.Exception.Type.Exception GHC.Internal.Control.Exception.Ba
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.Data.Dynamic.Dynamic -- Defined in ‘GHC.Internal.Data.Dynamic’
 instance [safe] GHC.Internal.Exception.Type.Exception ghc-internal-9.1300.0:GHC.Internal.IO.Handle.Lock.Common.FileLockingNotSupported -- Defined in ‘ghc-internal-9.1300.0:GHC.Internal.IO.Handle.Lock.Common’
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.IOPort.IOPortException -- Defined in ‘GHC.Internal.IOPort’
-instance [safe] GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance forall a k (b :: k). GHC.Internal.Float.Floating a => GHC.Internal.Float.Floating (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’
 instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Float.Floating (Data.Complex.Complex a) -- Defined in ‘Data.Complex’
 instance forall k1 k2 (f :: k1 -> *) (g :: k2 -> k1) (a :: k2). GHC.Internal.Float.Floating (f (g a)) => GHC.Internal.Float.Floating (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’
@@ -13476,7 +13476,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Show.Show (GHC.Inte
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Show.Show (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance [safe] forall a b. GHC.Internal.Show.Show (a -> b) -- Defined in ‘Text.Show.Functions’


=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -10619,7 +10619,7 @@ module System.Posix.Types where
 
 
 module System.Timeout where
-  -- Safety: Safe
+  -- Safety: Trustworthy
   type Timeout :: *
   newtype Timeout = ...
   timeout :: forall a. GHC.Internal.Types.Int -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe a)
@@ -11736,7 +11736,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Int
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance forall a. GHC.Internal.Classes.Ord a => GHC.Internal.Classes.Ord (GHC.Internal.Base.NonEmpty a) -- Defined in ‘GHC.Internal.Base’
@@ -12349,7 +12349,7 @@ instance GHC.Internal.Exception.Type.Exception GHC.Internal.Control.Exception.Ba
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.Data.Dynamic.Dynamic -- Defined in ‘GHC.Internal.Data.Dynamic’
 instance [safe] GHC.Internal.Exception.Type.Exception ghc-internal-9.1300.0:GHC.Internal.IO.Handle.Lock.Common.FileLockingNotSupported -- Defined in ‘ghc-internal-9.1300.0:GHC.Internal.IO.Handle.Lock.Common’
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.IOPort.IOPortException -- Defined in ‘GHC.Internal.IOPort’
-instance [safe] GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance forall a k (b :: k). GHC.Internal.Float.Floating a => GHC.Internal.Float.Floating (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’
 instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Float.Floating (Data.Complex.Complex a) -- Defined in ‘Data.Complex’
 instance forall k1 k2 (f :: k1 -> *) (g :: k2 -> k1) (a :: k2). GHC.Internal.Float.Floating (f (g a)) => GHC.Internal.Float.Floating (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’
@@ -13204,7 +13204,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Show.Show (GHC.Inte
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Show.Show (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance [safe] forall a b. GHC.Internal.Show.Show (a -> b) -- Defined in ‘Text.Show.Functions’



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/27f2df7adfcd9ffbd04749d5aba962e84c39ff6b...50fdf33ff6c82c370659c8491457ca4ea05c8938

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/27f2df7adfcd9ffbd04749d5aba962e84c39ff6b...50fdf33ff6c82c370659c8491457ca4ea05c8938
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250207/739cc8aa/attachment-0001.html>