[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: base: Label threads forked by IO operations
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Feb 7 23:27:38 UTC 2025
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
bab55603 by Ben Gamari at 2025-02-07T18:27:15-05:00
base: Label threads forked by IO operations
Addresses part of #25452.
Addresses core-libraries-committee#305.
- - - - -
d70ae5a3 by Ben Gamari at 2025-02-07T18:27:16-05:00
base: Label threads forked by System.Timeout
Addresses part of #25452.
Addresses core-libraries-committee#305.
- - - - -
58cc664d by Ben Gamari at 2025-02-07T18:27:16-05:00
base: Label signal handling threads
Addresses part of #25452.
Addresses core-libraries-committee#305.
- - - - -
b8b0096f by Ben Gamari at 2025-02-07T18:27:16-05:00
base: Label Windows console event handling threads
Addresses part of #25452.
Addresses core-libraries-committee#305.
- - - - -
1a361e0f by Ben Gamari at 2025-02-07T18:27:16-05:00
ghci: Label evaluation sandbox thread
Addresses part of #25452.
Addresses core-libraries-committee#305.
- - - - -
c5ed83eb by Ben Gamari at 2025-02-07T18:27:16-05:00
base: Add changelog entry for addition of thread labels
Addresses #25452.
Addresses core-libraries-committee#305.
- - - - -
ec91a79b by Ben Gamari at 2025-02-07T18:27:16-05:00
gen-ci: Clean up style
This cleans up a number of stylistic inconsistencies although it's still
far from perfect.
- - - - -
aa0df0c5 by Ben Gamari at 2025-02-07T18:27:16-05:00
gen-ci: Properly encapsulate GitLab predicates
- - - - -
11 changed files:
- .gitlab/generate-ci/gen_ci.hs
- 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
- 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
=====================================
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
=====================================
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/50fdf33ff6c82c370659c8491457ca4ea05c8938...aa0df0c5aa43d2e16040ad7911362e3bf4bb16ce
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50fdf33ff6c82c370659c8491457ca4ea05c8938...aa0df0c5aa43d2e16040ad7911362e3bf4bb16ce
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/689059ab/attachment-0001.html>
More information about the ghc-commits
mailing list