[Git][ghc/ghc][wip/fendor/unitstate-split] 2 commits: WIP: split UnitState into global and local data
by Hannes Siebenhandl (＠fendor) 22 May '26
by Hannes Siebenhandl (＠fendor) 22 May '26
22 May '26
Hannes Siebenhandl pushed to branch wip/fendor/unitstate-split at Glasgow Haskell Compiler / GHC
Commits:
74f022a2 by fendor at 2026-05-22T11:57:14+02:00
WIP: split UnitState into global and local data
- - - - -
06d2232b by fendor at 2026-05-22T11:57:14+02:00
Drop preloadClosure as it is always empty
- - - - -
74 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/ByteCode.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Main/Compile.hs
- compiler/GHC/Driver/Main/Hsc.hs
- compiler/GHC/Driver/Main/Interactive.hs
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Messager.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Ppr.hs
- compiler/GHC/Driver/Session/Inspect.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Errors.hs
- compiler/GHC/Iface/Errors/Types.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Linker/Dynamic.hs
- compiler/GHC/Linker/Executable.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/MacOS.hs
- compiler/GHC/Linker/Static.hs
- compiler/GHC/Linker/Unit.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Interpreter/Init.hs
- compiler/GHC/Runtime/Interpreter/JS.hs
- compiler/GHC/Runtime/Interpreter/Types.hs
- compiler/GHC/Runtime/Interpreter/Wasm.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Linker/Utils.hs
- compiler/GHC/SysTools/Cpp.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Unit/State.hs-boot
- compiler/GHC/Unit/Types.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Print.hs
- ghc/Main.hs
- utils/dump-decls/Main.hs
- utils/haddock/haddock-api/src/Haddock.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-api/src/Haddock/Interface.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/ModuleTree.hs
- utils/haddock/haddock-api/src/Haddock/Options.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d696fe67f8ea12d7a9869078b406e4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d696fe67f8ea12d7a9869078b406e4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T27261 at Glasgow Haskell Compiler / GHC
Commits:
65d6391c by Simon Peyton Jones at 2026-05-22T12:27:34+01:00
Wibbles
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/Simplify/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -502,6 +502,7 @@ contIsTrivial _ = False
-------------------
contStop :: SimplCont -> SimplCont
-- Get the Stop at the tail of the argument
+-- Always returns a continuation of form (Stop ...)
contStop stop@(Stop {}) = stop
contStop (CastIt { sc_cont = k }) = contStop k
contStop (StrictBind { sc_cont = k }) = contStop k
@@ -670,20 +671,26 @@ mkBottomCont ::SimplCont -> SimplCont
-- looking like (case <hole> of {}).
-- This is used when we are going to fill in the <hole> with bottom
-- See (TC2,3) in Note [Trimming the continuation for bottoming functions]
-mkBottomCont cont@(Stop {}) = cont
-mkBottomCont cont@(Select { sc_alts = [], sc_cont = Stop {} }) = cont
-mkBottomCont cont
- | Stop res_ty _ _ <- stop_cont
- , hole_ty `eqTypeIgnoringMultiplicity` res_ty
- = stop_cont
- | otherwise
- = Select { sc_alts = []
- , sc_bndr = mkWildValBinder OneTy hole_ty
- , sc_env = Simplified OkDup
- , sc_cont = stop_cont }
+-- But don't bother to trim, making a `case <hole> of {}`, if we have only
+-- an essentially-trivial continuation; e.g. (<hole> @ty |> co)
+mkBottomCont cont = go cont
where
- hole_ty = contHoleType cont
- stop_cont = contStop cont
+ go k@(Stop {}) = k
+ go (TickIt t k') = TickIt t (go k')
+ go k@(CastIt { sc_cont = k' }) = k { sc_cont = go k' }
+ go k@(ApplyToTy { sc_cont = k' }) = k { sc_cont = go k' }
+ go k@(Select { sc_alts = [], sc_cont = Stop {} }) = k -- Optimisation only
+ go k | Stop res_ty _ _ <- stop_cont
+ , hole_ty `eqTypeIgnoringMultiplicity` res_ty
+ = stop_cont
+ | otherwise
+ = Select { sc_alts = []
+ , sc_bndr = mkWildValBinder OneTy hole_ty
+ , sc_env = Simplified OkDup
+ , sc_cont = stop_cont }
+ where
+ hole_ty = contHoleType k
+ stop_cont = contStop k
-------------------
mkArgInfo :: SimplEnv -> Id -> [CoreRule] -> SimplCont -> ArgInfo
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/65d6391c0d4209b390f8cd9868ef7aa…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/65d6391c0d4209b390f8cd9868ef7aa…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/spj-try-opt-coercion] Drastically reduce the use of the coercion optimiser
by Simon Peyton Jones (＠simonpj) 22 May '26
by Simon Peyton Jones (＠simonpj) 22 May '26
22 May '26
Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC
Commits:
843b9a2a by Simon Peyton Jones at 2026-05-22T12:00:39+01:00
Drastically reduce the use of the coercion optimiser
This MR addresess #26679 by calling the coercion optimiser much less often;
the coercion optimiser is expensive, and often ineffective, especially when
it is called repeatedly.
See Note [Coercion optimisation] in GHC.Core.Corecion.Opt.
Specifically
* Make coercion optimisation into its own pass, controlled by its own flag
`-fopt-coercion` like any other pass. The pass runs early in the pipeline.
* The Simplifier now contents itself with merely applying the current substitution
to a coercion, and checking for reflexivity.
* Kill off OptCoercionOpts, which is now unused.
Another important, but only loosely related, improvement
* In `GHC.Core.Subst.substIdBndr`, `GHC.Core.TyCo.Subst.substTyVarBndrUsing`,
and `GHC.Core.TyCo.Subst.substTyVarBndrUsing`, check for an empty substitution.
This keeps substitutions empty in the no-op case.
See Note [Keeping the substitution empty] in GHC.Core.TyCo.Subst
Compile time improves. Here are the compile-time allocation change over 1%:
Baseline
Test value Change
------------------------------------------------------------
CoOpt_Singletons(normal) 721,677,974 -7.9% GOOD
LargeRecord(normal) 1,268,094,410 -20.4% GOOD
T12545(normal) 772,150,124 -9.2%
T12707(normal) 777,720,918 -1.5% GOOD
T14766(normal) 918,228,179 -50.2% GOOD
T15703(normal) 318,141,541 +1.0% BAD
T18223(normal) 371,496,473 -7.6% GOOD
T1969(normal) 670,830,326 +2.2% BAD
T20261(normal) 573,444,953 -2.2%
T24984(normal) 87,836,660 -1.5%
T3064(normal) 171,636,592 -6.2% GOOD
T5030(normal) 148,301,062 -16.4% GOOD
T5321Fun(normal) 263,120,022 -3.3% GOOD
T8095(normal) 777,033,006 -71.3% GOOD
T9020(optasm) 222,159,574 -2.5% GOOD
T9630(normal) 873,422,584 -15.4% GOOD
T9872b(normal) 1,906,890,318 -2.9% GOOD
T9872b_defer(normal) 2,878,170,737 -2.1% GOOD
T9872d(normal) 356,978,798 -7.7% GOOD
TcPlugin_RewritePerf(normal) 2,132,138,060 -2.6% GOOD
geo. mean -2.7%
minimum -71.3%
maximum +2.2%
Metric Decrease:
CoOpt_Singletons
LargeRecord
T12707
T14766
T18223
T3064
T5030
T5321Fun
T8095
T9020
T9630
T9872b
T9872b_defer
T9872d
TcPlugin_RewritePerf
Metric Increase:
T15703
T1969
Serious attempt to avoid duplicating large coercions
Progress on not-inlining coercions
Add a type signature
More on exported coercions
More on coercion bindings
Allow in letrec; indeed make the invariants for letrec the same
as the invariants for top-level bindings.
ToDo: document this
Fix expression-equality for (Coercion co)
We were just saying "True" which is utterly wrong.
See Note [Equality for coercions] in GHC.Core.Map.Type
Wibbles on coercion bindings
Try a very cheap coercion optimiser
Comments -- almost all just about core invariants
Fuse optCoRefl and substCo
Maybe this will be better than either
Update Notes about core binding invariants
T26332 really should fail with -dlinear-core-lint
Try switching off the big optCoercion except in O2
Comments only
Try dropping all optimisation
The Simplifier just calls substCo, instead of optCoRefl
Flags for tracing coercion sizes
More optCoRefl
* Deal with submultiplicities
* In InitialPhase run even with empty subst
Update user manual
Care with the simple refl optimiser
Improve the gobbler
Fix warning
Add changelog
- - - - -
57 changed files:
- + changelog.d/opt-coercion
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/LateCC/TopLevelBinds.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Map/Expr.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Pipeline/Types.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Data/TrieMap.hs
- compiler/GHC/Driver/Config.hs
- compiler/GHC/Driver/Config/Core/Lint.hs
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Types/Var/Env.hs
- compiler/GHC/Utils/Misc.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/GHC/Utils/Trace.hs
- docs/users_guide/debugging.rst
- docs/users_guide/using-optimisation.rst
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/linear/should_compile/T26332.hs
- testsuite/tests/linear/should_compile/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/843b9a2a0d9b8f99528a6f45053b7aa…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/843b9a2a0d9b8f99528a6f45053b7aa…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/9.10.4-batch1] 3 commits: compiler: Rename isMathFun -> isLibcFun
by Andreas Klebinger (＠AndreasK) 22 May '26
by Andreas Klebinger (＠AndreasK) 22 May '26
22 May '26
Andreas Klebinger pushed to branch wip/andreask/9.10.4-batch1 at Glasgow Haskell Compiler / GHC
Commits:
6f860cc8 by Ben Gamari at 2026-05-22T12:55:55+02:00
compiler: Rename isMathFun -> isLibcFun
This set includes more than just math functions.
(cherry picked from commit 43fdfddc25c36ef4811941231d5755bad065796d)
(cherry picked from commit 99291e88f0498f11317e0f45c4968583c8c6ef0f)
- - - - -
b37650e3 by Ben Gamari at 2026-05-22T12:56:09+02:00
compiler: Add libc allocator functions to libc_funs
Prototypes for these are now visible from `Prim.h`, resulting in
multiple-declaration warnings in the unregisterised job.
(cherry picked from commit 4ed5138f7af532731f88380f98103487a9f15c5a)
(cherry picked from commit d5d081e38f6abf445ad50b355585d2edddfc8173)
- - - - -
871e635e by Ben Gamari at 2026-05-22T12:56:09+02:00
rts: Minimize header dependencies of Prim.h
Otherwise we will end up with redundant and incompatible declarations
resulting in warnings during the unregisterised build.
(cherry picked from commit 9a0a076b80d6fb68d7722d2bb72c17c90ba22cd1)
(cherry picked from commit ef442bd152400dc550fba2ba5fd90fb0f5454614)
- - - - -
5 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/CmmToC.hs
- rts/include/stg/Prim.h
- rts/prim/int64x2minmax.c
- rts/prim/vectorQuotRem.c
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -100,7 +100,7 @@ module GHC.Cmm.CLabel (
needsCDecl,
maybeLocalBlockLabel,
externallyVisibleCLabel,
- isMathFun,
+ isLibcFun,
isCFunctionLabel,
isGcPtrLabel,
labelDynamic,
@@ -1021,7 +1021,7 @@ needsCDecl (CmmLabel pkgId (NeedExternDecl external) _ _)
-- For other labels we inline one into the HC file directly.
| otherwise = True
-needsCDecl l@(ForeignLabel{}) = not (isMathFun l)
+needsCDecl l@(ForeignLabel{}) = not (isLibcFun l)
needsCDecl (CC_Label _) = True
needsCDecl (CCS_Label _) = True
needsCDecl (IPE_Label {}) = True
@@ -1048,15 +1048,19 @@ maybeLocalBlockLabel _ = Nothing
-- | Check whether a label corresponds to a C function that has
--- a prototype in a system header somewhere, or is built-in
--- to the C compiler. For these labels we avoid generating our
--- own C prototypes.
-isMathFun :: CLabel -> Bool
-isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs
-isMathFun _ = False
-
-math_funs :: UniqSet FastString
-math_funs = mkUniqSet [
+-- a prototype in a system header somewhere, or is built-in
+-- to the C compiler. For these labels we avoid generating our
+-- own C prototypes.
+isLibcFun :: CLabel -> Bool
+isLibcFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` libc_funs
+isLibcFun _ = False
+
+libc_funs :: UniqSet FastString
+libc_funs = mkUniqSet [
+ ---------------------
+ -- Math functions
+ ---------------------
+
-- _ISOC99_SOURCE
(fsLit "acos"), (fsLit "acosf"), (fsLit "acosh"),
(fsLit "acoshf"), (fsLit "acoshl"), (fsLit "acosl"),
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -252,7 +252,7 @@ pprStmt platform stmt =
-- it isn't valid C.
| CmmNeverReturns <- ret ->
pprCall platform cast_fn cconv hresults hargs <> semi <> text "__builtin_unreachable();"
- | not (isMathFun lbl) ->
+ | not (isLibcFun lbl) ->
pprForeignCall platform (pprCLabel platform lbl) cconv hresults hargs
_ ->
pprCall platform cast_fn cconv hresults hargs <> semi
=====================================
rts/include/stg/Prim.h
=====================================
@@ -145,30 +145,28 @@ W_ hs_mulIntMayOflo(W_ a, W_ b);
/* rts/prim/int64x2minmax and rts/prim/vectorQuotRem */
#if defined(__SSE2__)
-#include <emmintrin.h>
-
-__m128i hs_minInt64X2(__m128i, __m128i);
-__m128i hs_maxInt64X2(__m128i, __m128i);
-__m128i hs_minWord64X2(__m128i, __m128i);
-__m128i hs_maxWord64X2(__m128i, __m128i);
-
-__m128i hs_quotInt8X16(__m128i, __m128i);
-__m128i hs_quotInt16X8(__m128i, __m128i);
-__m128i hs_quotInt32X4(__m128i, __m128i);
-__m128i hs_quotInt64X2(__m128i, __m128i);
-__m128i hs_quotWord8X16(__m128i, __m128i);
-__m128i hs_quotWord16X8(__m128i, __m128i);
-__m128i hs_quotWord32X4(__m128i, __m128i);
-__m128i hs_quotWord64X2(__m128i, __m128i);
-__m128i hs_remInt8X16(__m128i, __m128i);
-__m128i hs_remInt16X8(__m128i, __m128i);
-__m128i hs_remInt32X4(__m128i, __m128i);
-__m128i hs_remInt64X2(__m128i, __m128i);
-__m128i hs_remWord8X16(__m128i, __m128i);
-__m128i hs_remWord16X8(__m128i, __m128i);
-__m128i hs_remWord32X4(__m128i, __m128i);
-__m128i hs_remWord64X2(__m128i, __m128i);
-
+typedef char v128 __attribute__((vector_size(16)));
+v128 hs_minInt64X2(v128, v128);
+v128 hs_maxInt64X2(v128, v128);
+v128 hs_minWord64X2(v128, v128);
+v128 hs_maxWord64X2(v128, v128);
+
+v128 hs_quotInt8X16(v128, v128);
+v128 hs_quotInt16X8(v128, v128);
+v128 hs_quotInt32X4(v128, v128);
+v128 hs_quotInt64X2(v128, v128);
+v128 hs_quotWord8X16(v128, v128);
+v128 hs_quotWord16X8(v128, v128);
+v128 hs_quotWord32X4(v128, v128);
+v128 hs_quotWord64X2(v128, v128);
+v128 hs_remInt8X16(v128, v128);
+v128 hs_remInt16X8(v128, v128);
+v128 hs_remInt32X4(v128, v128);
+v128 hs_remInt64X2(v128, v128);
+v128 hs_remWord8X16(v128, v128);
+v128 hs_remWord16X8(v128, v128);
+v128 hs_remWord32X4(v128, v128);
+v128 hs_remWord64X2(v128, v128);
#endif
/* bitcasts, instead of creating a new C file we static inline these here. We
=====================================
rts/prim/int64x2minmax.c
=====================================
@@ -12,44 +12,44 @@
// * enable SSE4.2, or
// * implement min/max in NCG.
-__m128i hs_minInt64X2(__m128i xx, __m128i yy)
+v128 hs_minInt64X2(v128 xx, v128 yy)
{
int64_t x[2], y[2];
memcpy(x, &xx, 16);
memcpy(y, &yy, 16);
int64_t z0 = x[0] < y[0] ? x[0] : y[0];
int64_t z1 = x[1] < y[1] ? x[1] : y[1];
- return _mm_set_epi64x(z1, z0);
+ return (v128) _mm_set_epi64x(z1, z0);
}
-__m128i hs_maxInt64X2(__m128i xx, __m128i yy)
+v128 hs_maxInt64X2(v128 xx, v128 yy)
{
int64_t x[2], y[2];
memcpy(x, &xx, 16);
memcpy(y, &yy, 16);
int64_t z0 = x[0] < y[0] ? y[0] : x[0];
int64_t z1 = x[1] < y[1] ? y[1] : x[1];
- return _mm_set_epi64x(z1, z0);
+ return (v128) _mm_set_epi64x(z1, z0);
}
-__m128i hs_minWord64X2(__m128i xx, __m128i yy)
+v128 hs_minWord64X2(v128 xx, v128 yy)
{
uint64_t x[2], y[2];
memcpy(x, &xx, 16);
memcpy(y, &yy, 16);
uint64_t z0 = x[0] < y[0] ? x[0] : y[0];
uint64_t z1 = x[1] < y[1] ? x[1] : y[1];
- return _mm_set_epi64x(z1, z0);
+ return (v128) _mm_set_epi64x(z1, z0);
}
-__m128i hs_maxWord64X2(__m128i xx, __m128i yy)
+v128 hs_maxWord64X2(v128 xx, v128 yy)
{
uint64_t x[2], y[2];
memcpy(x, &xx, 16);
memcpy(y, &yy, 16);
uint64_t z0 = x[0] < y[0] ? y[0] : x[0];
uint64_t z1 = x[1] < y[1] ? y[1] : x[1];
- return _mm_set_epi64x(z1, z0);
+ return (v128) _mm_set_epi64x(z1, z0);
}
#endif
=====================================
rts/prim/vectorQuotRem.c
=====================================
@@ -16,7 +16,7 @@ int8x16_t hs_quotInt8X16(int8x16_t x, int8x16_t y)
*/
-__m128i hs_quotInt8X16(__m128i xx, __m128i yy)
+v128 hs_quotInt8X16(v128 xx, v128 yy)
{
int8_t x[16], y[16];
memcpy(x, &xx, 16);
@@ -37,10 +37,10 @@ __m128i hs_quotInt8X16(__m128i xx, __m128i yy)
int8_t z13 = x[13] / y[13];
int8_t z14 = x[14] / y[14];
int8_t z15 = x[15] / y[15];
- return _mm_set_epi8(z15, z14, z13, z12, z11, z10, z9, z8, z7, z6, z5, z4, z3, z2, z1, z0);
+ return (v128) _mm_set_epi8(z15, z14, z13, z12, z11, z10, z9, z8, z7, z6, z5, z4, z3, z2, z1, z0);
}
-__m128i hs_quotInt16X8(__m128i xx, __m128i yy)
+v128 hs_quotInt16X8(v128 xx, v128 yy)
{
int16_t x[8], y[8];
memcpy(x, &xx, 16);
@@ -53,10 +53,10 @@ __m128i hs_quotInt16X8(__m128i xx, __m128i yy)
int16_t z5 = x[5] / y[5];
int16_t z6 = x[6] / y[6];
int16_t z7 = x[7] / y[7];
- return _mm_set_epi16(z7, z6, z5, z4, z3, z2, z1, z0);
+ return (v128) _mm_set_epi16(z7, z6, z5, z4, z3, z2, z1, z0);
}
-__m128i hs_quotInt32X4(__m128i xx, __m128i yy)
+v128 hs_quotInt32X4(v128 xx, v128 yy)
{
int32_t x[4], y[4];
memcpy(x, &xx, 16);
@@ -65,20 +65,20 @@ __m128i hs_quotInt32X4(__m128i xx, __m128i yy)
int32_t z1 = x[1] / y[1];
int32_t z2 = x[2] / y[2];
int32_t z3 = x[3] / y[3];
- return _mm_set_epi32(z3, z2, z1, z0);
+ return (v128) _mm_set_epi32(z3, z2, z1, z0);
}
-__m128i hs_quotInt64X2(__m128i xx, __m128i yy)
+v128 hs_quotInt64X2(v128 xx, v128 yy)
{
int64_t x[2], y[2];
memcpy(x, &xx, 16);
memcpy(y, &yy, 16);
int64_t z0 = x[0] / y[0];
int64_t z1 = x[1] / y[1];
- return _mm_set_epi64x(z1, z0);
+ return (v128) _mm_set_epi64x(z1, z0);
}
-__m128i hs_quotWord8X16(__m128i xx, __m128i yy)
+v128 hs_quotWord8X16(v128 xx, v128 yy)
{
uint8_t x[16], y[16];
memcpy(x, &xx, 16);
@@ -99,10 +99,10 @@ __m128i hs_quotWord8X16(__m128i xx, __m128i yy)
uint8_t z13 = x[13] / y[13];
uint8_t z14 = x[14] / y[14];
uint8_t z15 = x[15] / y[15];
- return _mm_set_epi8(z15, z14, z13, z12, z11, z10, z9, z8, z7, z6, z5, z4, z3, z2, z1, z0);
+ return (v128) _mm_set_epi8(z15, z14, z13, z12, z11, z10, z9, z8, z7, z6, z5, z4, z3, z2, z1, z0);
}
-__m128i hs_quotWord16X8(__m128i xx, __m128i yy)
+v128 hs_quotWord16X8(v128 xx, v128 yy)
{
uint16_t x[8], y[8];
memcpy(x, &xx, 16);
@@ -115,10 +115,10 @@ __m128i hs_quotWord16X8(__m128i xx, __m128i yy)
uint16_t z5 = x[5] / y[5];
uint16_t z6 = x[6] / y[6];
uint16_t z7 = x[7] / y[7];
- return _mm_set_epi16(z7, z6, z5, z4, z3, z2, z1, z0);
+ return (v128) _mm_set_epi16(z7, z6, z5, z4, z3, z2, z1, z0);
}
-__m128i hs_quotWord32X4(__m128i xx, __m128i yy)
+v128 hs_quotWord32X4(v128 xx, v128 yy)
{
uint32_t x[4], y[4];
memcpy(x, &xx, 16);
@@ -127,20 +127,20 @@ __m128i hs_quotWord32X4(__m128i xx, __m128i yy)
uint32_t z1 = x[1] / y[1];
uint32_t z2 = x[2] / y[2];
uint32_t z3 = x[3] / y[3];
- return _mm_set_epi32(z3, z2, z1, z0);
+ return (v128) _mm_set_epi32(z3, z2, z1, z0);
}
-__m128i hs_quotWord64X2(__m128i xx, __m128i yy)
+v128 hs_quotWord64X2(v128 xx, v128 yy)
{
uint64_t x[2], y[2];
memcpy(x, &xx, 16);
memcpy(y, &yy, 16);
uint64_t z0 = x[0] / y[0];
uint64_t z1 = x[1] / y[1];
- return _mm_set_epi64x(z1, z0);
+ return (v128) _mm_set_epi64x(z1, z0);
}
-__m128i hs_remInt8X16(__m128i xx, __m128i yy)
+v128 hs_remInt8X16(v128 xx, v128 yy)
{
int8_t x[16], y[16];
memcpy(x, &xx, 16);
@@ -161,10 +161,10 @@ __m128i hs_remInt8X16(__m128i xx, __m128i yy)
int8_t z13 = x[13] % y[13];
int8_t z14 = x[14] % y[14];
int8_t z15 = x[15] % y[15];
- return _mm_set_epi8(z15, z14, z13, z12, z11, z10, z9, z8, z7, z6, z5, z4, z3, z2, z1, z0);
+ return (v128) _mm_set_epi8(z15, z14, z13, z12, z11, z10, z9, z8, z7, z6, z5, z4, z3, z2, z1, z0);
}
-__m128i hs_remInt16X8(__m128i xx, __m128i yy)
+v128 hs_remInt16X8(v128 xx, v128 yy)
{
int16_t x[8], y[8];
memcpy(x, &xx, 16);
@@ -177,10 +177,10 @@ __m128i hs_remInt16X8(__m128i xx, __m128i yy)
int16_t z5 = x[5] % y[5];
int16_t z6 = x[6] % y[6];
int16_t z7 = x[7] % y[7];
- return _mm_set_epi16(z7, z6, z5, z4, z3, z2, z1, z0);
+ return (v128) _mm_set_epi16(z7, z6, z5, z4, z3, z2, z1, z0);
}
-__m128i hs_remInt32X4(__m128i xx, __m128i yy)
+v128 hs_remInt32X4(v128 xx, v128 yy)
{
int32_t x[4], y[4];
memcpy(x, &xx, 16);
@@ -189,20 +189,20 @@ __m128i hs_remInt32X4(__m128i xx, __m128i yy)
int32_t z1 = x[1] % y[1];
int32_t z2 = x[2] % y[2];
int32_t z3 = x[3] % y[3];
- return _mm_set_epi32(z3, z2, z1, z0);
+ return (v128) _mm_set_epi32(z3, z2, z1, z0);
}
-__m128i hs_remInt64X2(__m128i xx, __m128i yy)
+v128 hs_remInt64X2(v128 xx, v128 yy)
{
int64_t x[2], y[2];
memcpy(x, &xx, 16);
memcpy(y, &yy, 16);
int64_t z0 = x[0] % y[0];
int64_t z1 = x[1] % y[1];
- return _mm_set_epi64x(z1, z0);
+ return (v128) _mm_set_epi64x(z1, z0);
}
-__m128i hs_remWord8X16(__m128i xx, __m128i yy)
+v128 hs_remWord8X16(v128 xx, v128 yy)
{
uint8_t x[16], y[16];
memcpy(x, &xx, 16);
@@ -223,10 +223,10 @@ __m128i hs_remWord8X16(__m128i xx, __m128i yy)
uint8_t z13 = x[13] % y[13];
uint8_t z14 = x[14] % y[14];
uint8_t z15 = x[15] % y[15];
- return _mm_set_epi8(z15, z14, z13, z12, z11, z10, z9, z8, z7, z6, z5, z4, z3, z2, z1, z0);
+ return (v128) _mm_set_epi8(z15, z14, z13, z12, z11, z10, z9, z8, z7, z6, z5, z4, z3, z2, z1, z0);
}
-__m128i hs_remWord16X8(__m128i xx, __m128i yy)
+v128 hs_remWord16X8(v128 xx, v128 yy)
{
uint16_t x[8], y[8];
memcpy(x, &xx, 16);
@@ -239,10 +239,10 @@ __m128i hs_remWord16X8(__m128i xx, __m128i yy)
uint16_t z5 = x[5] % y[5];
uint16_t z6 = x[6] % y[6];
uint16_t z7 = x[7] % y[7];
- return _mm_set_epi16(z7, z6, z5, z4, z3, z2, z1, z0);
+ return (v128) _mm_set_epi16(z7, z6, z5, z4, z3, z2, z1, z0);
}
-__m128i hs_remWord32X4(__m128i xx, __m128i yy)
+v128 hs_remWord32X4(v128 xx, v128 yy)
{
uint32_t x[4], y[4];
memcpy(x, &xx, 16);
@@ -251,17 +251,17 @@ __m128i hs_remWord32X4(__m128i xx, __m128i yy)
uint32_t z1 = x[1] % y[1];
uint32_t z2 = x[2] % y[2];
uint32_t z3 = x[3] % y[3];
- return _mm_set_epi32(z3, z2, z1, z0);
+ return (v128) _mm_set_epi32(z3, z2, z1, z0);
}
-__m128i hs_remWord64X2(__m128i xx, __m128i yy)
+v128 hs_remWord64X2(v128 xx, v128 yy)
{
uint64_t x[2], y[2];
memcpy(x, &xx, 16);
memcpy(y, &yy, 16);
uint64_t z0 = x[0] % y[0];
uint64_t z1 = x[1] % y[1];
- return _mm_set_epi64x(z1, z0);
+ return (v128) _mm_set_epi64x(z1, z0);
}
#endif
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8e310a1fa14328ae2cc4c46109ccf…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8e310a1fa14328ae2cc4c46109ccf…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/az/T27274-epa-qualified-multiline-string] 4 commits: Use "grimily" instead of "grimly"
by Alan Zimmerman (＠alanz) 22 May '26
by Alan Zimmerman (＠alanz) 22 May '26
22 May '26
Alan Zimmerman pushed to branch wip/az/T27274-epa-qualified-multiline-string at Glasgow Haskell Compiler / GHC
Commits:
6f9d7c71 by Markus Läll at 2026-05-21T15:25:34-04:00
Use "grimily" instead of "grimly"
Fixes https://gitlab.haskell.org/ghc/ghc/-/issues/27221
- - - - -
50e999ca by fendor at 2026-05-21T15:26:18-04:00
Speed up 'closure' computation in `ghc-pkg`
Cache the set of already seen `UnitId`s and use `Set` operations to
speed up 'closure' computation.
Further simplify the implementation of 'closure' to account for the
actual usage.
As a consequence, we rename 'closure' to 'brokenPackages' to reflect its
purpose better after the simplification.
- - - - -
7ecc6184 by sheaf at 2026-05-21T15:27:10-04:00
TcMPluginHandling: be more lenient when no plugins
This change ensures that, if a function such as 'typecheckModule' was
invoked with 'NoTcMPlugins', GHC doesn't spuriously complain about TcM
plugins having already been stopped, as there were none to start with.
- - - - -
f1b78c98 by Alan Zimmerman at 2026-05-22T10:53:09+00:00
EPA: Fix span for qualified multiline string
Fix the span for a qualified multiline string like
Text."""
I'm a multiline
Text value
!
"""
to extend to the end of the entire string, not just the first line.
Closes #27274
- - - - -
20 changed files:
- + changelog.d/ghc-pkg-faster-closure
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/StgToJS/Ids.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Cache.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Types/Unique/Supply.hs
- + testsuite/tests/ghc-api/T27273.hs
- testsuite/tests/ghc-api/all.T
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/PprQualifiedStrings.hs
- testsuite/tests/printer/all.T
- utils/check-exact/ExactPrint.hs
- utils/ghc-pkg/Main.hs
Changes:
=====================================
changelog.d/ghc-pkg-faster-closure
=====================================
@@ -0,0 +1,10 @@
+section: ghc-pkg
+synopsis: Improve performance of `ghc-pkg list` command
+issues: #27275
+mrs: !16062
+
+description: {
+`ghc-pkg list` was quadratic in the number of packages due to an inefficient `closure` computation.
+We cache the set of seen packages, allowing us to speed up the `closure` computation, improving run-time
+for the commands `list`, `check`, `distrust`, `expose`, `hide`, `trust` and `unregister`.
+}
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -318,7 +318,7 @@ instance DSM.MonadGetUnique LlvmM where
tag <- getEnv envTag
liftUDSMT $! do
uq <- DSM.getUniqueM
- return (newTagUniqueGrimly uq tag)
+ return (newTagUniqueGrimily uq tag)
-- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
liftIO :: IO a -> LlvmM a
=====================================
compiler/GHC/Core/Opt/Monad.hs
=====================================
@@ -175,11 +175,11 @@ instance MonadPlus CoreM
instance MonadUnique CoreM where
getUniqueSupplyM = do
tag <- read cr_uniq_tag
- liftIO $! mkSplitUniqSupplyGrimly tag
+ liftIO $! mkSplitUniqSupplyGrimily tag
getUniqueM = do
tag <- read cr_uniq_tag
- liftIO $! uniqFromTagGrimly tag
+ liftIO $! uniqFromTagGrimily tag
runCoreM :: HscEnv
-> RuleBase
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -144,7 +144,7 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
| otherwise = unpackHObj res_hty
header_bits = maybe mempty idTag maybe_target
- idTag i = let (tag, u) = unpkUniqueGrimly (getUnique i)
+ idTag i = let (tag, u) = unpkUniqueGrimily (getUnique i)
in CHeader (char tag <> word64 u)
normal_args = map (\(nm,_ty,_,_) -> nm) arg_info
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -707,7 +707,7 @@ putName BinSymbolTable{
bin_symtab_next = symtab_next }
bh name
| isKnownKeyName name
- , let (c, u) = unpkUniqueGrimly (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
+ , let (c, u) = unpkUniqueGrimily (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
= -- assert (u < 2^(22 :: Int))
put_ bh (0x80000000
.|. (fromIntegral (ord c) `shiftL` 22)
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -2274,8 +2274,9 @@ tok_quoted_label span buf len _buf2 = do
tok_qstrings :: Action -> Action
tok_qstrings lex_str span0 buf0 len0 endBuf0 = do
let modName = ModuleName $ lexemeToFastString buf0 modNameLen
- (src, meta, s) <- unITstring <$> lex_str strSpan strBuf strLen endBuf0
- pure $ L span0 $ ITstring src meta{strMetaQualified = Just modName} s
+ (span1, src, meta, s) <- unITstring <$> lex_str strSpan strBuf strLen endBuf0
+ let span2 = mkPsSpan (psSpanStart span0) (psSpanEnd span1)
+ pure $ L span2 $ ITstring src meta{strMetaQualified = Just modName} s
where
-- The buffer/span starting at the string literal
(strBuf, strSpanStart) =
@@ -2298,7 +2299,7 @@ tok_qstrings lex_str span0 buf0 len0 endBuf0 = do
strSpan = mkPsSpan strSpanStart (psSpanEnd span0)
unITstring = \case
- L _ (ITstring src meta s) -> (src, meta, s)
+ L span1 (ITstring src meta s) -> (span1, src, meta, s)
tok -> panic $ "tok_qstrings got unexpected token: " ++ show tok
tok_char :: Action
=====================================
compiler/GHC/Stg/Pipeline.hs
=====================================
@@ -66,9 +66,9 @@ newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
instance MonadUnique StgM where
getUniqueSupplyM = StgM $ do { tag <- ask
- ; liftIO $! mkSplitUniqSupplyGrimly tag}
+ ; liftIO $! mkSplitUniqSupplyGrimily tag}
getUniqueM = StgM $ do { tag <- ask
- ; liftIO $! uniqFromTagGrimly tag}
+ ; liftIO $! uniqFromTagGrimily tag}
runStgM :: UniqueTag -> StgM a -> IO a
runStgM mask (StgM m) = runReaderT m (uniqueTag mask)
=====================================
compiler/GHC/StgToJS/Ids.hs
=====================================
@@ -130,7 +130,7 @@ makeIdentForId i num id_type current_module = name ident
-- unique suffix for non-exported Ids
, if exported
then mempty
- else let (c,u) = unpkUniqueGrimly (getUnique i)
+ else let (c,u) = unpkUniqueGrimily (getUnique i)
in mconcat [BSC.pack ['_',c,'_'], word64BS u]
]
@@ -235,4 +235,3 @@ declVarsForId i = case typeSize (idType i) of
0 -> return mempty
1 -> decl <$> identForId i
s -> mconcat <$> mapM (\n -> decl <$> identForIdN i n) [1..s]
-
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -1250,14 +1250,17 @@ emptyTcMPluginsShutdown = TcMPluginsShutdown
data TcMPluginsState
-- | The 'TcM' plugins have not been started.
= TcMPluginsUninitialised
- -- | The 'TcM' plugins have been initialised and not yet stopped.
+ -- | The 'TcM' plugins have been initialised and not yet stopped,
+ -- or there were no 'TcM' plugins to start with.
--
-- We may be in the middle of typechecker, or have finished typechecking
-- and be in the middle of desugaring.
| TcMPluginsRunning !RunningTcMPlugins
- -- | The 'TcM' plugins have been stopped.
+ -- | There were 'TcM' plugins that were running, but they have been stopped.
| TcMPluginsStopped
+-- | A (possibly empty) collection of 'TcM' plugin @run@, @post-tc@ and
+-- @shutdown@ actions.
data RunningTcMPlugins =
RunningTcMPlugins
{ rtcmp_run :: TcMPluginsRun
@@ -1281,11 +1284,20 @@ tcMPluginsShutdownActions = rtcmp_shutdown
-- | Retrieve the 'TcM' plugins from a 'TcMPluginsState'.
--
--- Assumes the plugins have been already started and not yet stopped.
+-- Assumes the plugins (if any) have been already started and not yet stopped.
runningTcMPlugins
:: HasDebugCallStack
=> TcMPluginsState -> RunningTcMPlugins
runningTcMPlugins = \case
- TcMPluginsUninitialised -> panic "runningTcMPlugins: TcM plugins not started"
- TcMPluginsStopped -> panic "runningTcMPlugins: TcM plugins already stopped"
+ TcMPluginsUninitialised ->
+ pprPanic "TcM plugins have not been started" $
+ vcat [ text "If you are a GHC API user, make sure to use an appropriate 'TcMPluginHandling'"
+ , text "to ensure that TcM plugins (if any) are initialised before typechecking."
+ ]
+ TcMPluginsStopped ->
+ pprPanic "TcM plugins already stopped" $
+ vcat [ text "If you are a GHC API user and want to proceed to desugaring after typechecking,"
+ , text "make sure you are not using the 'StartAndStopTcMPlugins' 'TcMPluginHandling',"
+ , text "as that stops TcM plugins after typechecking."
+ ]
TcMPluginsRunning plugins -> plugins
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -790,9 +790,10 @@ withoutTcMPlugins thing_inside = do
tcg_env <- getGblEnv
writeTcRef (tcg_plugins tcg_env) $
TcMPluginsRunning emptyRunningTcMPlugins
- teardown = do
- tcg_env <- getGblEnv
- writeTcRef (tcg_plugins tcg_env) TcMPluginsStopped
+ teardown =
+ -- Don't set 'tcg_plugins' to 'TcMPluginsStopped', as that should only
+ -- be used when there were 'TcM' plugins to start with (#27273).
+ return ()
-- | Initialise 'TcM' plugins.
initTcMPlugins :: HscEnv -> TcM ()
@@ -946,32 +947,20 @@ shutdownTcMPlugins = \case
runPluginShutdowns (tcs ++ defs)
solverTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [TcPluginSolver]
-solverTcMPlugins = \case
- TcMPluginsUninitialised -> panic "solverTcMPlugins: TcM plugins not started"
- TcMPluginsStopped -> panic "solverTcMPlugins: TcM plugins already stopped"
- TcMPluginsRunning plugins ->
- tcmp_solvers (tcMPluginsRunActions plugins)
+solverTcMPlugins =
+ tcmp_solvers . tcMPluginsRunActions . runningTcMPlugins
rewriterTcMPlugins :: HasDebugCallStack => TcMPluginsState -> UniqFM TyCon [TcPluginRewriter]
-rewriterTcMPlugins = \case
- TcMPluginsUninitialised -> panic "rewriterTcMPlugins: TcM plugins not started"
- TcMPluginsStopped -> panic "rewriterTcMPlugins: TcM plugins already stopped"
- TcMPluginsRunning plugins ->
- tcmp_rewriters (tcMPluginsRunActions plugins)
+rewriterTcMPlugins =
+ tcmp_rewriters . tcMPluginsRunActions . runningTcMPlugins
defaultingTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [FillDefaulting]
-defaultingTcMPlugins = \case
- TcMPluginsUninitialised -> panic "defaultingTcMPlugins: TcM plugins not started"
- TcMPluginsStopped -> panic "defaultingTcMPlugins: TcM plugins already stopped"
- TcMPluginsRunning plugins ->
- tcmp_defaulters (tcMPluginsRunActions plugins)
+defaultingTcMPlugins =
+ tcmp_defaulters . tcMPluginsRunActions . runningTcMPlugins
holeFitTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [HoleFitPlugin]
-holeFitTcMPlugins = \case
- TcMPluginsUninitialised -> panic "holeFitTcMPlugins: TcM plugins not started"
- TcMPluginsStopped -> panic "holeFitTcMPlugins: TcM plugins already stopped"
- TcMPluginsRunning plugins ->
- tcmp_hole_fits (tcMPluginsRunActions plugins)
+holeFitTcMPlugins =
+ tcmp_hole_fits . tcMPluginsRunActions . runningTcMPlugins
{-
************************************************************************
@@ -1008,13 +997,13 @@ newUnique :: TcRnIf gbl lcl Unique
newUnique
= do { env <- getEnv
; let tag = env_ut env
- ; liftIO $! uniqFromTagGrimly tag }
+ ; liftIO $! uniqFromTagGrimily tag }
newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
= do { env <- getEnv
; let tag = env_ut env
- ; liftIO $! mkSplitUniqSupplyGrimly tag }
+ ; liftIO $! mkSplitUniqSupplyGrimily tag }
cloneLocalName :: Name -> TcM Name
-- Make a fresh Internal name with the same OccName and SrcSpan
=====================================
compiler/GHC/Types/Name/Cache.hs
=====================================
@@ -122,7 +122,7 @@ data NameCache = NameCache
type OrigNameCache = ModuleEnv (OccEnv Name)
takeUniqFromNameCache :: NameCache -> IO Unique
-takeUniqFromNameCache (NameCache c _) = uniqFromTagGrimly c
+takeUniqFromNameCache (NameCache c _) = uniqFromTagGrimily c
lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache nc mod occ = lookup_infinite <|> lookup_normal
=====================================
compiler/GHC/Types/Unique.hs
=====================================
@@ -38,12 +38,12 @@ module GHC.Types.Unique (
mkUniqueIntGrimily,
getKey,
mkUnique, unpkUnique,
- unpkUniqueGrimly,
+ unpkUniqueGrimily,
mkUniqueInt,
eqUnique, ltUnique,
incrUnique, stepUnique,
- newTagUnique, newTagUniqueGrimly,
+ newTagUnique, newTagUniqueGrimily,
nonDetCmpUnique,
isValidKnownKeyUnique,
@@ -99,7 +99,7 @@ Note [Performance implications of UniqueTag]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The UniqueTag ADT is meant to be ephemeral and eliminated by the simplifier,
so for long term storage (i.e. in monadic environments or data structures) we
-want to store the raw 'Char's. Working with the raw tags is done via the *Grimly
+want to store the raw 'Char's. Working with the raw tags is done via the *Grimily
class of functions
For instance, if we are generating a unique for a concrete tag, we should use
@@ -116,7 +116,7 @@ newUnique
; liftIO $! uniqFromTag tag }
Prefer `env_ut :: Char` and
- ; liftIO $! uniqFromTagGrimly tag }
+ ; liftIO $! uniqFromTagGrimily tag }
-}
@@ -295,7 +295,7 @@ The stuff about unique *supplies* is handled further down this module.
-}
unpkUnique :: Unique -> (UniqueTag, Word64) -- The reverse
-unpkUniqueGrimly :: Unique -> (Char, Word64) -- The reverse
+unpkUniqueGrimily :: Unique -> (Char, Word64) -- The reverse
mkUniqueGrimily :: Word64 -> Unique -- A trap-door for UniqSupply
getKey :: Unique -> Word64 -- for Var
@@ -303,7 +303,7 @@ getKey :: Unique -> Word64 -- for Var
incrUnique :: Unique -> Unique
stepUnique :: Unique -> Word64 -> Unique
newTagUnique :: Unique -> UniqueTag -> Unique
-newTagUniqueGrimly :: Unique -> Char -> Unique
+newTagUniqueGrimily :: Unique -> Char -> Unique
mkUniqueGrimily = MkUnique
@@ -323,9 +323,9 @@ maxLocalUnique :: Unique
maxLocalUnique = mkLocalUnique uniqueMask
-- newTagUnique changes the "domain" of a unique to a different char
-newTagUnique u c = newTagUniqueGrimly u (uniqueTag c)
+newTagUnique u c = newTagUniqueGrimily u (uniqueTag c)
-newTagUniqueGrimly u c = mkUniqueGrimilyWithTag c i where (_,i) = unpkUniqueGrimly u
+newTagUniqueGrimily u c = mkUniqueGrimilyWithTag c i where (_,i) = unpkUniqueGrimily u
-- | Bitmask that has zeros for the tag bits and ones for the rest.
uniqueMask :: Word64
@@ -368,7 +368,7 @@ mkUniqueIntGrimily = MkUnique . intToWord64
{-# INLINE mkUniqueIntGrimily #-}
-unpkUniqueGrimly (MkUnique u)
+unpkUniqueGrimily (MkUnique u)
= let
-- The potentially truncating use of fromIntegral here is safe
-- because the argument is just the tag bits after shifting.
@@ -376,10 +376,10 @@ unpkUniqueGrimly (MkUnique u)
i = u .&. uniqueMask
in
(tag, i)
-{-# INLINE unpkUniqueGrimly #-}
+{-# INLINE unpkUniqueGrimily #-}
-unpkUnique u = case unpkUniqueGrimly u of
+unpkUnique u = case unpkUniqueGrimily u of
(c, i) -> ( charToUniqueTag c, i)
{-# INLINE unpkUnique #-}
@@ -389,7 +389,7 @@ unpkUnique u = case unpkUniqueGrimly u of
-- See Note [Symbol table representation of names] in "GHC.Iface.Binary" for details.
isValidKnownKeyUnique :: Unique -> Bool
isValidKnownKeyUnique u =
- case unpkUniqueGrimly u of
+ case unpkUniqueGrimily u of
(c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)
{-
@@ -512,7 +512,7 @@ showUnique :: Unique -> String
showUnique uniq
= tagStr ++ w64ToBase62 u
where
- (tag, u) = unpkUniqueGrimly uniq
+ (tag, u) = unpkUniqueGrimily uniq
-- Avoid emitting non-printable characters in pretty uniques.
-- See #25989.
tagStr
=====================================
compiler/GHC/Types/Unique/Supply.hs
=====================================
@@ -16,10 +16,10 @@ module GHC.Types.Unique.Supply (
-- ** Operations on supplies
uniqFromSupply, uniqsFromSupply, -- basic ops
takeUniqFromSupply,
- uniqFromTag, uniqFromTagGrimly,
+ uniqFromTag, uniqFromTagGrimily,
UniqueTag(..),
- mkSplitUniqSupply, mkSplitUniqSupplyGrimly,
+ mkSplitUniqSupply, mkSplitUniqSupplyGrimily,
splitUniqSupply, listSplitUniqSupply,
-- * Unique supply monad and its abstraction
@@ -203,10 +203,10 @@ data UniqSupply
-- when split => these two supplies
mkSplitUniqSupply :: UniqueTag -> IO UniqSupply
-mkSplitUniqSupply ut = mkSplitUniqSupplyGrimly (uniqueTag ut)
+mkSplitUniqSupply ut = mkSplitUniqSupplyGrimily (uniqueTag ut)
{-# INLINE mkSplitUniqSupply #-}
-mkSplitUniqSupplyGrimly :: Char -> IO UniqSupply
+mkSplitUniqSupplyGrimily :: Char -> IO UniqSupply
-- ^ Create a unique supply out of thin air.
-- The "tag" (Char) supplied is mostly cosmetic, making it easier
-- to figure out where a Unique was born. See Note [Uniques and tags].
@@ -219,7 +219,7 @@ mkSplitUniqSupplyGrimly :: Char -> IO UniqSupply
-- See Note [How the unique supply works]
-- See Note [Optimising the unique supply]
-mkSplitUniqSupplyGrimly ut
+mkSplitUniqSupplyGrimily ut
= unsafeDupableInterleaveIO (IO mk_supply)
where
@@ -286,15 +286,15 @@ initUniqSupply counter inc = do
poke ghc_unique_inc inc
uniqFromTag :: UniqueTag -> IO Unique
-uniqFromTag !ut = uniqFromTagGrimly (uniqueTag ut)
+uniqFromTag !ut = uniqFromTagGrimily (uniqueTag ut)
{-# INLINE uniqFromTag #-}
-uniqFromTagGrimly :: Char -> IO Unique
-uniqFromTagGrimly !tag
+uniqFromTagGrimily :: Char -> IO Unique
+uniqFromTagGrimily !tag
= do { uqNum <- genSym
; return $! mkUniqueGrimilyWithTag tag uqNum }
-{-# NOINLINE uniqFromTagGrimly #-} -- We'll unbox everything, but we don't want to inline it
+{-# NOINLINE uniqFromTagGrimily #-} -- We'll unbox everything, but we don't want to inline it
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
-- ^ Build two 'UniqSupply' from a single one, each of which
=====================================
testsuite/tests/ghc-api/T27273.hs
=====================================
@@ -0,0 +1,56 @@
+module Main where
+
+-- base
+import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import System.Environment (getArgs)
+
+-- time
+import Data.Time (getCurrentTime)
+
+-- ghc
+import qualified GHC as GHC
+import qualified GHC.Core as GHC
+import qualified GHC.Data.StringBuffer as GHC
+import qualified GHC.Unit.Module.ModGuts as GHC
+import qualified GHC.Unit.Types as GHC
+
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+ let inputSource = unlines
+ [ "module NumLitDesugaring where"
+ , "f :: Num a => a" -- !!! Succeeds if type signature is f :: Int
+ , "f = 1"
+ ]
+
+ void $ compileToCore "NumLitDesugaring" inputSource
+
+compileToCore :: String -> String -> IO [GHC.CoreBind]
+compileToCore modName inputSource = do
+ [libdir] <- getArgs
+ GHC.runGhc (Just libdir) $ do
+ (_ms, tcMod) <- typecheckSourceCode modName inputSource
+ dsMod <- GHC.desugarModule tcMod
+ return $ GHC.mg_binds $ GHC.dm_core_module dsMod
+
+typecheckSourceCode
+ :: GHC.GhcMonad m => String -> String -> m (GHC.ModSummary, GHC.TypecheckedModule)
+typecheckSourceCode modName inputSource = do
+ now <- liftIO getCurrentTime
+ df1 <- GHC.getSessionDynFlags
+ GHC.setSessionDynFlags $ df1 { GHC.backend = GHC.bytecodeBackend }
+ let target = GHC.Target
+ { GHC.targetId = GHC.TargetFile (modName ++ ".hs") Nothing
+ , GHC.targetUnitId = GHC.homeUnitId_ df1
+ , GHC.targetAllowObjCode = False
+ , GHC.targetContents = Just (GHC.stringToStringBuffer inputSource, now)
+ }
+ GHC.setTargets [target]
+ void $ GHC.depanal [] False
+
+ ms <- GHC.getModSummary
+ (GHC.mkModule GHC.mainUnit (GHC.mkModuleName modName))
+ tm <- GHC.parseModule ms >>= GHC.typecheckModule GHC.NoTcMPlugins
+ return (ms, tm)
=====================================
testsuite/tests/ghc-api/all.T
=====================================
@@ -82,3 +82,6 @@ test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc'])
test('T25121_status', normal, compile_and_run, ['-package ghc'])
test('T24386', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc'])
+test('T27273', [extra_run_opts(f'"{config.libdir}"')],
+ compile_and_run,
+ ['-package ghc'])
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -922,3 +922,8 @@ TestNamedDefaults:
PprModifiers:
$(CHECK_PPR) $(LIBDIR) PprModifiers.hs
$(CHECK_EXACT) $(LIBDIR) PprModifiers.hs
+
+.PHONY: PprQualifiedStrings
+PprQualifiedStrings:
+ $(CHECK_PPR) $(LIBDIR) PprQualifiedStrings.hs
+ $(CHECK_EXACT) $(LIBDIR) PprQualifiedStrings.hs
=====================================
testsuite/tests/printer/PprQualifiedStrings.hs
=====================================
@@ -0,0 +1,75 @@
+{-# LANGUAGE MultilineStrings #-}
+{-# LANGUAGE QualifiedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- These are harvested from ../qualified-strings
+
+module PprQualifiedStrings where
+
+import Data.Typeable (Typeable, typeOf)
+import qualified Example.ByteStringAscii as Ascii
+import qualified Example.ByteStringUtf8 as Utf8
+import qualified Example.Text as Text
+
+exprs :: IO ()
+exprs = do
+ inspect "I'm a String" -- would be an ambiguous type error with OverloadedStrings
+ inspect Text."I'm a Text"
+ inspect Ascii."I'm an ASCII bytestring: 語"
+ inspect Utf8."I'm a UTF8 bytestring: 語"
+
+ inspect """
+ I'm a multiline
+ String value
+ !
+ """
+
+ inspect Text."""
+ I'm a multiline
+ Text value
+ !
+ """
+
+ inspect Text . """
+ I'm a multiline
+ Text value
+ """
+
+ inspect Text .
+ """
+ I'm a multiline
+ Text value
+ """
+
+pats :: IO ()
+pats = do
+ let text = Text."foo" :: Text
+ case text of
+ Text."foo" -> putStrLn "Text.\"foo\" matched"
+ _ -> putStrLn "Text.\"foo\" did not match"
+
+ let ascii = Ascii."語" :: ByteString
+ case ascii of
+ Ascii."語" -> putStrLn "Ascii.\"語\" matched"
+ _ -> putStrLn "Ascii.\"語\" did not match"
+
+ let utf = Utf8."語" :: ByteString
+ case utf of
+ Utf8."語" -> putStrLn "Utf8.\"語\" matched"
+ _ -> putStrLn "Utf8.\"語\" did not match"
+
+th :: IO ()
+th =
+ $(do
+ foldr (\stmt acc -> [| $stmt >> $acc |]) [| pure () |] $
+ [ [| inspect Text."I'm a Text" |]
+ , [| inspect Ascii."I'm an ASCII bytestring: 語" |]
+ , [| inspect Utf8."I'm a Utf8 bytestring: 語" |]
+ , [|
+ inspect Text."""
+ I'm a multiline
+ Text string
+ """
+ |]
+ ]
+ )
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -221,3 +221,4 @@ test('Test25885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25885'])
test('TestLevelImports', [ignore_stderr, req_ppr_deps], makefile_test, ['TestLevelImports'])
test('TestNamedDefaults', [ignore_stderr, req_ppr_deps], makefile_test, ['TestNamedDefaults'])
test('PprModifiers', [ignore_stderr,req_ppr_deps], makefile_test, ['PprModifiers'])
+test('PprQualifiedStrings', [ignore_stderr,req_ppr_deps], makefile_test, ['PprQualifiedStrings'])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -3145,6 +3145,12 @@ instance ExactPrint (HsExpr GhcPs) where
body' <- markAnnotated body
return (HsQual noExtField ctxt' body')
+ exact (HsQualLit _ (QualLit _ modu (HsQualString src fs))) = do
+ modu' <- markAnnotated modu
+ printStringAdvanceA "."
+ printSourceTextAA src (show (unpackFS fs))
+ return (HsQualLit noExtField (QualLit noExtField modu' (HsQualString src fs)))
+
exact x = error $ "exact HsExpr for:" ++ showAst x
-- ---------------------------------------------------------------------
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -1826,7 +1826,7 @@ checkConsistency verbosity my_flags = do
all_ps = map mungedId pkgs1
let not_broken_pkgs = filterOut broken_pkgs pkgs
- (_, trans_broken_pkgs) = closure [] not_broken_pkgs
+ trans_broken_pkgs = brokenPackages not_broken_pkgs
all_broken_pkgs :: [InstalledPackageInfo]
all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
@@ -1845,26 +1845,26 @@ checkConsistency verbosity my_flags = do
when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
-closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
- -> ([InstalledPackageInfo], [InstalledPackageInfo])
-closure pkgs db_stack = go pkgs db_stack
- where
- go avail not_avail =
- case partition (depsAvailable avail) not_avail of
- ([], not_avail') -> (avail, not_avail')
- (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
+-- | Compute the set of transitive broken packages.
+--
+-- A package is assumed to be broken if any of its dependencies is not
+-- found in the 'db_stack' after a transitive reduction.
+brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
+brokenPackages db_stack = go Set.empty db_stack
+ where
+ go avail_ids not_avail =
+ case partition (depsAvailable avail_ids) not_avail of
+ ([], not_avail') -> not_avail'
+ (new_avail, not_avail') -> go (add new_avail avail_ids) not_avail'
- depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
- -> Bool
- depsAvailable pkgs_ok pkg = null dangling
- where dangling = filter (`notElem` pids) (depends pkg)
- pids = map installedUnitId pkgs_ok
+ add new_avail avail_ids =
+ foldl' (flip Set.insert) avail_ids (map installedUnitId new_avail)
- -- we want mutually recursive groups of package to show up
- -- as broken. (#1750)
+ depsAvailable :: Set.Set UnitId -> InstalledPackageInfo -> Bool
+ depsAvailable pids pkg = all (`Set.member` pids) (depends pkg)
-brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
-brokenPackages pkgs = snd (closure [] pkgs)
+ -- we want mutually recursive groups of package to show up
+ -- as broken. (#1750)
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc2e431d96dcf835d80ac0fb91e07f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc2e431d96dcf835d80ac0fb91e07f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/ghc-internal-def] TMP: CI: do only x86_64-windows-validate
by David Eichmann (＠DavidEichmann) 22 May '26
by David Eichmann (＠DavidEichmann) 22 May '26
22 May '26
David Eichmann pushed to branch wip/davide/ghc-internal-def at Glasgow Haskell Compiler / GHC
Commits:
a30d1fcc by David Eichmann at 2026-05-22T11:39:21+01:00
TMP: CI: do only x86_64-windows-validate
- - - - -
2 changed files:
- .gitlab-ci.yml
- .gitlab/jobs.yaml
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a30d1fcc49f32fa00147983511621a5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a30d1fcc49f32fa00147983511621a5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/semaphore-v2] Update to semaphore-compat 2.0.0 using v2 of the protocol
by Zubin (＠wz1000) 22 May '26
by Zubin (＠wz1000) 22 May '26
22 May '26
Zubin pushed to branch wip/semaphore-v2 at Glasgow Haskell Compiler / GHC
Commits:
1170e992 by Zubin Duggal at 2026-05-22T15:44:25+05:30
Update to semaphore-compat 2.0.0 using v2 of the protocol
On Linux and other POSIX platforms, GHC's -jsem jobserver client now
speaks v2 of the semaphore-compat protocol, which uses Unix domain
sockets in place of POSIX named semaphores. This avoids the libc-ABI
issues that affected the old implementation. Windows is unaffected
and continues to use the v1 protocol (Win32 named semaphores); its
reported protocol version remains v1.
When GHC receives a -jsem name whose protocol version it does not
support, it emits a -Wsemaphore-version-mismatch warning and falls
back to -j<N> rather than crashing. ghc --info exposes the supported
version in a new "Semaphore version" entry so cabal-install can detect
a mismatch before invoking GHC.
Users on a cabal-install that predates the v2 update will continue to
build successfully on Linux/POSIX, but will lose the cross-process
-jsem coordination and fall back to -j<N> per GHC invocation. Users
must upgrade to a cabal-install that supports protocol v2 to recover
full parallelism.
Also fix a leak in cleanupSem (#27253): cleanupSem used to snapshot
heldTokens and release them before killing the loop, while the loop's
in-flight acquire/release children could still be mutating it.
Cleanup now runs inside the loop's own exit handler, after draining
the active child via a new activeChild TVar, so the snapshot has no
concurrent mutator.
See also:
- GHC proposal amendment: https://github.com/ghc-proposals/ghc-proposals/pull/673
- cabal-install patch: https://github.com/haskell/cabal/pull/11628
- semaphore-compat MR: https://gitlab.haskell.org/ghc/semaphore-compat/-/merge_requests/8
Bump semaphore-compat submodule to 2.0.0
Fixes #25087 and #27253
- - - - -
16 changed files:
- + changelog.d/jobserver-leak-fix
- + changelog.d/semaphore-v2
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/MakeAction.hs
- compiler/GHC/Driver/MakeSem.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- docs/users_guide/using-warnings.rst
- docs/users_guide/using.rst
- hadrian/src/Flavour.hs
- libraries/semaphore-compat
- testsuite/tests/diagnostic-codes/codes.stdout
Changes:
=====================================
changelog.d/jobserver-leak-fix
=====================================
@@ -0,0 +1,8 @@
+section: compiler
+issues: #27253
+mrs: !15729
+synopsis:
+ Fix a token leak in the ``-jsem`` jobserver shutdown path
+description:
+ A build interrupted by Ctrl-C while a ``-jsem`` token transfer was in
+ flight could leak that token.
=====================================
changelog.d/semaphore-v2
=====================================
@@ -0,0 +1,30 @@
+section: compiler
+issues: #25087
+mrs: !15729
+synopsis:
+ Update to semaphore-compat 2.0.0 (``-jsem`` protocol v2)
+description:
+ On Linux and other POSIX platforms, GHC's ``-jsem`` jobserver client
+ now speaks v2 of the semaphore-compat protocol, which uses Unix
+ domain sockets in place of POSIX named semaphores. This avoids the
+ libc-ABI issues that affected the old implementation. Windows is
+ unaffected and continues to use the v1 protocol (Win32 named
+ semaphores); its reported protocol version remains v1.
+
+ When GHC receives a ``-jsem`` name whose protocol version it does not
+ support, it now emits a ``-Wsemaphore-version-mismatch`` warning and
+ falls back to ``-j1`` rather than crashing. ``ghc --info`` exposes the
+ supported version in a new ``"Semaphore version"`` entry so
+ cabal-install can detect a mismatch before invoking GHC.
+
+ Users on a ``cabal-install`` that predates the v2 update will continue
+ to build successfully, but on Linux/POSIX will lose the cross-process
+ ``-jsem`` coordination and fall back to ``-j1`` per GHC invocation.
+ To recover full parallelism, upgrade to a ``cabal-install`` that
+ supports protocol v2.
+
+ See also:
+
+ - the `GHC proposal amendment <https://github.com/ghc-proposals/ghc-proposals/pull/673>`_
+ - the `cabal-install patch <https://github.com/haskell/cabal/pull/11628>`_
+ - the `semaphore-compat library MR <https://gitlab.haskell.org/ghc/semaphore-compat/-/merge_requests/8>`_
=====================================
compiler/GHC/Driver/Errors/Ppr.hs
=====================================
@@ -24,6 +24,8 @@ import GHC.Types.Hint
import GHC.Types.SrcLoc
import Data.Version
+import System.Semaphore
+ ( SemaphoreError(..), getSemaphoreProtocolVersion )
import Language.Haskell.Syntax.Decls (RuleDecl(..))
import GHC.Tc.Errors.Types (TcRnMessage)
import GHC.HsToCore.Errors.Types (DsMessage)
@@ -90,6 +92,20 @@ instance Diagnostic GhcMessage where
instance HasDefaultDiagnosticOpts DriverMessageOpts where
defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage)
+pprSemaphoreError :: SemaphoreError -> SDoc
+pprSemaphoreError = \case
+ SemaphoreAlreadyExists nm ->
+ text "a semaphore named" <+> quotes (text nm) <+> text "already exists"
+ SemaphoreDoesNotExist nm ->
+ text "no semaphore named" <+> quotes (text nm)
+ SemaphoreIncompatibleVersion got want ->
+ text "protocol version mismatch (got v"
+ <> int (getSemaphoreProtocolVersion got)
+ <> text ", supported v"
+ <> int (getSemaphoreProtocolVersion want) <> text ")"
+ SemaphoreOtherError ioe ->
+ text (show ioe)
+
instance Diagnostic DriverMessage where
type DiagnosticOpts DriverMessage = DriverMessageOpts
diagnosticMessage opts = \case
@@ -282,6 +298,10 @@ instance Diagnostic DriverMessage where
-> mkSimpleDecorated $
vcat [ text "The following modules are missing a linkable which is needed for creating a library:"
, nest 2 $ hcat (map ppr mods) ]
+ DriverSemaphoreOpenFailure _ err
+ -> mkSimpleDecorated $
+ text "Failed to open -jsem semaphore:" <+> pprSemaphoreError err <>
+ text "; ignoring -jsem and compiling sequentially."
diagnosticReason = \case
DriverUnknownMessage m
@@ -355,6 +375,8 @@ instance Diagnostic DriverMessage where
-> WarningWithoutFlag
DriverMissingLinkableForModule {}
-> ErrorWithoutFlag
+ DriverSemaphoreOpenFailure {}
+ -> WarningWithFlag Opt_WarnSemaphoreOpenFailure
diagnosticHints = \case
DriverUnknownMessage m
@@ -430,5 +452,19 @@ instance Diagnostic DriverMessage where
-> noHints
DriverMissingLinkableForModule {}
-> noHints
+ DriverSemaphoreOpenFailure buildingCabal (SemaphoreIncompatibleVersion received supported)
+ | received < supported
+ -> let required = getSemaphoreProtocolVersion supported
+ target = case buildingCabal of
+ YesBuildingCabalPackage -> UpgradeCabalInstall
+ NoBuildingCabalPackage -> UpgradeJobserver
+ in [SuggestUpgradeForSemaphoreVersionMismatch target required]
+ | received > supported
+ -> [SuggestUpgradeForSemaphoreVersionMismatch
+ UpgradeGHC (getSemaphoreProtocolVersion received)]
+ | otherwise
+ -> noHints
+ DriverSemaphoreOpenFailure {}
+ -> noHints
diagnosticCode = constructorCode @GHC
=====================================
compiler/GHC/Driver/Errors/Types.hs
=====================================
@@ -37,6 +37,7 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Generics ( Generic )
+import System.Semaphore ( SemaphoreError )
import GHC.Tc.Errors.Types
import GHC.Iface.Errors.Types
@@ -419,6 +420,17 @@ data DriverMessage where
DriverMissingLinkableForModule :: ![Module] -> DriverMessage
+ {-| DriverSemaphoreOpenFailure is a warning that occurs when GHC fails to
+ open the semaphore specified by @-jsem@, e.g. the socket does not
+ exist, the protocol version is incompatible, or a system error
+ occurred. GHC ignores @-jsem@ and compiles sequentially.
+
+ The 'BuildingCabalPackage' flag controls whether the diagnostic
+ hint suggests upgrading @cabal-install@ (it only does so when GHC
+ is invoked by Cabal).
+ -}
+ DriverSemaphoreOpenFailure :: !BuildingCabalPackage -> !SemaphoreError -> DriverMessage
+
deriving instance Generic DriverMessage
data DriverMessageOpts =
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -1115,6 +1115,7 @@ data WarningFlag =
| Opt_WarnUnusableUnpackPragmas -- ^ @since 9.14
| Opt_WarnPatternNamespaceSpecifier -- ^ @since 9.14
| Opt_WarnUnrecognisedModifiers -- ^ @since 10.0
+ | Opt_WarnSemaphoreOpenFailure -- Since 10.0.1
deriving (Eq, Ord, Show, Enum, Bounded)
-- | Return the names of a WarningFlag
@@ -1237,6 +1238,7 @@ warnFlagNames wflag = case wflag of
Opt_WarnUnusableUnpackPragmas -> "unusable-unpack-pragmas" :| []
Opt_WarnPatternNamespaceSpecifier -> "pattern-namespace-specifier" :| []
Opt_WarnUnrecognisedModifiers -> "unrecognised-modifiers" :| []
+ Opt_WarnSemaphoreOpenFailure -> "semaphore-open-failure" :| []
-- -----------------------------------------------------------------------------
-- Standard sets of warning options
@@ -1383,7 +1385,8 @@ standardWarnings -- see Note [Documenting warning flags]
Opt_WarnDeprecatedPragmas,
Opt_WarnRuleLhsEqualities,
Opt_WarnUnusableUnpackPragmas,
- Opt_WarnUnrecognisedModifiers
+ Opt_WarnUnrecognisedModifiers,
+ Opt_WarnSemaphoreOpenFailure
]
-- | Things you get with @-W@.
=====================================
compiler/GHC/Driver/MakeAction.hs
=====================================
@@ -28,16 +28,39 @@ import GHC.Driver.Errors.Types
import GHC.Driver.Messager
import GHC.Driver.MakeSem
+#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
+import System.Semaphore
+ ( SemaphoreIdentifier )
+#else
+import System.Semaphore
+ ( SemaphoreError, SemaphoreIdentifier )
+#endif
+
+#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH))
+import GHC.Driver.Config.Diagnostic ( initDiagOpts, initPrintConfig )
+import GHC.Driver.Errors ( printOrThrowDiagnostics )
+import GHC.Types.Error ( singleMessage )
+import GHC.Types.SrcLoc ( noSrcSpan )
+import GHC.Utils.Error ( mkPlainMsgEnvelope )
+#endif
import GHC.Utils.Logger
import GHC.Utils.TmpFs
+#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
+import Control.Concurrent ( ThreadId, killThread, forkIOWithUnmask )
+#else
import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
+#endif
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
import Control.Monad
import qualified Control.Monad.Catch as MC
+#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
+import GHC.Conc ( getNumProcessors )
+#else
import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
+#endif
import Control.Monad.Trans.Reader
import GHC.Driver.Pipeline.LogQueue
import Control.Concurrent.STM
@@ -49,7 +72,7 @@ mkWorkerLimit :: DynFlags -> IO WorkerLimit
mkWorkerLimit dflags =
case parMakeCount dflags of
Nothing -> pure $ num_procs 1
- Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h))
+ Just (ParMakeSemaphore h) -> pure (JSemLimit h)
Just ParMakeNumProcessors -> num_procs <$> getNumProcessors
Just (ParMakeThisMany n) -> pure $ num_procs n
where
@@ -65,8 +88,8 @@ isWorkerLimitSequential (JSemLimit {}) = False
data WorkerLimit
= NumProcessorsLimit Int
| JSemLimit
- SemaphoreName
- -- ^ Semaphore name to use
+ SemaphoreIdentifier
+ -- ^ Semaphore identifier from @-jsem@
deriving Eq
-- | Environment used when compiling a module
@@ -106,6 +129,7 @@ runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines =
}
in runAllPipelines (NumProcessorsLimit 1) env all_pipelines
+#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH))
runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a
runNjobsAbstractSem n_jobs action = do
compile_sem <- newQSem n_jobs
@@ -122,17 +146,26 @@ runNjobsAbstractSem n_jobs action = do
resetNumCapabilities = set_num_caps n_capabilities
MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem
-runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a
-#if defined(wasm32_HOST_ARCH)
-runWorkerLimit _ action = do
+#endif
+
+runWorkerLimit :: Logger -> DynFlags -> WorkerLimit -> (AbstractSem -> IO a) -> IO a
+#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
+runWorkerLimit _logger _dflags _ action = do
lock <- newMVar ()
action $ AbstractSem (takeMVar lock) (putMVar lock ())
#else
-runWorkerLimit worker_limit action = case worker_limit of
+runWorkerLimit logger dflags worker_limit action = case worker_limit of
NumProcessorsLimit n_jobs ->
runNjobsAbstractSem n_jobs action
- JSemLimit sem ->
- runJSemAbstractSem sem action
+ JSemLimit sem_ident -> do
+ result <- MC.try @_ @SemaphoreError $ runJSemAbstractSem sem_ident action
+ case result of
+ Right a -> return a
+ Left err -> do
+ let diag = DriverSemaphoreOpenFailure (checkBuildingCabalPackage dflags) err
+ msg = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag
+ printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg)
+ runNjobsAbstractSem 1 action
#endif
-- | Build and run a pipeline
@@ -159,7 +192,7 @@ runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipeli
thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)
let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }
- runWorkerLimit worker_limit $ \abstract_sem -> do
+ runWorkerLimit (hsc_logger plugin_hsc_env) (hsc_dflags plugin_hsc_env) worker_limit $ \abstract_sem -> do
let env = MakeEnv { hsc_env = thread_safe_hsc_env
, withLogger = withParLog log_queue_queue_var
, compile_sem = abstract_sem
@@ -245,4 +278,4 @@ type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a
data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a))
waitMakeAction :: MakeAction -> IO ()
-waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar
\ No newline at end of file
+waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar
=====================================
compiler/GHC/Driver/MakeSem.hs
=====================================
@@ -1,23 +1,33 @@
{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
-- | Implementation of a jobserver using system semaphores.
--
--
module GHC.Driver.MakeSem
- ( -- * JSem: parallelism semaphore backed
+ (
+#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH))
+ -- * JSem: parallelism semaphore backed
-- by a system semaphore (Posix/Windows)
- runJSemAbstractSem
-
- -- * System semaphores
- , Semaphore, SemaphoreName(..)
+ runJSemAbstractSem,
+#endif
-- * Abstract semaphores
- , AbstractSem(..)
+ AbstractSem(..)
, withAbstractSem
)
where
+#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
+
+import System.Semaphore
+ ( AbstractSem(..)
+ , withAbstractSem
+ )
+
+#else
+
import GHC.Prelude
import GHC.Conc
import GHC.Data.OrdList
@@ -27,6 +37,15 @@ import GHC.Utils.Panic
import GHC.Utils.Json
import System.Semaphore
+ ( AbstractSem(..)
+ , ClientSemaphore
+ , SemaphoreIdentifier
+ , SemaphoreToken
+ , openSemaphore
+ , releaseSemaphoreToken
+ , waitOnSemaphore
+ , withAbstractSem
+ )
import Control.Monad
import qualified Control.Monad.Catch as MC
@@ -46,11 +65,14 @@ import Debug.Trace
-- available from the semaphore.
data Jobserver
= Jobserver
- { jSemaphore :: !Semaphore
+ { jSemaphore :: !ClientSemaphore
-- ^ The semaphore which controls available resources
, jobs :: !(TVar JobResources)
-- ^ The currently pending jobs, and the resources
-- obtained from the semaphore
+ , activeChild :: !(TVar (Maybe (ThreadId, TMVar (Maybe MC.SomeException))))
+ -- ^ Handle on the current acquire thread (if any). The loop's exit
+ -- handler reads this to drain a still-running child on shutdown.
}
data JobserverOptions
@@ -81,6 +103,9 @@ data JobResources
, jobsWaiting :: !(OrdList (TMVar ()))
-- ^ Pending jobs waiting on a token, the job will be blocked on the TMVar so putting into
-- the TMVar will allow the job to continue.
+ , heldTokens :: [SemaphoreToken]
+ -- ^ Actual semaphore tokens (for release/cleanup).
+ -- Length should equal tokensOwned - 1 (the implicit token has no SemaphoreToken).
}
instance Outputable JobResources where
@@ -93,9 +118,9 @@ instance Outputable JobResources where
] )
-- | Add one new token.
-addToken :: JobResources -> JobResources
-addToken jobs@( Jobs { tokensOwned = owned, tokensFree = free })
- = jobs { tokensOwned = owned + 1, tokensFree = free + 1 }
+addToken :: SemaphoreToken -> JobResources -> JobResources
+addToken tok jobs@( Jobs { tokensOwned = owned, tokensFree = free, heldTokens = toks })
+ = jobs { tokensOwned = owned + 1, tokensFree = free + 1, heldTokens = tok : toks }
-- | Free one token.
addFreeToken :: JobResources -> JobResources
@@ -111,12 +136,14 @@ removeFreeToken jobs@( Jobs { tokensFree = free })
(text "removeFreeToken:" <+> ppr free)
$ jobs { tokensFree = free - 1 }
--- | Return one owned token.
-removeOwnedToken :: JobResources -> JobResources
-removeOwnedToken jobs@( Jobs { tokensOwned = owned })
+-- | Return one owned token, extracting the 'SemaphoreToken' for release.
+removeOwnedToken :: JobResources -> (SemaphoreToken, JobResources)
+removeOwnedToken jobs@( Jobs { tokensOwned = owned, heldTokens = toks })
= assertPpr (owned > 1)
(text "removeOwnedToken:" <+> ppr owned)
- $ jobs { tokensOwned = owned - 1 }
+ $ case toks of
+ (t:rest) -> (t, jobs { tokensOwned = owned - 1, heldTokens = rest })
+ [] -> panic "removeOwnedToken: no held tokens"
-- | Add one new job to the end of the list of pending jobs.
addJob :: TMVar () -> JobResources -> JobResources
@@ -143,7 +170,7 @@ data JobserverAction
= Idle
-- | A thread is waiting for a token on the semaphore.
| Acquiring
- { activeWaitId :: WaitId
+ { activeThreadId :: ThreadId
, threadFinished :: TMVar (Maybe MC.SomeException) }
-- | Retrieve the 'TMVar' that signals if the current thread has finished,
@@ -189,17 +216,30 @@ releaseJob jobs_tvar = do
return ((), addFreeToken jobs)
--- | Release all tokens owned from the semaphore (to clean up
--- the jobserver at the end).
-cleanupJobserver :: Jobserver -> IO ()
-cleanupJobserver (Jobserver { jSemaphore = sem
- , jobs = jobs_tvar })
- = do
- Jobs { tokensOwned = owned } <- readTVarIO jobs_tvar
- let toks_to_release = owned - 1
- -- Subtract off the implicit token: whoever spawned the ghc process
- -- in the first place is responsible for that token.
- releaseSemaphore sem toks_to_release
+-- | Kill the current acquire thread, if any, and wait for it to exit.
+--
+-- Called from the jobserver loop's exit handler, which runs masked.
+-- Relies on the invariant from 'acquireThread' that a forked child
+-- always fills its 'threadFinished' TMVar before it dies; this is what
+-- lets the 'takeTMVar' below terminate after the 'killThread'.
+drainActiveChild :: Jobserver -> IO ()
+drainActiveChild (Jobserver { activeChild = active_tvar }) = do
+ mb <- readTVarIO active_tvar
+ for_ mb $ \(tid, tmv) -> do
+ killThread tid
+ void $ atomically (takeTMVar tmv)
+ atomically $ writeTVar active_tvar Nothing
+
+-- | Release every token currently in 'heldTokens'.
+--
+-- Called from the jobserver loop's exit handler, which runs masked,
+-- after 'drainActiveChild': no other thread is mutating 'JobResources'
+-- at this point.
+releaseAllHeld :: Jobserver -> IO ()
+releaseAllHeld (Jobserver { jobs = jobs_tvar }) = do
+ Jobs { heldTokens = toks } <- readTVarIO jobs_tvar
+ forM_ toks $ \t ->
+ void $ MC.try @_ @MC.SomeException (releaseSemaphoreToken t)
-- | Dispatch the available tokens acquired from the semaphore
-- to the pending jobs in the job server.
@@ -252,7 +292,7 @@ tracedAtomically origin act = do
return a
renderJobResources :: String -> JobResources -> String
-renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON $
+renderJobResources origin (Jobs own free pending _heldToks) = showSDocUnsafe $ renderJSON $
JSObject [ ("name", JSString origin)
, ("owned", JSInt own)
, ("free", JSInt free)
@@ -262,61 +302,68 @@ renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON
-- | Spawn a new thread that waits on the semaphore in order to acquire
-- an additional token.
+--
+-- The child is forked masked so the only async-exception delivery point
+-- is the interruptible 'waitOnSemaphore'; the STM commit afterwards then
+-- always runs to completion, so 'threadFinished' is always filled.
+--
+-- The (tid, threadFinished) pair is also published to 'activeChild' so
+-- shutdown can drain the child even after the in-loop 'JobserverState'
+-- is gone.
acquireThread :: Jobserver -> IO JobserverAction
-acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
+acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar, activeChild = active_tvar }) = do
threadFinished_tmvar <- newEmptyTMVarIO
- let
- wait_result_action :: Either MC.SomeException Bool -> IO ()
- wait_result_action wait_res =
+ tid <- MC.mask_ $ do
+ tid <- forkIO $ do
+ wait_res <- MC.try @_ @MC.SomeException $ waitOnSemaphore sem
tracedAtomically_ "acquire_thread" do
(r, jb) <- case wait_res of
Left (e :: MC.SomeException) -> do
return $ (Just e, Nothing)
- Right success -> do
- if success
- then do
- modifyJobResources jobs_tvar \ jobs ->
- return (Nothing, addToken jobs)
- else
- return (Nothing, Nothing)
+ Right tok -> do
+ modifyJobResources jobs_tvar \ jobs ->
+ return (Nothing, addToken tok jobs)
putTMVar threadFinished_tmvar r
return jb
- wait_id <- forkWaitOnSemaphoreInterruptible sem wait_result_action
- labelThread (waitingThreadId wait_id) "acquire_thread"
- return $ Acquiring { activeWaitId = wait_id
+ atomically $ writeTVar active_tvar (Just (tid, threadFinished_tmvar))
+ return tid
+ labelThread tid "acquire_thread"
+ return $ Acquiring { activeThreadId = tid
, threadFinished = threadFinished_tmvar }
-- | Spawn a thread to release ownership of one resource from the semaphore,
-- provided we have spare resources and no pending jobs.
releaseThread :: Jobserver -> IO JobserverAction
-releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
+releaseThread (Jobserver { jobs = jobs_tvar }) = do
threadFinished_tmvar <- newEmptyTMVarIO
MC.mask_ do
-- Pre-release the resource so that another thread doesn't take control of it
-- just as we release the lock on the semaphore.
- still_ok_to_release
+ mb_tok
<- tracedAtomically "pre_release" $
modifyJobResources jobs_tvar \ jobs ->
if guardRelease jobs
- -- TODO: should this also debounce?
- then return (True , removeOwnedToken $ removeFreeToken jobs)
- else return (False, jobs)
- if not still_ok_to_release
- then return Idle
- else do
- tid <- forkIO $ do
- x <- MC.try $ releaseSemaphore sem 1
- tracedAtomically_ "post-release" $ do
- (r, jobs) <- case x of
- Left (e :: MC.SomeException) -> do
- modifyJobResources jobs_tvar \ jobs ->
- return (Just e, addToken jobs)
- Right _ -> do
- return (Nothing, Nothing)
- putTMVar threadFinished_tmvar r
- return jobs
- labelThread tid "release_thread"
- return Idle
+ then let (tok, jobs') = removeOwnedToken $ removeFreeToken jobs
+ in return (Just tok, jobs')
+ else return (Nothing, jobs)
+ case mb_tok of
+ Nothing ->
+ -- Not OK to release: there are other pending jobs that could make use of the token.
+ return Idle
+ Just tok -> do
+ tid <- forkIO $ do
+ x <- MC.try @_ @MC.SomeException $ releaseSemaphoreToken tok
+ tracedAtomically_ "post-release" $ do
+ (r, jobs) <- case x of
+ Left (e :: MC.SomeException) -> do
+ modifyJobResources jobs_tvar \ jobs ->
+ return (Just e, addToken tok jobs)
+ Right _ -> do
+ return (Nothing, Nothing)
+ putTMVar threadFinished_tmvar r
+ return jobs
+ labelThread tid "release_thread"
+ return Idle
-- | When there are pending jobs but no free tokens,
-- spawn a thread to acquire a new token from the semaphore.
@@ -363,13 +410,14 @@ tryRelease _ _ = retry
-- | Wait for an active thread to finish. Once it finishes:
--
-- - set the 'JobserverAction' to 'Idle',
+-- - clear the 'activeChild' handle,
-- - update the number of capabilities to reflect the number
-- of owned tokens from the semaphore.
tryNoticeIdle :: JobserverOptions
- -> TVar JobResources
+ -> Jobserver
-> JobserverState
-> STM (IO JobserverState)
-tryNoticeIdle opts jobs_tvar jobserver_state
+tryNoticeIdle opts (Jobserver { jobs = jobs_tvar, activeChild = active_tvar }) jobserver_state
| Just threadFinished_tmvar <- activeThread_maybe $ jobserverAction jobserver_state
= sync_num_caps (canChangeNumCaps jobserver_state) threadFinished_tmvar
| otherwise
@@ -381,6 +429,7 @@ tryNoticeIdle opts jobs_tvar jobserver_state
sync_num_caps can_change_numcaps_tvar threadFinished_tmvar = do
mb_ex <- takeTMVar threadFinished_tmvar
for_ mb_ex MC.throwM
+ writeTVar active_tvar Nothing
Jobs { tokensOwned } <- readTVar jobs_tvar
can_change_numcaps <- readTVar can_change_numcaps_tvar
guard can_change_numcaps
@@ -404,11 +453,11 @@ tryStopThread :: TVar JobResources
-> STM (IO JobserverState)
tryStopThread jobs_tvar jsj = do
case jobserverAction jsj of
- Acquiring { activeWaitId = wait_id } -> do
+ Acquiring { activeThreadId = tid } -> do
jobs <- readTVar jobs_tvar
guard $ null (jobsWaiting jobs)
return do
- interruptWaitOnSemaphore wait_id
+ killThread tid
return $ jsj { jobserverAction = Idle }
_ -> retry
@@ -430,30 +479,38 @@ jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar })
action <- atomically $ asum $ (\x -> x s) <$>
[ tryRelease sjs
, tryAcquire opts sjs
- , tryNoticeIdle opts jobs_tvar
+ , tryNoticeIdle opts sjs
, tryStopThread jobs_tvar
]
s <- action
loop s
--- | Create a new jobserver using the given semaphore handle.
-makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ())
-makeJobserver sem_name = do
- semaphore <- openSemaphore sem_name
+-- | Create a new jobserver using the given semaphore identifier.
+makeJobserver :: SemaphoreIdentifier -> IO (AbstractSem, IO ())
+makeJobserver sem_ident = do
+ semaphore <- openSemaphore sem_ident >>= either MC.throwM pure
let
init_jobs =
Jobs { tokensOwned = 1
, tokensFree = 1
, jobsWaiting = NilOL
+ , heldTokens = []
}
jobs_tvar <- newTVarIO init_jobs
+ active_tvar <- newTVarIO Nothing
let
opts = defaultJobserverOptions -- TODO: allow this to be configured
- sjs = Jobserver { jSemaphore = semaphore
- , jobs = jobs_tvar }
+ sjs = Jobserver { jSemaphore = semaphore
+ , jobs = jobs_tvar
+ , activeChild = active_tvar }
loop_finished_mvar <- newEmptyMVar
loop_tid <- forkIOWithUnmask \ unmask -> do
r <- try $ unmask $ jobserverLoop opts sjs
+ -- Always-run exit handler: any child the loop spawned is still alive
+ -- in its own thread, so drain it before touching jobs_tvar. No one
+ -- else can mutate the resources once both are dead.
+ drainActiveChild sjs
+ releaseAllHeld sjs
putMVar loop_finished_mvar $
case r of
Left e
@@ -467,8 +524,8 @@ makeJobserver sem_name = do
acquireSem = acquireJob jobs_tvar
releaseSem = releaseJob jobs_tvar
cleanupSem = do
- -- this is interruptible
- cleanupJobserver sjs
+ -- Trigger the loop's exit handler; it drains the active child and
+ -- releases all held tokens, then signals loop_finished_mvar.
killThread loop_tid
mb_ex <- takeMVar loop_finished_mvar
for_ mb_ex MC.throwM
@@ -477,12 +534,12 @@ makeJobserver sem_name = do
-- | Implement an abstract semaphore using a semaphore 'Jobserver'
-- which queries the system semaphore of the given name for resources.
-runJSemAbstractSem :: SemaphoreName -- ^ the system semaphore to use
+runJSemAbstractSem :: SemaphoreIdentifier -- ^ the semaphore identifier (from @-jsem@)
-> (AbstractSem -> IO a) -- ^ the operation to run
-- which requires a semaphore
-> IO a
-runJSemAbstractSem sem action = MC.mask \ unmask -> do
- (abs, cleanup) <- makeJobserver sem
+runJSemAbstractSem sem_ident action = MC.mask \ unmask -> do
+ (abs, cleanup) <- makeJobserver sem_ident
r <- try $ unmask $ action abs
case r of
Left (e1 :: MC.SomeException) -> do
@@ -517,8 +574,13 @@ increases the number of `free` jobs. If there are more pending jobs when the fre
is increased, the token is immediately reused (see `modifyJobResources`).
The `jobServerLoop` interacts with the system semaphore: when there are pending
-jobs, `acquireThread` blocks, waiting for a token from the semaphore. Once a
-token is obtained, it increases the owned count.
+jobs, `acquireThread` forks a child that calls the interruptible
+`waitOnSemaphore`. The child is forked in the masked state, so the only place
+an async exception can be delivered is the wait itself; once the wait returns,
+the child's STM commit always completes, recording either the new token in
+`heldTokens` or the failure exception in `threadFinished`. The (tid, tmvar)
+pair is also published in `activeChild` so the loop's exit handler can drain
+the child on shutdown even after the in-loop `JobserverState` is gone.
When GHC has free tokens (tokens from the semaphore that it is not using),
no pending jobs, and the debounce has expired, then `releaseThread` will
@@ -531,6 +593,12 @@ This second token is no longer needed, so we should cancel the wait
(as it would not be used to do any work, and not be returned until the debounce).
We only need to kill `acquireJob`, because `releaseJob` never blocks.
+Shutdown starts with `killThread loop_tid`. The loop's exit handler then
+runs `drainActiveChild` followed by `releaseAllHeld`; only then does the
+loop signal `loop_finished_mvar`. This sequence makes the heldTokens
+snapshot consistent because no other thread can mutate it once the loop and
+its child are both dead.
+
Note [Eventlog Messages for jsem]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It can be tricky to verify that the work is shared adequately across different
@@ -540,3 +608,5 @@ to analyse this output and report statistics about core saturation in the
GitHub repo (https://github.com/mpickering/ghc-jsem-analyse)
-}
+
+#endif
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -289,6 +289,8 @@ import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )
import GHC.Toolchain
import GHC.Toolchain.Program
+import System.Semaphore ( getSemaphoreProtocolVersion, semaphoreVersion )
+
import Data.IORef
import Control.Arrow ((&&&))
import Control.Monad
@@ -2445,6 +2447,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of
Opt_WarnUnusableUnpackPragmas -> warnSpec x
Opt_WarnPatternNamespaceSpecifier -> warnSpec x
Opt_WarnUnrecognisedModifiers -> warnSpec x
+ Opt_WarnSemaphoreOpenFailure -> warnSpec x
warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]
warningGroupsDeps = map mk warningGroups
@@ -3628,6 +3631,8 @@ compilerInfo dflags
("Support dynamic-too", showBool $ not isWindows),
-- Whether or not we support the @-j@ flag with @--make@.
("Support parallel --make", "YES"),
+ -- The semaphore protocol version supported by @-jsem@.
+ ("Semaphore version", show (getSemaphoreProtocolVersion semaphoreVersion)),
-- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in
-- installed package info.
("Support reexported-modules", "YES"),
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -403,6 +403,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "DriverInstantiationNodeInDependencyGeneration" = 74284
GhcDiagnosticCode "DriverNoConfiguredLLVMToolchain" = 66599
GhcDiagnosticCode "DriverMissingLinkableForModule" = 47338
+ GhcDiagnosticCode "DriverSemaphoreOpenFailure" = 19877
-- Constraint solver diagnostic codes
GhcDiagnosticCode "BadTelescope" = 97739
=====================================
compiler/GHC/Types/Hint.hs
=====================================
@@ -11,6 +11,7 @@ module GHC.Types.Hint (
, StarIsType(..)
, UntickedPromotedThing(..)
, AssumedDerivingStrategy(..)
+ , SemaphoreUpgradeTarget(..)
, SigLike(..)
, pprUntickedConstructor, isBareSymbol
, suggestExtension
@@ -538,6 +539,28 @@ data GhcHint
{-| Suggest adding signature to modifier -}
| SuggestModifierSignature (HsModifier GhcRn) Name
+ {-| Suggest upgrading either the @-jsem@ jobserver or GHC itself to
+ support the given semaphore protocol version.
+
+ Triggered by 'GHC.Driver.Errors.Types.DriverSemaphoreOpenFailure'
+ carrying a 'System.Semaphore.SemaphoreIncompatibleVersion'.
+ -}
+ | SuggestUpgradeForSemaphoreVersionMismatch !SemaphoreUpgradeTarget !Int
+ -- ^ The 'Int' is the required protocol version.
+
+-- | What the user should upgrade to resolve an @-jsem@ semaphore
+-- protocol version mismatch.
+data SemaphoreUpgradeTarget
+ = UpgradeCabalInstall
+ -- ^ Jobserver is @cabal-install@ (we are building a Cabal package)
+ -- and speaks an older protocol than GHC.
+ | UpgradeJobserver
+ -- ^ Jobserver (not @cabal-install@) speaks an older protocol than
+ -- GHC.
+ | UpgradeGHC
+ -- ^ Jobserver speaks a newer protocol than GHC.
+ deriving (Eq, Show)
+
-- | The deriving strategy that was assumed when not explicitly listed in the
-- source. This is used solely by the missing-deriving-strategies warning.
-- There's no `Via` case because we never assume that.
=====================================
compiler/GHC/Types/Hint/Ppr.hs
=====================================
@@ -306,6 +306,20 @@ instance Outputable GhcHint where
(text "Perhaps it should have a kind signature, like")
2
(hsep [text "%(" <> ppr ty, text "::", ppr name <> text ")"])
+ SuggestUpgradeForSemaphoreVersionMismatch target required
+ -> case target of
+ UpgradeCabalInstall ->
+ text "The cabal-install jobserver uses an older semaphore protocol."
+ $$ (text "Upgrade cabal-install to a version that supports semaphore protocol v"
+ <> int required <> text " to resolve this.")
+ UpgradeJobserver ->
+ text "The jobserver uses an older semaphore protocol."
+ $$ (text "Upgrade it to a version that supports semaphore protocol v"
+ <> int required <> text " to resolve this.")
+ UpgradeGHC ->
+ text "The jobserver uses a newer semaphore protocol than this GHC."
+ $$ (text "Upgrade GHC to a version that supports semaphore protocol v"
+ <> int required <> text " to resolve this.")
perhapsAsPat :: SDoc
perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
=====================================
docs/users_guide/using-warnings.rst
=====================================
@@ -2721,6 +2721,23 @@ of ``-W(no-)*``.
f :: a %True -> a
g :: a %(k :: Int) -> a
+.. ghc-flag:: -Wsemaphore-open-failure
+ :shortdesc: warn when GHC cannot open the ``-jsem`` semaphore.
+ :type: dynamic
+ :reverse: -Wno-semaphore-open-failure
+ :category:
+
+ :since: 10.0.1
+
+ Warn when GHC is invoked with :ghc-flag:`-jsem` but the semaphore
+ cannot be opened (e.g. the socket does not exist, the protocol
+ version is incompatible, or a system error occurred). When this
+ occurs, GHC ignores ``-jsem`` and compiles modules sequentially.
+
+ A common cause is ``cabal-install`` and GHC being built against
+ different versions of the ``semaphore-compat`` library; upgrading
+ both to versions that use the same protocol resolves the mismatch.
+
----
If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice.
=====================================
docs/users_guide/using.rst
=====================================
@@ -797,7 +797,12 @@ There are two kinds of participants in the GHC Jobserver protocol:
Perform compilation in parallel when possible, coordinating with other
processes through the semaphore ⟨sem⟩ (specified as a string).
- Error if the semaphore doesn't exist.
+
+ If the semaphore cannot be opened (e.g. the socket does not exist
+ or its protocol version is incompatible with this GHC), GHC emits
+ a :ghc-flag:`-Wsemaphore-open-failure` warning and compiles
+ sequentially, using only the implicit token inherited from the
+ parent process.
Use of ``-jsem`` will override use of :ghc-flag:`-j[⟨n⟩]`,
and vice-versa.
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -149,10 +149,6 @@ werror =
-- unix has many unused imports
, package unix
? mconcat [arg "-Wwarn=unused-imports", arg "-Wwarn=unused-top-binds"]
- -- semaphore-compat relies on sem_getvalue as provided by unix, which is
- -- not implemented on Darwin and therefore throws a deprecation warning
- , package semaphoreCompat
- ? mconcat [arg "-Wwarn=deprecations"]
]
, builder Ghc
? package rts
=====================================
libraries/semaphore-compat
=====================================
@@ -1 +1 @@
-Subproject commit 7929702401d49bc64d809c501ed5fe80aebc3cc1
+Subproject commit baa6d17eadcb88f5b0300dfaf6ca510374ffc8e7
=====================================
testsuite/tests/diagnostic-codes/codes.stdout
=====================================
@@ -21,6 +21,7 @@
[GHC-29747] is untested (constructor = DriverMissingSafeHaskellMode)
[GHC-74284] is untested (constructor = DriverInstantiationNodeInDependencyGeneration)
[GHC-66599] is untested (constructor = DriverNoConfiguredLLVMToolchain)
+[GHC-19877] is untested (constructor = DriverSemaphoreOpenFailure)
[GHC-81325] is untested (constructor = ExpectingMoreArguments)
[GHC-78125] is untested (constructor = AmbiguityPreventsSolvingCt)
[GHC-84170] is untested (constructor = TcRnModMissingRealSrcSpan)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1170e99240b04e9e4013d31ccea9f84…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1170e99240b04e9e4013d31ccea9f84…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] rts: add a few missing i386 relocations in the rts linker
by Magnus (＠MangoIV) 22 May '26
by Magnus (＠MangoIV) 22 May '26
22 May '26
Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC
Commits:
df48432e by Luite Stegeman at 2026-05-22T11:54:49+02:00
rts: add a few missing i386 relocations in the rts linker
(cherry picked from commit 04d143c02e82e9ca03eb75849959d369d07fb81a)
- - - - -
2 changed files:
- rts/linker/Elf.c
- testsuite/tests/th/all.T
Changes:
=====================================
rts/linker/Elf.c
=====================================
@@ -1308,6 +1308,16 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
case COMPAT_R_386_NONE: break;
case COMPAT_R_386_32: *pP = value; break;
case COMPAT_R_386_PC32: *pP = value - P; break;
+ case COMPAT_R_386_PLT32: *pP = value - P; break;
+ case COMPAT_R_386_GOTOFF: *pP = value - (Elf_Addr)oc->info->got_start; break;
+ case COMPAT_R_386_GOTPC: *pP = (Elf_Addr)oc->info->got_start + A - P; break;
+ case COMPAT_R_386_GOT32:
+ case COMPAT_R_386_GOT32X:
+ CHECK(symbol);
+ CHECK(symbol->got_addr);
+ *pP = (Elf_Addr)symbol->got_addr
+ - (Elf_Addr)oc->info->got_start + A;
+ break;
# endif
# if defined(arm_HOST_ARCH)
=====================================
testsuite/tests/th/all.T
=====================================
@@ -626,7 +626,6 @@ test('T25209', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('TH_MultilineStrings', normal, compile_and_run, [''])
test('T25252',
[extra_files(['T25252B.hs', 'T25252_c.c']),
- when(arch('i386'), expect_broken_for(25260,['ext-interp'])),
req_th,
req_c],
compile_and_run, ['-fPIC T25252_c.c'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df48432ec29980947c039311a78b537…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df48432ec29980947c039311a78b537…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/ghc-internal-def] TMP: CI: do only x86_64-windows-validate
by David Eichmann (＠DavidEichmann) 22 May '26
by David Eichmann (＠DavidEichmann) 22 May '26
22 May '26
David Eichmann pushed to branch wip/davide/ghc-internal-def at Glasgow Haskell Compiler / GHC
Commits:
eee0b5c3 by David Eichmann at 2026-05-22T10:50:15+01:00
TMP: CI: do only x86_64-windows-validate
- - - - -
28 changed files:
- .gitlab-ci.yml
- .gitlab/jobs.yaml
- libraries/Cabal
- libraries/array
- libraries/deepseq
- libraries/directory
- libraries/exceptions
- libraries/file-io
- libraries/filepath
- libraries/haskeline
- libraries/hpc
- libraries/libffi-clib
- libraries/mtl
- libraries/os-string
- libraries/parsec
- libraries/process
- libraries/semaphore-compat
- libraries/stm
- libraries/template-haskell-lift
- libraries/template-haskell-quasiquoter
- libraries/terminfo
- libraries/text
- libraries/transformers
- libraries/unix
- libraries/xhtml
- nofib
- utils/hpc
- utils/hsc2hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eee0b5c376b09b9502dcb53d53d8767…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eee0b5c376b09b9502dcb53d53d8767…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/ghc-internal-def] TMP: CI: do only x86_64-windows-validate
by David Eichmann (＠DavidEichmann) 22 May '26
by David Eichmann (＠DavidEichmann) 22 May '26
22 May '26
David Eichmann pushed to branch wip/davide/ghc-internal-def at Glasgow Haskell Compiler / GHC
Commits:
cf355321 by David Eichmann at 2026-05-22T10:44:53+01:00
TMP: CI: do only x86_64-windows-validate
- - - - -
27 changed files:
- .gitlab/jobs.yaml
- libraries/Cabal
- libraries/array
- libraries/deepseq
- libraries/directory
- libraries/exceptions
- libraries/file-io
- libraries/filepath
- libraries/haskeline
- libraries/hpc
- libraries/libffi-clib
- libraries/mtl
- libraries/os-string
- libraries/parsec
- libraries/process
- libraries/semaphore-compat
- libraries/stm
- libraries/template-haskell-lift
- libraries/template-haskell-quasiquoter
- libraries/terminfo
- libraries/text
- libraries/transformers
- libraries/unix
- libraries/xhtml
- nofib
- utils/hpc
- utils/hsc2hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf355321b6ccd8ec2f8ae43643e3cc0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf355321b6ccd8ec2f8ae43643e3cc0…
You're receiving this email because of your account on gitlab.haskell.org.
1
0