maralorn pushed new branch wip/bump-emscripten at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/bump-emscripten
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Fix various failures to -fprint-unicode-syntax
by Marge Bot (＠marge-bot) 11 Jun '25
by Marge Bot (＠marge-bot) 11 Jun '25
11 Jun '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
e2467dbd by Ryan Hendrickson at 2025-06-09T13:07:05-04:00
Fix various failures to -fprint-unicode-syntax
- - - - -
b4e3515f by meooow25 at 2025-06-11T05:22:03-04:00
Bump containers submodule to 0.8
Also
* Allow containers-0.8 for in-tree packages
* Bump some submodules so that they allow containers-0.8. These are not
at any particular versions.
* Remove unused deps containers and split from ucd2haskell
* Fix tests affected by the new containers and hpc-bin
- - - - -
9fe60c79 by maralorn at 2025-06-11T05:22:07-04:00
Add necessary flag for js linking
- - - - -
6a0a015f by maralorn at 2025-06-11T05:22:07-04:00
Don’t use additional linker flags to detect presence of -fno-pie in configure.ac
This mirrors the behavior of ghc-toolchain
- - - - -
36 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/ghc.cabal.in
- ghc/ghc-bin.cabal.in
- hadrian/hadrian.cabal
- libraries/containers
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-internal/tools/ucd2haskell/ucd2haskell.cabal
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- libraries/hpc
- m4/fp_gcc_supports_no_pie.m4
- m4/fptools_set_c_ld_flags.m4
- testsuite/tests/ghci/scripts/T12550.stdout
- testsuite/tests/ghci/scripts/T8959b.stderr
- testsuite/tests/ghci/scripts/all.T
- + testsuite/tests/ghci/scripts/print-unicode-syntax.script
- + testsuite/tests/ghci/scripts/print-unicode-syntax.stderr
- + testsuite/tests/ghci/scripts/print-unicode-syntax.stdout
- testsuite/tests/ghci/should_run/T11825.stdout
- testsuite/tests/hpc/fork/hpc_fork.stdout
- testsuite/tests/hpc/function/tough.stdout
- testsuite/tests/hpc/function2/tough2.stdout
- testsuite/tests/hpc/simple/hpc001.stdout
- testsuite/tests/partial-sigs/should_fail/T10999.stderr
- testsuite/tests/rebindable/DoRestrictedM.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs
- utils/haddock/haddock-library/haddock-library.cabal
- utils/hpc
- utils/hsc2hs
- utils/iserv/iserv.cabal.in
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/70cdcb7bd5704e01fb5e254490da7c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/70cdcb7bd5704e01fb5e254490da7c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/libffi-3.5.0] 3 commits: Hadrian: Add option to generate .hie files for stage1 libraries
by Cheng Shao (＠TerrorJack) 11 Jun '25
by Cheng Shao (＠TerrorJack) 11 Jun '25
11 Jun '25
Cheng Shao pushed to branch wip/libffi-3.5.0 at Glasgow Haskell Compiler / GHC
Commits:
35826d8b by Matthew Pickering at 2025-06-08T22:00:41+01:00
Hadrian: Add option to generate .hie files for stage1 libraries
The +hie_files flavour transformer can be enabled to produce hie files
for stage1 libraries. The hie files are produced in the
"extra-compilation-artifacts" folder and copied into the resulting
bindist.
At the moment the hie files are not produced for the release flavour,
they add about 170M to the final bindist.
Towards #16901
- - - - -
e2467dbd by Ryan Hendrickson at 2025-06-09T13:07:05-04:00
Fix various failures to -fprint-unicode-syntax
- - - - -
4ebbaf16 by Cheng Shao at 2025-06-11T03:59:52+00:00
libffi: update to 3.5.1
Bumps libffi submodule.
- - - - -
23 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Parser/PostProcess.hs
- hadrian/doc/flavours.md
- hadrian/doc/user-settings.md
- hadrian/src/Context.hs
- hadrian/src/Context/Path.hs
- hadrian/src/Flavour.hs
- hadrian/src/Flavour/Type.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Flavours/Release.hs
- libffi-tarballs
- testsuite/tests/ghci/scripts/T12550.stdout
- testsuite/tests/ghci/scripts/T8959b.stderr
- testsuite/tests/ghci/scripts/all.T
- + testsuite/tests/ghci/scripts/print-unicode-syntax.script
- + testsuite/tests/ghci/scripts/print-unicode-syntax.stderr
- + testsuite/tests/ghci/scripts/print-unicode-syntax.stdout
- testsuite/tests/ghci/should_run/T11825.stdout
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -627,9 +627,9 @@ instance (OutputableBndrId l, OutputableBndrId r)
GhcTc -> ppr v
ppr_rhs = case dir of
- Unidirectional -> ppr_simple (text "<-")
+ Unidirectional -> ppr_simple larrow
ImplicitBidirectional -> ppr_simple equals
- ExplicitBidirectional mg -> ppr_simple (text "<-") <+> text "where" $$
+ ExplicitBidirectional mg -> ppr_simple larrow <+> text "where" $$
(nest 2 $ pprFunBind mg)
pprTicks :: SDoc -> SDoc -> SDoc
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -699,7 +699,7 @@ instance OutputableBndrId p
TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr
pp_inj = case mb_inj of
Just (L _ (InjectivityAnn _ lhs rhs)) ->
- hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
+ hsep [ vbar, ppr lhs, arrow, hsep (map ppr rhs) ]
Nothing -> empty
(pp_where, pp_eqns) = case info of
ClosedTypeFamily mb_eqns ->
@@ -868,7 +868,7 @@ instance OutputableBndrId p
instance OutputableBndrId p
=> Outputable (StandaloneKindSig (GhcPass p)) where
ppr (StandaloneKindSig _ v ki)
- = text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki
+ = text "type" <+> pprPrefixOcc (unLoc v) <+> dcolon <+> ppr ki
pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc
pp_condecls cs
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -956,7 +956,7 @@ ppr_expr (HsIf _ e1 e2 e3)
ppr_expr (HsMultiIf _ alts)
= hang (text "if") 3 (vcat $ toList $ NE.map ppr_alt alts)
where ppr_alt (L _ (GRHS _ guards expr)) =
- hang vbar 2 (hang (interpp'SP guards) 2 (text "->" <+> pprDeeper (ppr expr)))
+ hang vbar 2 (hang (interpp'SP guards) 2 (arrow <+> pprDeeper (ppr expr)))
ppr_alt (L _ (XGRHS x)) = ppr x
-- special case: let ... in let ...
@@ -1029,7 +1029,7 @@ ppr_expr (HsUntypedBracket b q)
ppr rnq `ppr_with_pending_tc_splices` ps
ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
- = hsep [text "proc", ppr pat, text "->", ppr cmd]
+ = hsep [text "proc", ppr pat, arrow, ppr cmd]
ppr_expr (HsStatic _ e)
= hsep [text "static", ppr e]
@@ -1844,10 +1844,10 @@ pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
matchSeparator :: HsMatchContext fn -> SDoc
matchSeparator FunRhs{} = text "="
-matchSeparator CaseAlt = text "->"
-matchSeparator LamAlt{} = text "->"
-matchSeparator IfAlt = text "->"
-matchSeparator ArrowMatchCtxt{} = text "->"
+matchSeparator CaseAlt = arrow
+matchSeparator LamAlt{} = arrow
+matchSeparator IfAlt = arrow
+matchSeparator ArrowMatchCtxt{} = arrow
matchSeparator PatBindRhs = text "="
matchSeparator PatBindGuards = text "="
matchSeparator StmtCtxt{} = text "<-"
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -1377,7 +1377,7 @@ pprIfaceDecl ss decl@(IfaceFamily { ifName = tycon
pp_inj_cond res inj = case filterByList inj binders of
[] -> empty
- tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)]
+ tvs -> hsep [vbar, ppr res, arrow, interppSP (map ifTyConBinderName tvs)]
pp_rhs IfaceDataFamilyTyCon
= ppShowIface ss (text "data")
@@ -1464,7 +1464,7 @@ pprRoles suppress_if tyCon bndrs roles
text "type role" <+> tyCon <+> hsep (map ppr froles)
pprStandaloneKindSig :: SDoc -> IfaceType -> SDoc
-pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> text "::" <+> ppr ty
+pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> dcolon <+> ppr ty
pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc
pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1747,7 +1747,7 @@ pprTyTcApp ctxt_prec tc tys =
, IA_Arg (IfaceLitTy (IfaceStrTyLit n))
Required (IA_Arg ty Required IA_Nil) <- tys
-> maybeParen ctxt_prec funPrec
- $ char '?' <> ftext (getLexicalFastString n) <> text "::" <> ppr_ty topPrec ty
+ $ char '?' <> ftext (getLexicalFastString n) <> dcolon <> ppr_ty topPrec ty
| IfaceTupleTyCon arity sort <- ifaceTyConSort info
, not debug
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1935,7 +1935,7 @@ instance DisambECP (HsCmd GhcPs) where
mkHsLitPV (L l a) = cmdFail l (ppr a)
mkHsOverLitPV (L l a) = cmdFail (locA l) (ppr a)
mkHsWildCardPV l = cmdFail l (text "_")
- mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig)
+ mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> dcolon <+> ppr sig)
mkHsExplicitListPV l xs _ = cmdFail l $
brackets (pprWithCommas ppr xs)
mkHsSplicePV (L l sp) = cmdFail l (pprUntypedSplice True Nothing sp)
=====================================
hadrian/doc/flavours.md
=====================================
@@ -334,6 +334,8 @@ The supported transformers are listed below:
<td>Disable including self-recompilation information in interface files via <code>-fno-write-if-self-recomp</code>. If you are building a distribution you can enable this flag to produce more deterministic interface files.</td>
<td><code>hash_unit_ids</code></td>
<td>Include a package hash in the unit id of built packages</td>
+ <td><code>hie_files</code></td>
+ <td>Produce hie files for stage1 libraries</td>
</tr>
</table>
=====================================
hadrian/doc/user-settings.md
=====================================
@@ -47,7 +47,10 @@ data Flavour = Flavour {
-> Bool,
-- | Whether to build docs and which ones
-- (haddocks, user manual, haddock manual)
- ghcDocs :: Action DocTargets }
+ ghcDocs :: Action DocTargets,
+ -- | Whether to generate .hie files
+ ghcHieFiles :: Stage -> Bool
+ }
```
Hadrian provides several built-in flavours (`default`, `quick`, and a few
others; see `hadrian/doc/flavours.md`), which can be activated from the command line,
@@ -364,6 +367,13 @@ all of the documentation targets:
You can pass several `--docs=...` flags, Hadrian will combine
their effects.
+### HIE files
+
+The `ghcHieFiles` field controls whether `.hie` files are generated
+for source files built with the stage1 compiler.
+
+For most flavours `.hie` files wil be generated by default.
+
### Split sections
You can build all or just a few packages with
=====================================
hadrian/src/Context.hs
=====================================
@@ -3,7 +3,7 @@ module Context (
Context (..), vanillaContext, stageContext,
-- * Expressions
- getStage, getPackage, getWay, getBuildPath, getPackageDbLoc, getStagedTarget,
+ getStage, getPackage, getWay, getBuildPath, getHieBuildPath, getPackageDbLoc, getStagedTarget,
-- * Paths
contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile, pkgSetupConfigDir,
=====================================
hadrian/src/Context/Path.hs
=====================================
@@ -42,6 +42,10 @@ buildPath context = buildRoot <&> (-/- buildDir context)
getBuildPath :: Expr Context b FilePath
getBuildPath = expr . buildPath =<< getContext
+-- | The output directory for hie files
+getHieBuildPath :: Expr Context b FilePath
+getHieBuildPath = (-/- "extra-compilation-artifacts" -/- "hie") <$> getBuildPath
+
-- | Path to the directory containing haddock timing files, used by
-- the haddock perf tests.
haddockStatsFilesDir :: Action FilePath
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -21,6 +21,7 @@ module Flavour
, enableHiCore
, useNativeBignum
, enableTextWithSIMDUTF
+ , enableHieFiles
, omitPragmas
, completeSetting
@@ -75,6 +76,7 @@ flavourTransformers = M.fromList
, "boot_nonmoving_gc" =: enableBootNonmovingGc
, "dump_stg" =: enableDumpStg
, "hash_unit_ids" =: enableHashUnitIds
+ , "hie_files" =: enableHieFiles
]
where (=:) = (,)
@@ -324,6 +326,9 @@ enableTextWithSIMDUTF flavour = flavour {
enableHashUnitIds :: Flavour -> Flavour
enableHashUnitIds flavour = flavour { hashUnitIds = True }
+enableHieFiles :: Flavour -> Flavour
+enableHieFiles flavour = flavour { ghcHieFiles = (>= Stage1) }
+
-- | Build stage2 compiler with -fomit-interface-pragmas to reduce
-- recompilation.
omitPragmas :: Flavour -> Flavour
=====================================
hadrian/src/Flavour/Type.hs
=====================================
@@ -51,7 +51,10 @@ data Flavour = Flavour {
ghcDocs :: Action DocTargets,
-- | Whether to uses hashes or inplace for unit ids
- hashUnitIds :: Bool
+ hashUnitIds :: Bool,
+
+ -- | Whether to generate .hie files
+ ghcHieFiles :: Stage -> Bool
}
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -35,6 +35,9 @@ compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
useColor <- shakeColor <$> expr getShakeOptions
let hasVanilla = elem vanilla ways
hasDynamic = elem dynamic ways
+ hieFiles <- ghcHieFiles <$> expr flavour
+ stage <- getStage
+ hie_path <- getHieBuildPath
mconcat [ arg "-Wall"
, arg "-Wcompat"
, not useColor ? builder (Ghc CompileHs) ?
@@ -49,6 +52,10 @@ compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
, ghcLinkArgs
, defaultGhcWarningsArgs
, builder (Ghc CompileHs) ? arg "-c"
+ , hieFiles stage ? builder (Ghc CompileHs) ? mconcat
+ [ arg "-fwrite-ide-info"
+ , arg "-hiedir", arg hie_path
+ ]
, getInputs
, arg "-o", arg =<< getOutput ]
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -283,6 +283,7 @@ defaultFlavour = Flavour
, ghcDebugAssertions = const False
, ghcSplitSections = False
, ghcDocs = cmdDocsArgs
+ , ghcHieFiles = const False
, hashUnitIds = False }
-- | Default logic for determining whether to build
=====================================
hadrian/src/Settings/Flavours/Release.hs
=====================================
@@ -11,4 +11,6 @@ releaseFlavour =
$ enableHaddock
-- 3. Include unit id hashes
$ enableHashUnitIds
+ -- 4. Include hie files (#16901)
+ -- $ enableHieFiles
$ performanceFlavour { name = "release" }
=====================================
libffi-tarballs
=====================================
@@ -1 +1 @@
-Subproject commit ac7fa3132d382056837cad297ab4c66418febb69
+Subproject commit 1a5955e69b7b139b066cc31507676afc24959dbd
=====================================
testsuite/tests/ghci/scripts/T12550.stdout
=====================================
@@ -11,13 +11,13 @@ f ∷ ∀ (a ∷ ★ → ★) b. C a ⇒ a b
f ∷ ∀ (a ∷ ★ → ★) b. C a ⇒ a b
f ∷ ∀ (a ∷ ★ → ★) b. C a ⇒ a b
fmap ∷ ∀ (f ∷ ★ → ★) a b. Functor f ⇒ (a → b) → f a → f b
-type Functor :: (★ → ★) → Constraint
+type Functor ∷ (★ → ★) → Constraint
class Functor f where
fmap ∷ ∀ a b. (a → b) → f a → f b
...
-- Defined in ‘GHC.Internal.Base’
Functor ∷ (★ → ★) → Constraint
-type Functor :: (★ → ★) → Constraint
+type Functor ∷ (★ → ★) → Constraint
class Functor f where
fmap ∷ ∀ a b. (a → b) → f a → f b
(<$) ∷ ∀ a b. a → f b → f a
@@ -77,7 +77,7 @@ datatypeName
(a ∷ k1).
Datatype d ⇒
t d f a → [Char]
-type Datatype :: ∀ {k}. k → Constraint
+type Datatype ∷ ∀ {k}. k → Constraint
class Datatype d where
datatypeName ∷ ∀ k1 (t ∷ k → (k1 → ★) → k1 → ★) (f ∷ k1 → ★)
(a ∷ k1).
=====================================
testsuite/tests/ghci/scripts/T8959b.stderr
=====================================
@@ -1,4 +1,3 @@
-
T8959b.hs:5:7: error: [GHC-83865]
• Couldn't match expected type ‘Int → Int’ with actual type ‘()’
• In the expression: ()
@@ -6,11 +5,12 @@ T8959b.hs:5:7: error: [GHC-83865]
T8959b.hs:8:7: error: [GHC-83865]
• Couldn't match expected type ‘()’ with actual type ‘t0 → m0 t0’
- • In the expression: proc x -> do return ⤙ x
- In an equation for ‘bar’: bar = proc x -> do return ⤙ x
+ • In the expression: proc x → do return ⤙ x
+ In an equation for ‘bar’: bar = proc x → do return ⤙ x
T8959b.hs:10:7: error: [GHC-83865]
• Couldn't match expected type ‘(∀ a. a → a) → a1’
with actual type ‘()’
• In the expression: () ∷ (∀ a. a → a) → a
In an equation for ‘baz’: baz = () ∷ (∀ a. a → a) → a
+
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -357,6 +357,7 @@ test('T20101', normal, ghci_script, ['T20101.script'])
test('T20206', normal, ghci_script, ['T20206.script'])
test('T20217', normal, ghci_script, ['T20217.script'])
test('T20455', normal, ghci_script, ['T20455.script'])
+test('print-unicode-syntax', normal, ghci_script, ['print-unicode-syntax.script'])
test('shadow-bindings', normal, ghci_script, ['shadow-bindings.script'])
test('T925', normal, ghci_script, ['T925.script'])
test('T7388', normal, ghci_script, ['T7388.script'])
=====================================
testsuite/tests/ghci/scripts/print-unicode-syntax.script
=====================================
@@ -0,0 +1,44 @@
+:set -fprint-unicode-syntax
+:set -XArrows -XImplicitParams -XMultiWayIf -XPatternSynonyms -XTemplateHaskell -XTypeFamilyDependencies
+
+---------------------------------------
+-- Double-colon checks
+
+import Data.Kind
+[d| type Foo :: Type |]
+
+:{
+foo :: (?imp :: Int) => Int
+foo = ?imp
+:}
+:t foo
+
+proc x -> (_ -< _) :: _
+
+---------------------------------------
+-- Rightwards arrow checks
+
+[d| type family Foo a = b | b -> c |]
+
+type family Foo a = b | b -> a
+:i Foo
+
+\_ -> [] 0
+
+case () of [] -> 0
+
+if | [] -> 0
+
+:{
+if | True -> 0
+ | True -> 1
+:}
+
+proc _ -> \_ -> undefined -< 0
+
+---------------------------------------
+-- Leftwards arrow checks
+
+[d| pattern Foo x <- Nothing |]
+
+[d| pattern Foo x <- Nothing where Foo _ = Nothing |]
=====================================
testsuite/tests/ghci/scripts/print-unicode-syntax.stderr
=====================================
@@ -0,0 +1,56 @@
+<interactive>:8:10: error: [GHC-44432]
+ • The standalone kind signature for ‘Foo’
+ lacks an accompanying binding
+ • In the Template Haskell quotation: [d| type Foo ∷ Type |]
+
+<interactive>:16:11: error: [GHC-03790]
+ Parse error in command: (_ ⤙ _) ∷ _
+
+<interactive>:21:5: error: [GHC-76037]
+ • Not in scope: type variable ‘c’
+ • In the Template Haskell quotation:
+ [d| type family Foo a = b | b → c |]
+
+<interactive>:26:7: error: [GHC-83865]
+ • Couldn't match expected type: t0 → t
+ with actual type: [a0]
+ • The function ‘[]’ is applied to one visible argument,
+ but its type ‘[a]’ has none
+ In the expression: [] 0
+ In the expression: \ _ → [] 0
+ • Relevant bindings include
+ it ∷ p → t (bound at <interactive>:26:1)
+
+<interactive>:28:12: error: [GHC-83865]
+ • Couldn't match expected type ‘()’ with actual type ‘[a0]’
+ • In the pattern: []
+ In a case alternative: [] → 0
+ In the expression: case () of [] → 0
+
+<interactive>:30:6: error: [GHC-83865]
+ • Couldn't match expected type ‘Bool’ with actual type ‘[a0]’
+ • In the expression: []
+ In a stmt of a pattern guard for
+ a multi-way if alternative:
+ []
+ In the expression: if | [] → 0
+
+<interactive>:34:6: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a multi-way if alternative: | True → ...
+
+<interactive>:37:11: error: [GHC-83865]
+ • Couldn't match expected type ‘()’ with actual type ‘(a0, b0)’
+ • In the expression: proc _ → \ _ → undefined ⤙ 0
+ In an equation for ‘it’: it = proc _ → \ _ → undefined ⤙ 0
+
+<interactive>:42:17: error: [GHC-76037]
+ • Not in scope: ‘x’
+ • In the Template Haskell quotation: [d| pattern Foo x ← Nothing |]
+
+<interactive>:44:17: error: [GHC-76037]
+ • Not in scope: ‘x’
+ • In the Template Haskell quotation:
+ [d| pattern Foo x ← Nothing where
+ Foo _ = Nothing |]
+
=====================================
testsuite/tests/ghci/scripts/print-unicode-syntax.stdout
=====================================
@@ -0,0 +1,5 @@
+foo ∷ (?imp∷Int) ⇒ Int
+type Foo ∷ ★ → ★
+type family Foo a = b | b → a
+ -- Defined at <interactive>:23:1
+0
=====================================
testsuite/tests/ghci/should_run/T11825.stdout
=====================================
@@ -1,4 +1,4 @@
-type X :: ★ → ★ → Constraint
+type X ∷ ★ → ★ → Constraint
class X a b | a → b where
to ∷ a → b
{-# MINIMAL to #-}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/845df3cf65036503f762bf861fe6dc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/845df3cf65036503f762bf861fe6dc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fail-with-hascallstack] 10 commits: Make GHCi commands compatible with multiple home units
by Bodigrim (＠Bodigrim) 10 Jun '25
by Bodigrim (＠Bodigrim) 10 Jun '25
10 Jun '25
Bodigrim pushed to branch wip/fail-with-hascallstack at Glasgow Haskell Compiler / GHC
Commits:
5f213bff by fendor at 2025-06-02T09:16:24+02:00
Make GHCi commands compatible with multiple home units
=== Design
We enable all GHCi features that were previously guarded by the `inMulti`
option.
GHCi supported multiple home units up to a certain degree for quite a while now.
The supported feature set was limited, due to a design impasse:
One of the home units must be "active", e.g., there must be one `HomeUnit`
whose `UnitId` is "active" which is returned when calling
```haskell
do
hscActiveUnitId <$> getSession
```
This makes sense in a GHC session, since you are always compiling a particular
Module, but it makes less intuitive sense in an interactive session.
Given an expression to evaluate, we can't easily tell in which "context" the expression
should be parsed, typechecked and evaluated.
That's why initially, most of GHCi features, except for `:reload`ing were disabled
if the GHCi session had more than one `HomeUnitEnv`.
We lift this restriction, enabling all features of GHCi for the multiple home unit case.
To do this, we fundamentally change the `HomeUnitEnv` graph to be multiple home unit first.
Instead of differentiating the case were we have a single home unit and multiple,
we now always set up a multiple home unit session that scales seamlessly to an arbitrary
amount of home units.
We introduce two new `HomeUnitEnv`s that are always added to the `HomeUnitGraph`.
They are:
The "interactive-ghci", called the `interactiveGhciUnit`, contains the same
`DynFlags` that are used by the `InteractiveContext` for interactive evaluation
of expressions.
This `HomeUnitEnv` is only used on the prompt of GHCi, so we may refer to it as
"interactive-prompt" unit.
See Note [Relation between the `InteractiveContext` and `interactiveGhciUnitId`]
for discussing its role.
And the "interactive-session"", called `interactiveSessionUnit` or
`interactiveSessionUnitId`, which is used for loading Scripts into
GHCi that are not `Target`s of any home unit, via `:load` or `:add`.
Both of these "interactive" home units depend on all other `HomeUnitEnv`s that
are passed as arguments on the cli.
Additionally, the "interactive-ghci" unit depends on `interactive-session`.
We always evaluate expressions in the context of the
"interactive-ghci" session.
Since "interactive-ghci" depends on all home units, we can import any `Module`
from the other home units with ease.
As we have a clear `HomeUnitGraph` hierarchy, we can set `interactiveGhciUnitId`
as the active home unit for the full duration of the GHCi session.
In GHCi, we always set `interactiveGhciUnitId` to be the currently active home unit.
=== Implementation Details
Given this design idea, the implementation is relatively straight
forward.
The core insight is that a `ModuleName` is not sufficient to identify a
`Module` in the `HomeUnitGraph`. Thus, large parts of the PR is simply
about refactoring usages of `ModuleName` to prefer `Module`, which has a
`Unit` attached and is unique over the `HomeUnitGraph`.
Consequentially, most usages of `lookupHPT` are likely to be incorrect and have
been replaced by `lookupHugByModule` which is keyed by a `Module`.
In `GHCi/UI.hs`, we make sure there is only one location where we are
actually translating `ModuleName` to a `Module`:
* `lookupQualifiedModuleName`
If a `ModuleName` is ambiguous, we detect this and report it to the
user.
To avoid repeated lookups of `ModuleName`s, we store the `Module` in the
`InteractiveImport`, which additionally simplifies the interface
loading.
A subtle detail is that the `DynFlags` of the `InteractiveContext` are
now stored both in the `HomeUnitGraph` and in the `InteractiveContext`.
In UI.hs, there are multiple code paths where we are careful to update
the `DynFlags` in both locations.
Most importantly in `addToProgramDynFlags`.
---
There is one metric increase in this commit:
-------------------------
Metric Increase:
T4029
-------------------------
It is an increase from 14.4 MB to 16.1 MB (+11.8%) which sounds like a
pretty big regression at first.
However, we argue this increase is solely caused by using more data
structures for managing multiple home units in the GHCi session.
In particular, due to the design decision of using three home units, the
base memory usage increases... but by how much?
A big contributor is the `UnitState`, of which we have three now, which
on its own 260 KB per instance. That makes an additional memory usage of
520 KB, already explaining a third of the overall memory usage increase.
Then we store more elements in the `HomeUnitGraph`, we have more
`HomeUnitEnv` entries, etc...
While we didn't chase down each byte, we looked at the memory usage over time
for both `-hi` and `-hT` profiles and can say with confidence while the memory
usage increased slightly, we did not introduce any space leak, as
the graph looks almost identical as the memory usage graph of GHC HEAD.
---
Adds testcases for GHCi multiple home units session
* Test truly multiple home unit sessions, testing reload logic and code evaluation.
* Test that GHCi commands such as `:all-types`, `:browse`, etc., work
* Object code reloading for home modules
* GHCi debugger multiple home units session
- - - - -
de603d01 by fendor at 2025-06-02T09:16:24+02:00
Update "loading compiled code" GHCi documentation
To use object code in GHCi, the module needs to be compiled for use in
GHCi. To do that, users need to compile their modules with:
* `-dynamic`
* `-this-unit-id interactive-session`
Otherwise, the interface files will not match.
- - - - -
b255a8ca by Vladislav Zavialov at 2025-06-02T16:00:12-04:00
docs: Fix code example for NoListTuplePuns
Without the fix, the example produces an error:
Test.hs:11:3: error: [GHC-45219]
• Data constructor ‘Tuple’ returns type ‘Tuple2 a b’
instead of an instance of its parent type ‘Tuple a’
• In the definition of data constructor ‘Tuple’
In the data type declaration for ‘Tuple’
Fortunately, a one line change makes it compile.
- - - - -
6558467c by Ryan Hendrickson at 2025-06-06T05:46:58-04:00
haddock: Parse math even after ordinary characters
Fixes a bug where math sections were not recognized if preceded by a
character that isn't special (like space or a markup character).
- - - - -
265d0024 by ARATA Mizuki at 2025-06-06T05:47:48-04:00
AArch64 NCG: Fix sub-word arithmetic right shift
As noted in Note [Signed arithmetic on AArch64], we should zero-extend sub-word values.
Fixes #26061
- - - - -
05e9be18 by Simon Hengel at 2025-06-06T05:48:35-04:00
Allow Unicode in "message" and "hints" with -fdiagnostics-as-json
(fixes #26075)
- - - - -
bfa6b70f by ARATA Mizuki at 2025-06-06T05:49:24-04:00
x86 NCG: Fix code generation of bswap64 on i386
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
Fix #25601
- - - - -
35826d8b by Matthew Pickering at 2025-06-08T22:00:41+01:00
Hadrian: Add option to generate .hie files for stage1 libraries
The +hie_files flavour transformer can be enabled to produce hie files
for stage1 libraries. The hie files are produced in the
"extra-compilation-artifacts" folder and copied into the resulting
bindist.
At the moment the hie files are not produced for the release flavour,
they add about 170M to the final bindist.
Towards #16901
- - - - -
e2467dbd by Ryan Hendrickson at 2025-06-09T13:07:05-04:00
Fix various failures to -fprint-unicode-syntax
- - - - -
da08d54f by Andrew Lelechenko at 2025-06-10T21:00:12+01:00
Add HasCallStack to Control.Monad.Fail.fail
CLC proposal https://github.com/haskell/core-libraries-committee/issues/327
2% compile-time allocations increase in T3064, likely because `fail`
is now marginally more expensive to compile.
Metric Increase:
T3064
- - - - -
186 changed files:
- compiler/GHC.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Types.hs
- docs/users_guide/exts/data_kinds.rst
- docs/users_guide/ghci.rst
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
- hadrian/doc/flavours.md
- hadrian/doc/user-settings.md
- hadrian/src/Context.hs
- hadrian/src/Context/Path.hs
- hadrian/src/Flavour.hs
- hadrian/src/Flavour/Type.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Flavours/Release.hs
- libraries/base/changelog.md
- libraries/base/tests/IO/withBinaryFile002.stderr
- libraries/base/tests/IO/withFile002.stderr
- libraries/base/tests/IO/withFileBlocking002.stderr
- libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fail.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs-boot
- libraries/ghc-internal/src/GHC/Internal/IO.hs-boot
- libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs-boot
- testsuite/driver/testlib.py
- + testsuite/tests/cmm/should_run/T25601.hs
- + testsuite/tests/cmm/should_run/T25601.stdout
- + testsuite/tests/cmm/should_run/T25601a.cmm
- testsuite/tests/cmm/should_run/all.T
- + testsuite/tests/codeGen/should_run/T26061.hs
- + testsuite/tests/codeGen/should_run/T26061.stdout
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/deSugar/should_run/DsDoExprFailMsg.stderr
- testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.stderr
- testsuite/tests/driver/T8526/T8526.stdout
- testsuite/tests/driver/fat-iface/fat014.stdout
- testsuite/tests/driver/json.stderr
- testsuite/tests/driver/json_warn.stderr
- testsuite/tests/driver/multipleHomeUnits/multiGHCi.stderr
- testsuite/tests/ghc-api/T6145.hs
- testsuite/tests/ghc-api/annotations-literals/literals.hs
- testsuite/tests/ghc-api/annotations-literals/parsed.hs
- testsuite/tests/ghc-api/apirecomp001/myghc.hs
- testsuite/tests/ghc-api/fixed-nodes/T1.hs
- + testsuite/tests/ghci.debugger/scripts/break031/Makefile
- + testsuite/tests/ghci.debugger/scripts/break031/a/A.hs
- + testsuite/tests/ghci.debugger/scripts/break031/all.T
- + testsuite/tests/ghci.debugger/scripts/break031/b/B.hs
- + testsuite/tests/ghci.debugger/scripts/break031/break031a.script
- + testsuite/tests/ghci.debugger/scripts/break031/break031a.stdout
- + testsuite/tests/ghci.debugger/scripts/break031/break031b.script
- + testsuite/tests/ghci.debugger/scripts/break031/break031b.stderr
- + testsuite/tests/ghci.debugger/scripts/break031/break031b.stdout
- + testsuite/tests/ghci.debugger/scripts/break031/unitA
- + testsuite/tests/ghci.debugger/scripts/break031/unitB
- testsuite/tests/ghci/linking/dyn/T3372.hs
- + testsuite/tests/ghci/prog-mhu001/Makefile
- + testsuite/tests/ghci/prog-mhu001/all.T
- + testsuite/tests/ghci/prog-mhu001/e/E.hs
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001a.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001a.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001b.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001b.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001c.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001d.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001d.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001e.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001e.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001f.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001f.stdout
- + testsuite/tests/ghci/prog-mhu001/unitE
- + testsuite/tests/ghci/prog-mhu001/unitE-main-is
- + testsuite/tests/ghci/prog-mhu002/Makefile
- + testsuite/tests/ghci/prog-mhu002/a/A.hs
- + testsuite/tests/ghci/prog-mhu002/all.T
- + testsuite/tests/ghci/prog-mhu002/b/B.hs
- + testsuite/tests/ghci/prog-mhu002/c/C.hs
- + testsuite/tests/ghci/prog-mhu002/d/Main.hs
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.stderr
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.stderr
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002c.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002c.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002d.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002d.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002e.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002e.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002f.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002f.stdout
- + testsuite/tests/ghci/prog-mhu002/unitA
- + testsuite/tests/ghci/prog-mhu002/unitB
- + testsuite/tests/ghci/prog-mhu002/unitC
- + testsuite/tests/ghci/prog-mhu002/unitD
- + testsuite/tests/ghci/prog-mhu003/Makefile
- + testsuite/tests/ghci/prog-mhu003/a/A.hs
- + testsuite/tests/ghci/prog-mhu003/all.T
- + testsuite/tests/ghci/prog-mhu003/b/Foo.hs
- + testsuite/tests/ghci/prog-mhu003/c/C.hs
- + testsuite/tests/ghci/prog-mhu003/d/Foo.hs
- + testsuite/tests/ghci/prog-mhu003/prog-mhu003.script
- + testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr
- + testsuite/tests/ghci/prog-mhu003/prog-mhu003.stdout
- + testsuite/tests/ghci/prog-mhu003/unitA
- + testsuite/tests/ghci/prog-mhu003/unitB
- + testsuite/tests/ghci/prog-mhu003/unitC
- + testsuite/tests/ghci/prog-mhu003/unitD
- + testsuite/tests/ghci/prog-mhu004/Makefile
- + testsuite/tests/ghci/prog-mhu004/a/Foo.hs
- + testsuite/tests/ghci/prog-mhu004/all.T
- + testsuite/tests/ghci/prog-mhu004/b/Foo.hs
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.script
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stdout
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004b.script
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004b.stdout
- + testsuite/tests/ghci/prog-mhu004/unitA
- + testsuite/tests/ghci/prog-mhu004/unitB
- testsuite/tests/ghci/prog010/ghci.prog010.script
- testsuite/tests/ghci/prog018/prog018.stdout
- + testsuite/tests/ghci/prog020/A.hs
- + testsuite/tests/ghci/prog020/B.hs
- + testsuite/tests/ghci/prog020/Makefile
- + testsuite/tests/ghci/prog020/all.T
- + testsuite/tests/ghci/prog020/ghci.prog020.script
- + testsuite/tests/ghci/prog020/ghci.prog020.stderr
- + testsuite/tests/ghci/prog020/ghci.prog020.stdout
- testsuite/tests/ghci/scripts/T12550.stdout
- testsuite/tests/ghci/scripts/T13869.stdout
- testsuite/tests/ghci/scripts/T13997.stdout
- testsuite/tests/ghci/scripts/T17669.stdout
- testsuite/tests/ghci/scripts/T18330.stdout
- testsuite/tests/ghci/scripts/T1914.stdout
- testsuite/tests/ghci/scripts/T20217.stdout
- testsuite/tests/ghci/scripts/T20587.stdout
- testsuite/tests/ghci/scripts/T21110.stderr
- testsuite/tests/ghci/scripts/T6105.stdout
- testsuite/tests/ghci/scripts/T8042.stdout
- testsuite/tests/ghci/scripts/T8042recomp.stdout
- testsuite/tests/ghci/scripts/T8959b.stderr
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/ghci/scripts/ghci024.stdout
- testsuite/tests/ghci/scripts/ghci024.stdout-mingw32
- testsuite/tests/ghci/scripts/ghci058.script
- + testsuite/tests/ghci/scripts/print-unicode-syntax.script
- + testsuite/tests/ghci/scripts/print-unicode-syntax.stderr
- + testsuite/tests/ghci/scripts/print-unicode-syntax.stdout
- testsuite/tests/ghci/should_run/T11825.stdout
- testsuite/tests/ghci/should_run/TopEnvIface.stdout
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/quasiquotation/T7918.hs
- testsuite/tests/th/T15321.stderr
- testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/haddock/haddock-library/test/Documentation/Haddock/ParserSpec.hs
- utils/haddock/hypsrc-test/ref/src/Quasiquoter.html
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2a7f3468895bd84b31210e8ec23f4f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2a7f3468895bd84b31210e8ec23f4f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T23109] 8 commits: Hadrian: Add option to generate .hie files for stage1 libraries
by Simon Peyton Jones (＠simonpj) 10 Jun '25
by Simon Peyton Jones (＠simonpj) 10 Jun '25
10 Jun '25
Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC
Commits:
35826d8b by Matthew Pickering at 2025-06-08T22:00:41+01:00
Hadrian: Add option to generate .hie files for stage1 libraries
The +hie_files flavour transformer can be enabled to produce hie files
for stage1 libraries. The hie files are produced in the
"extra-compilation-artifacts" folder and copied into the resulting
bindist.
At the moment the hie files are not produced for the release flavour,
they add about 170M to the final bindist.
Towards #16901
- - - - -
e2467dbd by Ryan Hendrickson at 2025-06-09T13:07:05-04:00
Fix various failures to -fprint-unicode-syntax
- - - - -
43dd53c6 by Simon Peyton Jones at 2025-06-10T16:59:31+01:00
Make injecting implicit bindings into its own pass
Previously we were injecting "impliicit bindings" (data constructor
worker and wrappers etc)
- both at the end of CoreTidy,
- and at the start of CorePrep
This is unpleasant and confusing. This patch puts it it its own pass,
addImplicitBinds, which runs between the two.
The function `GHC.CoreToStg.AddImplicitBinds.addImplicitBinds` now takes /all/
TyCons, not just the ones for algebraic data types. That change ripples
through to
- corePrepPgm
- doCodeGen
- byteCodeGen
All take [TyCon] which includes all TyCons
- - - - -
c6a31618 by Simon Peyton Jones at 2025-06-10T16:59:31+01:00
Implement unary classes
The big change is described exhaustively in
Note [Unary class magic] in GHC.Core.TyCon
Other changes
* We never unbox class dictionaries in worker/wrapper. This has been true for some
time now, but the logic is now centralised in functions in
GHC.Core.Opt.WorkWrap.Utils, namely `canUnboxTyCon`, and `canUnboxArg`
See Note [Do not unbox class dictionaries] in GHC.Core.Opt.WorkWrap.Utils.
* Refactored the `notWorthFloating` logic in GHc.Core.Opt.SetLevels.
I can't remember if I actually changed any behaviour here, but if so it's
only in a corner cases.
* Fixed a bug in `GHC.Core.TyCon.isEnumerationTyCon`, which was wrongly returning
True for (##).
* Remove redundant Role argument to `liftCoSubstWithEx`. It was always
Representational.
* I refactored evidence generation in the constraint solver:
* Made GHC.Tc.Types.Evidence contain better abstactions for evidence
generation.
* I deleted the file `GHC.Tc.Types.EvTerm` and merged its (small) contents
elsewhere. It wasn't paying its way.
* Made evidence for implicit parameters go via a proper abstraction.
Smaller things
* Rename `isDataTyCon` to `isBoxedDataTyCon`.
* GHC.Core.Corecion.liftCoSubstWithEx was only called with Representational role,
so I baked that into the function and removed the argument.
* Get rid of `GHC.Core.TyCon.tyConSingleAlgDataCon_maybe` in favour of calling
`not isNewTyCon` at the call sites; more explicit.
* Refatored `GHC.Core.TyCon.isInjectiveTyCon`; but I don't think I changed its
behaviour
* Moved `decomposeIPPred` to GHC.Core.Predicate
- - - - -
164ac432 by Simon Peyton Jones at 2025-06-10T16:59:31+01:00
Accept GHCi debugger output change
@alt-romes says this is fine
- - - - -
5cd71bbc by Simon Peyton Jones at 2025-06-10T16:59:31+01:00
Renaming around predicate types
.. we were (as it turned out) abstracting over
type-class selectors in SPECIALISATION rules!
Wibble isEqPred
- - - - -
67591230 by Simon Peyton Jones at 2025-06-10T16:59:31+01:00
This increment adds tryTcS to support shortCutSolver
* Make short-cut solver invoke the real solver, so that it works
for type families.
* Use the short-cut solver for quantified constraints too.
* Use prepareSpecLHS for the old route too. Leave decomposeRuleLhs
for RULES only.
- - - - -
1a608495 by Simon Peyton Jones at 2025-06-10T16:59:31+01:00
Comments only
- - - - -
125 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/ByteCode/InfoTable.hs
- compiler/GHC/Core/Class.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Unfold/Make.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg.hs
- + compiler/GHC/CoreToStg/AddImplicitBinds.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Foreign/Call.hs
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Rewrite.hs
- compiler/GHC/Tc/Solver/Solve.hs
- + compiler/GHC/Tc/Solver/Solve.hs-boot
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- − compiler/GHC/Tc/Types/EvTerm.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/RepType.hs
- compiler/GHC/Types/TyThing.hs
- compiler/GHC/Types/Var.hs
- compiler/ghc.cabal.in
- hadrian/doc/flavours.md
- hadrian/doc/user-settings.md
- hadrian/src/Context.hs
- hadrian/src/Context/Path.hs
- hadrian/src/Flavour.hs
- hadrian/src/Flavour/Type.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Flavours/Release.hs
- testsuite/tests/core-to-stg/T24124.stderr
- testsuite/tests/deSugar/should_compile/T2431.stderr
- testsuite/tests/dependent/should_fail/T13135_simple.stderr
- testsuite/tests/dmdanal/should_compile/T16029.stdout
- testsuite/tests/dmdanal/sigs/T21119.stderr
- testsuite/tests/dmdanal/sigs/T21888.stderr
- testsuite/tests/ghci.debugger/scripts/break011.stdout
- testsuite/tests/ghci.debugger/scripts/break024.stdout
- testsuite/tests/ghci/scripts/T12550.stdout
- testsuite/tests/ghci/scripts/T8959b.stderr
- testsuite/tests/ghci/scripts/all.T
- + testsuite/tests/ghci/scripts/print-unicode-syntax.script
- + testsuite/tests/ghci/scripts/print-unicode-syntax.stderr
- + testsuite/tests/ghci/scripts/print-unicode-syntax.stdout
- testsuite/tests/ghci/should_run/T11825.stdout
- testsuite/tests/indexed-types/should_compile/T2238.hs
- testsuite/tests/numeric/should_compile/T15547.stderr
- testsuite/tests/numeric/should_compile/T23907.stderr
- testsuite/tests/roles/should_compile/Roles14.stderr
- testsuite/tests/roles/should_compile/Roles3.stderr
- testsuite/tests/roles/should_compile/Roles4.stderr
- testsuite/tests/simplCore/should_compile/DataToTagFamilyScrut.stderr
- testsuite/tests/simplCore/should_compile/T15205.stderr
- testsuite/tests/simplCore/should_compile/T17366.stderr
- testsuite/tests/simplCore/should_compile/T17966.stderr
- testsuite/tests/simplCore/should_compile/T22309.stderr
- testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr
- testsuite/tests/simplCore/should_compile/T23307.stderr
- testsuite/tests/simplCore/should_compile/T23307a.stderr
- testsuite/tests/simplCore/should_compile/T25389.stderr
- testsuite/tests/simplCore/should_compile/T25713.stderr
- testsuite/tests/simplCore/should_compile/T7360.stderr
- testsuite/tests/simplStg/should_compile/T15226b.stderr
- testsuite/tests/tcplugins/CtIdPlugin.hs
- testsuite/tests/typecheck/should_compile/Makefile
- testsuite/tests/typecheck/should_compile/T12763.stderr
- testsuite/tests/typecheck/should_compile/T14774.stdout
- testsuite/tests/typecheck/should_compile/T18406b.stderr
- testsuite/tests/typecheck/should_compile/T18529.stderr
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/unboxedsums/unpack_sums_7.stdout
- testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
- testsuite/tests/wasm/should_run/control-flow/RunWasm.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eea9a1825f8d9eb39f93be53779bde…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eea9a1825f8d9eb39f93be53779bde…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T22859] Implement user-defined allocation limit handlers
by Teo Camarasu (＠teo) 10 Jun '25
by Teo Camarasu (＠teo) 10 Jun '25
10 Jun '25
Teo Camarasu pushed to branch wip/T22859 at Glasgow Haskell Compiler / GHC
Commits:
0c1fd317 by Teo Camarasu at 2025-06-10T16:30:42+01:00
Implement user-defined allocation limit handlers
Allocation Limits allow killing a thread if they allocate more than a
user-specified limit.
We extend this feature to allow more versatile behaviour.
- We allow not killing the thread if the limit is exceeded.
- We allow setting a custom handler to be called when the limit is exceeded.
User-specified allocation limit handlers run in a fresh thread and are passed
the ThreadId of the thread that exceeded its limit.
We introduce utility functions for getting and setting the allocation
limits of other threads, so that users can reset the limit of a thread
from a handler. Both of these are somewhat coarse-grained as we are
unaware of the allocations in the current nursery chunk.
We provide several examples of usages in testsuite/tests/rts/T22859.hs
Resolves #22859
- - - - -
24 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/ghc-experimental/ghc-experimental.cabal.in
- + libraries/ghc-experimental/src/System/Mem/Experimental.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/Schedule.c
- rts/external-symbols.list.in
- rts/include/rts/storage/GC.h
- rts/include/rts/storage/TSO.h
- rts/include/stg/MiscClosures.h
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- + testsuite/tests/rts/T22859.hs
- + testsuite/tests/rts/T22859.stderr
- testsuite/tests/rts/all.T
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -4065,6 +4065,15 @@ primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp
effect = ReadWriteEffect
out_of_line = True
+primop SetOtherThreadAllocationCounter "setOtherThreadAllocationCounter#" GenPrimOp
+ Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
+ { Sets the allocation counter for the another thread to the given value.
+ This doesn't take allocations into the current nursery chunk into account.
+ Therefore it is only accurate if the other thread is not currently running. }
+ with
+ effect = ReadWriteEffect
+ out_of_line = True
+
primtype StackSnapshot#
{ Haskell representation of a @StgStack*@ that was created (cloned)
with a function in "GHC.Stack.CloneStack". Please check the
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1775,6 +1775,7 @@ emitPrimOp cfg primop =
TraceEventBinaryOp -> alwaysExternal
TraceMarkerOp -> alwaysExternal
SetThreadAllocationCounter -> alwaysExternal
+ SetOtherThreadAllocationCounter -> alwaysExternal
KeepAliveOp -> alwaysExternal
where
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -1173,6 +1173,7 @@ genPrim prof bound ty op = case op of
WhereFromOp -> unhandledPrimop op -- should be easily implementable with o.f.n
SetThreadAllocationCounter -> unhandledPrimop op
+ SetOtherThreadAllocationCounter -> unhandledPrimop op
------------------------------- Vector -----------------------------------------
-- For now, vectors are unsupported on the JS backend. Simply put, they do not
=====================================
libraries/ghc-experimental/ghc-experimental.cabal.in
=====================================
@@ -38,6 +38,7 @@ library
GHC.RTS.Flags.Experimental
GHC.Stats.Experimental
Prelude.Experimental
+ System.Mem.Experimental
if arch(wasm32)
exposed-modules: GHC.Wasm.Prim
other-extensions:
=====================================
libraries/ghc-experimental/src/System/Mem/Experimental.hs
=====================================
@@ -0,0 +1,10 @@
+module System.Mem.Experimental
+ ( setGlobalAllocationLimitHandler
+ , AllocationLimitKillBehaviour(..)
+ , getAllocationCounterFor
+ , setAllocationCounterFor
+ , enableAllocationLimitFor
+ , disableAllocationLimitFor
+ )
+ where
+import GHC.Internal.AllocationLimitHandler
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -122,6 +122,7 @@ Library
rts == 1.0.*
exposed-modules:
+ GHC.Internal.AllocationLimitHandler
GHC.Internal.ClosureTypes
GHC.Internal.Control.Arrow
GHC.Internal.Control.Category
=====================================
libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
=====================================
@@ -0,0 +1,117 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# OPTIONS_HADDOCK not-home #-}
+module GHC.Internal.AllocationLimitHandler
+ ( runAllocationLimitHandler
+ , setGlobalAllocationLimitHandler
+ , AllocationLimitKillBehaviour(..)
+ , getAllocationCounterFor
+ , setAllocationCounterFor
+ , enableAllocationLimitFor
+ , disableAllocationLimitFor
+ )
+ where
+import GHC.Internal.Base
+import GHC.Internal.Conc.Sync (ThreadId(..))
+import GHC.Internal.Data.IORef (IORef, readIORef, writeIORef, newIORef)
+import GHC.Internal.Foreign.C.Types
+import GHC.Internal.IO (unsafePerformIO)
+import GHC.Internal.Int (Int64(..))
+
+
+{-# NOINLINE allocationLimitHandler #-}
+allocationLimitHandler :: IORef (ThreadId -> IO ())
+allocationLimitHandler = unsafePerformIO (newIORef defaultHandler)
+
+defaultHandler :: ThreadId -> IO ()
+defaultHandler _ = pure ()
+
+foreign import ccall "setAllocLimitKill" setAllocLimitKill :: CBool -> CBool -> IO ()
+
+runAllocationLimitHandler :: ThreadId# -> IO ()
+runAllocationLimitHandler tid = do
+ hook <- getAllocationLimitHandler
+ hook $ ThreadId tid
+
+getAllocationLimitHandler :: IO (ThreadId -> IO ())
+getAllocationLimitHandler = readIORef allocationLimitHandler
+
+data AllocationLimitKillBehaviour =
+ KillOnAllocationLimit
+ -- ^ Throw a @AllocationLimitExceeded@ async exception to the thread when the
+ -- allocation limit is exceeded.
+ | DontKillOnAllocationLimit
+ -- ^ Do not throw an exception when the allocation limit is exceeded.
+
+-- | Define the behaviour for handling allocation limits.
+-- The default behaviour is to throw an @AllocationLimitExceeded@ async exception to the thread.
+-- This can be overriden using @AllocationLimitKillBehaviour@.
+--
+-- We can set a user-specified handler, which can be run in addition to
+-- or in place of the exception.
+-- This allows for instance logging on the allocation limit being exceeded,
+-- or dynamically determining whether to terminate the thread.
+-- The handler is not guaranteed to run before the thread is terminated or restarted.
+--
+-- Note: that if you don't terminate the thread, then the allocation limit gets
+-- removed.
+-- If you wish to keep the allocation limit you will have to reset it using
+-- @setAllocationCounter@ and @enableAllocationLimit@.
+setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> Maybe (ThreadId -> IO ()) -> IO ()
+setGlobalAllocationLimitHandler killBehaviour mHandler = do
+ shouldRunHandler <- case mHandler of
+ Just hook -> do
+ writeIORef allocationLimitHandler hook
+ pure 1
+ Nothing -> do
+ writeIORef allocationLimitHandler defaultHandler
+ pure 0
+ let shouldKill =
+ case killBehaviour of
+ KillOnAllocationLimit -> 1
+ DontKillOnAllocationLimit -> 0
+ setAllocLimitKill shouldKill shouldRunHandler
+
+-- | Retrieves the allocation counter for the another thread.
+foreign import prim "stg_getOtherThreadAllocationCounterzh" getOtherThreadAllocationCounter#
+ :: ThreadId#
+ -> State# RealWorld
+ -> (# State# RealWorld, Int64# #)
+
+-- | Get the allocation counter for a different thread.
+--
+-- Note: this doesn't take the current nursery chunk into account.
+-- If the thread is running then it may underestimate allocations by the size of a nursery thread.
+getAllocationCounterFor :: ThreadId -> IO Int64
+getAllocationCounterFor (ThreadId t#) = IO $ \s ->
+ case getOtherThreadAllocationCounter# t# s of (# s', i# #) -> (# s', I64# i# #)
+
+-- | Set the allocation counter for a different thread.
+-- This can be combined with 'enableAllocationLimitFor' to enable allocation limits for another thread.
+-- You may wish to do this during a user-specified allocation limit handler.
+--
+-- Note: this doesn't take the current nursery chunk into account.
+-- If the thread is running then it may overestimate allocations by the size of a nursery thread,
+-- and trigger the limit sooner than expected.
+setAllocationCounterFor :: Int64 -> ThreadId -> IO ()
+setAllocationCounterFor (I64# i#) (ThreadId t#) = IO $ \s ->
+ case setOtherThreadAllocationCounter# i# t# s of s' -> (# s', () #)
+
+
+-- | Enable allocation limit processing the thread @t@.
+enableAllocationLimitFor :: ThreadId -> IO ()
+enableAllocationLimitFor (ThreadId t) = do
+ rts_enableThreadAllocationLimit t
+
+-- | Disable allocation limit processing the thread @t@.
+disableAllocationLimitFor :: ThreadId -> IO ()
+disableAllocationLimitFor (ThreadId t) = do
+ rts_disableThreadAllocationLimit t
+
+foreign import ccall unsafe "rts_enableThreadAllocationLimit"
+ rts_enableThreadAllocationLimit :: ThreadId# -> IO ()
+
+foreign import ccall unsafe "rts_disableThreadAllocationLimit"
+ rts_disableThreadAllocationLimit :: ThreadId# -> IO ()
=====================================
rts/Prelude.h
=====================================
@@ -67,6 +67,7 @@ PRELUDE_CLOSURE(ghczminternal_GHCziInternalziEventziWindows_processRemoteComplet
PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure);
PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure);
+PRELUDE_CLOSURE(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure);
PRELUDE_INFO(ghczminternal_GHCziInternalziCString_unpackCStringzh_info);
PRELUDE_INFO(ghczminternal_GHCziInternalziTypes_Czh_con_info);
@@ -102,6 +103,7 @@ PRELUDE_INFO(ghczminternal_GHCziInternalziStable_StablePtr_con_info);
#if defined(mingw32_HOST_OS)
#define processRemoteCompletion_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziEventziWindows_processRemoteCompletion_closure)
#endif
+#define runAllocationLimitHandler_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure)
#define flushStdHandles_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure)
#define runMainIO_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure)
=====================================
rts/PrimOps.cmm
=====================================
@@ -2889,6 +2889,11 @@ stg_getThreadAllocationCounterzh ()
return (StgTSO_alloc_limit(CurrentTSO) - TO_I64(offset));
}
+stg_getOtherThreadAllocationCounterzh ( gcptr t )
+{
+ return (StgTSO_alloc_limit(t));
+}
+
stg_setThreadAllocationCounterzh ( I64 counter )
{
// Allocation in the current block will be subtracted by
@@ -2901,6 +2906,12 @@ stg_setThreadAllocationCounterzh ( I64 counter )
return ();
}
+stg_setOtherThreadAllocationCounterzh ( I64 counter, gcptr t )
+{
+ StgTSO_alloc_limit(t) = counter;
+ return ();
+}
+
#define KEEP_ALIVE_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,c) \
w_ info_ptr, \
=====================================
rts/RtsStartup.c
=====================================
@@ -224,6 +224,7 @@ static void initBuiltinGcRoots(void)
* GHC.Core.Make.mkExceptionId.
*/
getStablePtr((StgPtr)absentSumFieldError_closure);
+ getStablePtr((StgPtr)runAllocationLimitHandler_closure);
}
void
=====================================
rts/RtsSymbols.c
=====================================
@@ -916,7 +916,9 @@ extern char **environ;
SymI_HasDataProto(stg_traceMarkerzh) \
SymI_HasDataProto(stg_traceBinaryEventzh) \
SymI_HasDataProto(stg_getThreadAllocationCounterzh) \
+ SymI_HasDataProto(stg_getOtherThreadAllocationCounterzh) \
SymI_HasDataProto(stg_setThreadAllocationCounterzh) \
+ SymI_HasDataProto(stg_setOtherThreadAllocationCounterzh) \
SymI_HasProto(getMonotonicNSec) \
SymI_HasProto(lockFile) \
SymI_HasProto(unlockFile) \
=====================================
rts/Schedule.c
=====================================
@@ -41,6 +41,7 @@
#include "Threads.h"
#include "Timer.h"
#include "ThreadPaused.h"
+#include "ThreadLabels.h"
#include "Messages.h"
#include "StablePtr.h"
#include "StableName.h"
@@ -94,6 +95,10 @@ StgWord recent_activity = ACTIVITY_YES;
*/
StgWord sched_state = SCHED_RUNNING;
+
+bool allocLimitKill = true;
+bool allocLimitRunHook = false;
+
/*
* This mutex protects most of the global scheduler data in
* the THREADED_RTS runtime.
@@ -1125,19 +1130,36 @@ schedulePostRunThread (Capability *cap, StgTSO *t)
}
}
- //
- // If the current thread's allocation limit has run out, send it
- // the AllocationLimitExceeded exception.
+ // Handle the current thread's allocation limit running out,
if (PK_Int64((W_*)&(t->alloc_limit)) < 0 && (t->flags & TSO_ALLOC_LIMIT)) {
- // Use a throwToSelf rather than a throwToSingleThreaded, because
- // it correctly handles the case where the thread is currently
- // inside mask. Also the thread might be blocked (e.g. on an
- // MVar), and throwToSingleThreaded doesn't unblock it
- // correctly in that case.
- throwToSelf(cap, t, allocationLimitExceeded_closure);
- ASSIGN_Int64((W_*)&(t->alloc_limit),
- (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE);
+ if(allocLimitKill) {
+ // Throw the AllocationLimitExceeded exception.
+ // Use a throwToSelf rather than a throwToSingleThreaded, because
+ // it correctly handles the case where the thread is currently
+ // inside mask. Also the thread might be blocked (e.g. on an
+ // MVar), and throwToSingleThreaded doesn't unblock it
+ // correctly in that case.
+ throwToSelf(cap, t, allocationLimitExceeded_closure);
+ ASSIGN_Int64((W_*)&(t->alloc_limit),
+ (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE);
+ } else {
+ // If we aren't killing the thread, we must disable the limit
+ // otherwise we will immediatelly retrigger it.
+ // User defined handlers should re-enable it if wanted.
+ t->flags = t->flags & ~TSO_ALLOC_LIMIT;
+ }
+
+ if(allocLimitRunHook)
+ {
+ // Create a thread to run the allocation limit handler.
+ StgClosure* c = rts_apply(cap, runAllocationLimitHandler_closure, (StgClosure*)t);
+ StgTSO* hookThread = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, c);
+ setThreadLabel(cap, hookThread, "allocation limit handler thread");
+ // Schedule the handler to be run immediatelly.
+ pushOnRunQueue(cap, hookThread);
+ }
+
}
/* some statistics gathering in the parallel case */
@@ -3342,3 +3364,9 @@ resurrectThreads (StgTSO *threads)
}
}
}
+
+void setAllocLimitKill(bool shouldKill, bool shouldHook)
+{
+ allocLimitKill = shouldKill;
+ allocLimitRunHook = shouldHook;
+}
=====================================
rts/external-symbols.list.in
=====================================
@@ -43,6 +43,7 @@ ghczminternal_GHCziInternalziTypes_Izh_con_info
ghczminternal_GHCziInternalziTypes_Fzh_con_info
ghczminternal_GHCziInternalziTypes_Dzh_con_info
ghczminternal_GHCziInternalziTypes_Wzh_con_info
+ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure
ghczminternal_GHCziInternalziPtr_Ptr_con_info
ghczminternal_GHCziInternalziPtr_FunPtr_con_info
ghczminternal_GHCziInternalziInt_I8zh_con_info
=====================================
rts/include/rts/storage/GC.h
=====================================
@@ -209,6 +209,10 @@ void flushExec(W_ len, AdjustorExecutable exec_addr);
// Used by GC checks in external .cmm code:
extern W_ large_alloc_lim;
+// Should triggering an allocation limit kill the thread
+// and should we run a user-defined hook when it is triggered.
+void setAllocLimitKill(bool, bool);
+
/* -----------------------------------------------------------------------------
Performing Garbage Collection
-------------------------------------------------------------------------- */
=====================================
rts/include/rts/storage/TSO.h
=====================================
@@ -157,9 +157,10 @@ typedef struct StgTSO_ {
/*
* The allocation limit for this thread, which is updated as the
* thread allocates. If the value drops below zero, and
- * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the
- * thread, and give the thread a little more space to handle the
- * exception before we raise the exception again.
+ * TSO_ALLOC_LIMIT is set in flags, then a handler is triggerd.
+ * Either we raise an exception in the thread, and give the thread
+ * a little more space to handle the exception before we raise the
+ * exception again; or we run a user defined handler.
*
* This is an integer, because we might update it in a place where
* it isn't convenient to raise the exception, so we want it to
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -604,7 +604,9 @@ RTS_FUN_DECL(stg_traceEventzh);
RTS_FUN_DECL(stg_traceBinaryEventzh);
RTS_FUN_DECL(stg_traceMarkerzh);
RTS_FUN_DECL(stg_getThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_getOtherThreadAllocationCounterzh);
RTS_FUN_DECL(stg_setThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_setOtherThreadAllocationCounterzh);
RTS_FUN_DECL(stg_castWord64ToDoublezh);
RTS_FUN_DECL(stg_castDoubleToWord64zh);
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6693,6 +6694,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6665,6 +6666,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -4610,6 +4610,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6836,6 +6837,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6693,6 +6694,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -10916,6 +10916,16 @@ module Prelude.Experimental where
data Unit# = ...
getSolo :: forall a. Solo a -> a
+module System.Mem.Experimental where
+ -- Safety: None
+ type AllocationLimitKillBehaviour :: *
+ data AllocationLimitKillBehaviour = KillOnAllocationLimit | DontKillOnAllocationLimit
+ disableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()
+ enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()
+ getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO GHC.Internal.Int.Int64
+ setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()
+ setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()) -> GHC.Types.IO ()
+
-- Instances:
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/rts/T22859.hs
=====================================
@@ -0,0 +1,71 @@
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Control.Exception
+import Control.Exception.Backtrace
+import Control.Concurrent
+import Control.Concurrent.MVar
+import System.Mem
+import System.Mem.Experimental
+import GHC.IO (IO (..))
+import GHC.Exts
+import System.IO
+
+-- | Just do some work and hPutStrLn to stderr to indicate that we are making progress
+worker :: IO ()
+worker = loop [] 2
+ where
+ loop !m !n
+ | n > 30 = hPutStrLn stderr . show $ length m
+ | otherwise = do
+ let x = show n
+ hPutStrLn stderr x
+ -- just to bulk out the allocations
+ IO (\s -> case newByteArray# 900000# s of (# s', arr# #) -> (# s', () #))
+ yield
+ loop (x:m) (n + 1)
+
+main :: IO ()
+main = do
+ done <- newMVar () -- we use this lock to wait for the worker to finish
+ started <- newEmptyMVar
+ let runWorker = do
+ forkIO . withMVar done $ \_ -> flip onException (hPutStrLn stderr "worker died") $ do
+ hPutStrLn stderr "worker starting"
+ putMVar started ()
+ setAllocationCounter 1_000_000
+ enableAllocationLimit
+ worker
+ hPutStrLn stderr "worker done"
+ takeMVar started
+ readMVar done
+ hFlush stderr
+ threadDelay 1000
+ -- default behaviour:
+ -- kill it after the limit is exceeded
+ hPutStrLn stderr "default behaviour"
+ runWorker
+ hPutStrLn stderr "just log once on the hook being triggered"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 1")
+ runWorker
+ hPutStrLn stderr "just log on the hook being triggered"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tid -> do
+ hPutStrLn stderr "allocation limit triggered 2"
+ -- re-enable the hook
+ setAllocationCounterFor 1_000_000 tid
+ enableAllocationLimitFor tid
+ runWorker
+ hPutStrLn stderr "kill from the hook"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tId -> throwTo tId AllocationLimitExceeded
+ runWorker
+ -- not super helpful, but let's test it anyway
+ hPutStrLn stderr "do nothing"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit Nothing
+ runWorker
+ -- this is possible to handle using an exception handler instead.
+ hPutStrLn stderr "kill and log"
+ setGlobalAllocationLimitHandler KillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 3")
+ runWorker
+ threadDelay 1000
+ hPutStrLn stderr "done"
=====================================
testsuite/tests/rts/T22859.stderr
=====================================
@@ -0,0 +1,152 @@
+default behaviour
+worker starting
+2
+3
+worker died
+T22859: allocation limit exceeded
+HasCallStack backtrace:
+ collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception
+ toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO
+ throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base
+
+
+just log once on the hook being triggered
+worker starting
+2
+3
+allocation limit triggered 1
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+29
+worker done
+just log on the hook being triggered
+worker starting
+2
+3
+allocation limit triggered 2
+4
+5
+allocation limit triggered 2
+6
+7
+allocation limit triggered 2
+8
+9
+allocation limit triggered 2
+10
+11
+allocation limit triggered 2
+12
+13
+allocation limit triggered 2
+14
+15
+allocation limit triggered 2
+16
+17
+allocation limit triggered 2
+18
+19
+allocation limit triggered 2
+20
+21
+allocation limit triggered 2
+22
+23
+allocation limit triggered 2
+24
+25
+allocation limit triggered 2
+26
+27
+allocation limit triggered 2
+28
+29
+allocation limit triggered 2
+30
+29
+worker done
+kill from the hook
+worker starting
+2
+3
+worker died
+T22859: allocation limit exceeded
+HasCallStack backtrace:
+ collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception
+ toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO
+ throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base
+
+
+do nothing
+worker starting
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+29
+worker done
+kill and log
+worker starting
+2
+3
+allocation limit triggered 3
+worker died
+T22859: allocation limit exceeded
+HasCallStack backtrace:
+ collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception
+ toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO
+ throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base
+
+
+done
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -643,3 +643,4 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru
test('T25560', [req_c_rts, ignore_stderr], compile_and_run, [''])
test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main'])
+test('T22859', [js_skip], compile_and_run, ['-with-rtsopts -A8K'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c1fd3175865ccec423c4446e550c0f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c1fd3175865ccec423c4446e550c0f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T22859] Implement user-defined allocation limit handlers
by Teo Camarasu (＠teo) 10 Jun '25
by Teo Camarasu (＠teo) 10 Jun '25
10 Jun '25
Teo Camarasu pushed to branch wip/T22859 at Glasgow Haskell Compiler / GHC
Commits:
d3d7e58c by Teo Camarasu at 2025-06-10T16:09:47+01:00
Implement user-defined allocation limit handlers
Resolves #22859
- - - - -
24 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/ghc-experimental/ghc-experimental.cabal.in
- + libraries/ghc-experimental/src/System/Mem/Experimental.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/Schedule.c
- rts/external-symbols.list.in
- rts/include/rts/storage/GC.h
- rts/include/rts/storage/TSO.h
- rts/include/stg/MiscClosures.h
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- + testsuite/tests/rts/T22859.hs
- + testsuite/tests/rts/T22859.stderr
- testsuite/tests/rts/all.T
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -4065,6 +4065,15 @@ primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp
effect = ReadWriteEffect
out_of_line = True
+primop SetOtherThreadAllocationCounter "setOtherThreadAllocationCounter#" GenPrimOp
+ Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
+ { Sets the allocation counter for the another thread to the given value.
+ This doesn't take allocations into the current nursery chunk into account.
+ Therefore it is only accurate if the other thread is not currently running. }
+ with
+ effect = ReadWriteEffect
+ out_of_line = True
+
primtype StackSnapshot#
{ Haskell representation of a @StgStack*@ that was created (cloned)
with a function in "GHC.Stack.CloneStack". Please check the
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1775,6 +1775,7 @@ emitPrimOp cfg primop =
TraceEventBinaryOp -> alwaysExternal
TraceMarkerOp -> alwaysExternal
SetThreadAllocationCounter -> alwaysExternal
+ SetOtherThreadAllocationCounter -> alwaysExternal
KeepAliveOp -> alwaysExternal
where
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -1173,6 +1173,7 @@ genPrim prof bound ty op = case op of
WhereFromOp -> unhandledPrimop op -- should be easily implementable with o.f.n
SetThreadAllocationCounter -> unhandledPrimop op
+ SetOtherThreadAllocationCounter -> unhandledPrimop op
------------------------------- Vector -----------------------------------------
-- For now, vectors are unsupported on the JS backend. Simply put, they do not
=====================================
libraries/ghc-experimental/ghc-experimental.cabal.in
=====================================
@@ -38,6 +38,7 @@ library
GHC.RTS.Flags.Experimental
GHC.Stats.Experimental
Prelude.Experimental
+ System.Mem.Experimental
if arch(wasm32)
exposed-modules: GHC.Wasm.Prim
other-extensions:
=====================================
libraries/ghc-experimental/src/System/Mem/Experimental.hs
=====================================
@@ -0,0 +1,10 @@
+module System.Mem.Experimental
+ ( setGlobalAllocationLimitHandler
+ , AllocationLimitKillBehaviour(..)
+ , getAllocationCounterFor
+ , setAllocationCounterFor
+ , enableAllocationLimitFor
+ , disableAllocationLimitFor
+ )
+ where
+import GHC.Internal.AllocationLimitHandler
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -122,6 +122,7 @@ Library
rts == 1.0.*
exposed-modules:
+ GHC.Internal.AllocationLimitHandler
GHC.Internal.ClosureTypes
GHC.Internal.Control.Arrow
GHC.Internal.Control.Category
=====================================
libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
=====================================
@@ -0,0 +1,114 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# OPTIONS_HADDOCK not-home #-}
+module GHC.Internal.AllocationLimitHandler
+ ( runAllocationLimitHandler
+ , setGlobalAllocationLimitHandler
+ , AllocationLimitKillBehaviour(..)
+ , getAllocationCounterFor
+ , setAllocationCounterFor
+ , enableAllocationLimitFor
+ , disableAllocationLimitFor
+ )
+ where
+import GHC.Internal.Base
+import GHC.Internal.Conc.Sync (ThreadId(..))
+import GHC.Internal.Data.IORef (IORef, readIORef, writeIORef, newIORef)
+import GHC.Internal.Foreign.C.Types
+import GHC.Internal.IO (unsafePerformIO)
+import GHC.Internal.Int (Int64(..))
+
+
+{-# NOINLINE allocationLimitHandler #-}
+allocationLimitHandler :: IORef (ThreadId -> IO ())
+allocationLimitHandler = unsafePerformIO (newIORef defaultHandler)
+
+defaultHandler :: ThreadId -> IO ()
+defaultHandler _ = pure ()
+
+foreign import ccall "setAllocLimitKill" setAllocLimitKill :: CBool -> CBool -> IO ()
+
+runAllocationLimitHandler :: ThreadId# -> IO ()
+runAllocationLimitHandler tid = do
+ hook <- getAllocationLimitHandler
+ hook $ ThreadId tid
+
+getAllocationLimitHandler :: IO (ThreadId -> IO ())
+getAllocationLimitHandler = readIORef allocationLimitHandler
+
+data AllocationLimitKillBehaviour =
+ KillOnAllocationLimit
+ -- ^ Throw a @AllocationLimitExceeded@ async exception to the thread when the
+ -- allocation limit is exceeded.
+ | DontKillOnAllocationLimit
+ -- ^ Do not throw an exception when the allocation limit is exceeded.
+
+-- | Define the behaviour for handling allocation limits.
+-- By default we throw a @AllocationLimitExceeded@ async exception to the thread.
+-- This can be controlled using @AllocationLimitKillBehaviour@.
+--
+-- We can also run a user-specified handler, which can be done in addition to
+-- or in place of the exception.
+-- This allows for instance logging on the allocation limit being exceeded,
+-- or dynamically determining whether to terminate the thread.
+-- The handler is not guaranteed to run before the thread is terminated or restarted.
+--
+-- Note: that if you don't terminate the thread, then the allocation limit gets
+-- removed.
+-- If you wish to keep the allocation limit you will have to reset it using
+-- @setAllocationCounter@ and @enableAllocationLimit@.
+setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> Maybe (ThreadId -> IO ()) -> IO ()
+setGlobalAllocationLimitHandler killBehaviour mHandler = do
+ shouldRunHandler <- case mHandler of
+ Just hook -> do
+ writeIORef allocationLimitHandler hook
+ pure 1
+ Nothing -> do
+ writeIORef allocationLimitHandler defaultHandler
+ pure 0
+ let shouldKill =
+ case killBehaviour of
+ KillOnAllocationLimit -> 1
+ DontKillOnAllocationLimit -> 0
+ setAllocLimitKill shouldKill shouldRunHandler
+
+-- | Retrieves the allocation counter for the another thread.
+foreign import prim "stg_getOtherThreadAllocationCounterzh" getOtherThreadAllocationCounter#
+ :: ThreadId#
+ -> State# RealWorld
+ -> (# State# RealWorld, Int64# #)
+
+-- | Get the allocation counter for a different thread.
+-- Note this doesn't take the current nursery chunk into account.
+-- If the thread is running then it may underestimate allocations by the size of a nursery thread.
+getAllocationCounterFor :: ThreadId -> IO Int64
+getAllocationCounterFor (ThreadId t#) = IO $ \s ->
+ case getOtherThreadAllocationCounter# t# s of (# s', i# #) -> (# s', I64# i# #)
+
+-- | Set the allocation counter for a different thread.
+-- This can be combined with 'enableAllocationLimitFor' to enable allocation limits for another thread.
+-- Note this doesn't take the current nursery chunk into account.
+-- If the thread is running then it may overestimate allocations by the size of a nursery thread,
+-- and trigger the limit sooner than expected.
+setAllocationCounterFor :: Int64 -> ThreadId -> IO ()
+setAllocationCounterFor (I64# i#) (ThreadId t#) = IO $ \s ->
+ case setOtherThreadAllocationCounter# i# t# s of s' -> (# s', () #)
+
+
+-- | Enable allocation limit processing the thread @t@.
+enableAllocationLimitFor :: ThreadId -> IO ()
+enableAllocationLimitFor (ThreadId t) = do
+ rts_enableThreadAllocationLimit t
+
+-- | Disable allocation limit processing the thread @t@.
+disableAllocationLimitFor :: ThreadId -> IO ()
+disableAllocationLimitFor (ThreadId t) = do
+ rts_disableThreadAllocationLimit t
+
+foreign import ccall unsafe "rts_enableThreadAllocationLimit"
+ rts_enableThreadAllocationLimit :: ThreadId# -> IO ()
+
+foreign import ccall unsafe "rts_disableThreadAllocationLimit"
+ rts_disableThreadAllocationLimit :: ThreadId# -> IO ()
=====================================
rts/Prelude.h
=====================================
@@ -67,6 +67,7 @@ PRELUDE_CLOSURE(ghczminternal_GHCziInternalziEventziWindows_processRemoteComplet
PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure);
PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure);
+PRELUDE_CLOSURE(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure);
PRELUDE_INFO(ghczminternal_GHCziInternalziCString_unpackCStringzh_info);
PRELUDE_INFO(ghczminternal_GHCziInternalziTypes_Czh_con_info);
@@ -102,6 +103,7 @@ PRELUDE_INFO(ghczminternal_GHCziInternalziStable_StablePtr_con_info);
#if defined(mingw32_HOST_OS)
#define processRemoteCompletion_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziEventziWindows_processRemoteCompletion_closure)
#endif
+#define runAllocationLimitHandler_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure)
#define flushStdHandles_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure)
#define runMainIO_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure)
=====================================
rts/PrimOps.cmm
=====================================
@@ -2889,6 +2889,11 @@ stg_getThreadAllocationCounterzh ()
return (StgTSO_alloc_limit(CurrentTSO) - TO_I64(offset));
}
+stg_getOtherThreadAllocationCounterzh ( gcptr t )
+{
+ return (StgTSO_alloc_limit(t));
+}
+
stg_setThreadAllocationCounterzh ( I64 counter )
{
// Allocation in the current block will be subtracted by
@@ -2901,6 +2906,12 @@ stg_setThreadAllocationCounterzh ( I64 counter )
return ();
}
+stg_setOtherThreadAllocationCounterzh ( I64 counter, gcptr t )
+{
+ StgTSO_alloc_limit(t) = counter;
+ return ();
+}
+
#define KEEP_ALIVE_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,c) \
w_ info_ptr, \
=====================================
rts/RtsStartup.c
=====================================
@@ -224,6 +224,7 @@ static void initBuiltinGcRoots(void)
* GHC.Core.Make.mkExceptionId.
*/
getStablePtr((StgPtr)absentSumFieldError_closure);
+ getStablePtr((StgPtr)runAllocationLimitHandler_closure);
}
void
=====================================
rts/RtsSymbols.c
=====================================
@@ -916,7 +916,9 @@ extern char **environ;
SymI_HasDataProto(stg_traceMarkerzh) \
SymI_HasDataProto(stg_traceBinaryEventzh) \
SymI_HasDataProto(stg_getThreadAllocationCounterzh) \
+ SymI_HasDataProto(stg_getOtherThreadAllocationCounterzh) \
SymI_HasDataProto(stg_setThreadAllocationCounterzh) \
+ SymI_HasDataProto(stg_setOtherThreadAllocationCounterzh) \
SymI_HasProto(getMonotonicNSec) \
SymI_HasProto(lockFile) \
SymI_HasProto(unlockFile) \
=====================================
rts/Schedule.c
=====================================
@@ -41,6 +41,7 @@
#include "Threads.h"
#include "Timer.h"
#include "ThreadPaused.h"
+#include "ThreadLabels.h"
#include "Messages.h"
#include "StablePtr.h"
#include "StableName.h"
@@ -94,6 +95,10 @@ StgWord recent_activity = ACTIVITY_YES;
*/
StgWord sched_state = SCHED_RUNNING;
+
+bool allocLimitKill = true;
+bool allocLimitRunHook = false;
+
/*
* This mutex protects most of the global scheduler data in
* the THREADED_RTS runtime.
@@ -1125,19 +1130,36 @@ schedulePostRunThread (Capability *cap, StgTSO *t)
}
}
- //
- // If the current thread's allocation limit has run out, send it
- // the AllocationLimitExceeded exception.
+ // Handle the current thread's allocation limit running out,
if (PK_Int64((W_*)&(t->alloc_limit)) < 0 && (t->flags & TSO_ALLOC_LIMIT)) {
- // Use a throwToSelf rather than a throwToSingleThreaded, because
- // it correctly handles the case where the thread is currently
- // inside mask. Also the thread might be blocked (e.g. on an
- // MVar), and throwToSingleThreaded doesn't unblock it
- // correctly in that case.
- throwToSelf(cap, t, allocationLimitExceeded_closure);
- ASSIGN_Int64((W_*)&(t->alloc_limit),
- (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE);
+ if(allocLimitKill) {
+ // Throw the AllocationLimitExceeded exception.
+ // Use a throwToSelf rather than a throwToSingleThreaded, because
+ // it correctly handles the case where the thread is currently
+ // inside mask. Also the thread might be blocked (e.g. on an
+ // MVar), and throwToSingleThreaded doesn't unblock it
+ // correctly in that case.
+ throwToSelf(cap, t, allocationLimitExceeded_closure);
+ ASSIGN_Int64((W_*)&(t->alloc_limit),
+ (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE);
+ } else {
+ // If we aren't killing the thread, we must disable the limit
+ // otherwise we will immediatelly retrigger it.
+ // User defined handlers should re-enable it if wanted.
+ t->flags = t->flags & ~TSO_ALLOC_LIMIT;
+ }
+
+ if(allocLimitRunHook)
+ {
+ // Create a thread to run the allocation limit handler.
+ StgClosure* c = rts_apply(cap, runAllocationLimitHandler_closure, (StgClosure*)t);
+ StgTSO* hookThread = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, c);
+ setThreadLabel(cap, hookThread, "allocation limit handler thread");
+ // Schedule the handler to be run immediatelly.
+ pushOnRunQueue(cap, hookThread);
+ }
+
}
/* some statistics gathering in the parallel case */
@@ -3342,3 +3364,9 @@ resurrectThreads (StgTSO *threads)
}
}
}
+
+void setAllocLimitKill(bool shouldKill, bool shouldHook)
+{
+ allocLimitKill = shouldKill;
+ allocLimitRunHook = shouldHook;
+}
=====================================
rts/external-symbols.list.in
=====================================
@@ -43,6 +43,7 @@ ghczminternal_GHCziInternalziTypes_Izh_con_info
ghczminternal_GHCziInternalziTypes_Fzh_con_info
ghczminternal_GHCziInternalziTypes_Dzh_con_info
ghczminternal_GHCziInternalziTypes_Wzh_con_info
+ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure
ghczminternal_GHCziInternalziPtr_Ptr_con_info
ghczminternal_GHCziInternalziPtr_FunPtr_con_info
ghczminternal_GHCziInternalziInt_I8zh_con_info
=====================================
rts/include/rts/storage/GC.h
=====================================
@@ -209,6 +209,10 @@ void flushExec(W_ len, AdjustorExecutable exec_addr);
// Used by GC checks in external .cmm code:
extern W_ large_alloc_lim;
+// Should triggering an allocation limit kill the thread
+// and should we run a user-defined hook when it is triggered.
+void setAllocLimitKill(bool, bool);
+
/* -----------------------------------------------------------------------------
Performing Garbage Collection
-------------------------------------------------------------------------- */
=====================================
rts/include/rts/storage/TSO.h
=====================================
@@ -157,9 +157,10 @@ typedef struct StgTSO_ {
/*
* The allocation limit for this thread, which is updated as the
* thread allocates. If the value drops below zero, and
- * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the
- * thread, and give the thread a little more space to handle the
- * exception before we raise the exception again.
+ * TSO_ALLOC_LIMIT is set in flags, then a handler is triggerd.
+ * Either we raise an exception in the thread, and give the thread
+ * a little more space to handle the exception before we raise the
+ * exception again; or we run a user defined handler.
*
* This is an integer, because we might update it in a place where
* it isn't convenient to raise the exception, so we want it to
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -604,7 +604,9 @@ RTS_FUN_DECL(stg_traceEventzh);
RTS_FUN_DECL(stg_traceBinaryEventzh);
RTS_FUN_DECL(stg_traceMarkerzh);
RTS_FUN_DECL(stg_getThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_getOtherThreadAllocationCounterzh);
RTS_FUN_DECL(stg_setThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_setOtherThreadAllocationCounterzh);
RTS_FUN_DECL(stg_castWord64ToDoublezh);
RTS_FUN_DECL(stg_castDoubleToWord64zh);
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6693,6 +6694,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6665,6 +6666,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -4610,6 +4610,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6836,6 +6837,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6693,6 +6694,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -10916,6 +10916,16 @@ module Prelude.Experimental where
data Unit# = ...
getSolo :: forall a. Solo a -> a
+module System.Mem.Experimental where
+ -- Safety: None
+ type AllocationLimitKillBehaviour :: *
+ data AllocationLimitKillBehaviour = KillOnAllocationLimit | DontKillOnAllocationLimit
+ disableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()
+ enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()
+ getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO GHC.Internal.Int.Int64
+ setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()
+ setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()) -> GHC.Types.IO ()
+
-- Instances:
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/rts/T22859.hs
=====================================
@@ -0,0 +1,71 @@
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Control.Exception
+import Control.Exception.Backtrace
+import Control.Concurrent
+import Control.Concurrent.MVar
+import System.Mem
+import System.Mem.Experimental
+import GHC.IO (IO (..))
+import GHC.Exts
+import System.IO
+
+-- | Just do some work and hPutStrLn to stderr to indicate that we are making progress
+worker :: IO ()
+worker = loop [] 2
+ where
+ loop !m !n
+ | n > 30 = hPutStrLn stderr . show $ length m
+ | otherwise = do
+ let x = show n
+ hPutStrLn stderr x
+ -- just to bulk out the allocations
+ IO (\s -> case newByteArray# 900000# s of (# s', arr# #) -> (# s', () #))
+ yield
+ loop (x:m) (n + 1)
+
+main :: IO ()
+main = do
+ done <- newMVar () -- we use this lock to wait for the worker to finish
+ started <- newEmptyMVar
+ let runWorker = do
+ forkIO . withMVar done $ \_ -> flip onException (hPutStrLn stderr "worker died") $ do
+ hPutStrLn stderr "worker starting"
+ putMVar started ()
+ setAllocationCounter 1_000_000
+ enableAllocationLimit
+ worker
+ hPutStrLn stderr "worker done"
+ takeMVar started
+ readMVar done
+ hFlush stderr
+ threadDelay 1000
+ -- default behaviour:
+ -- kill it after the limit is exceeded
+ hPutStrLn stderr "default behaviour"
+ runWorker
+ hPutStrLn stderr "just log once on the hook being triggered"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 1")
+ runWorker
+ hPutStrLn stderr "just log on the hook being triggered"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tid -> do
+ hPutStrLn stderr "allocation limit triggered 2"
+ -- re-enable the hook
+ setAllocationCounterFor 1_000_000 tid
+ enableAllocationLimitFor tid
+ runWorker
+ hPutStrLn stderr "kill from the hook"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tId -> throwTo tId AllocationLimitExceeded
+ runWorker
+ -- not super helpful, but let's test it anyway
+ hPutStrLn stderr "do nothing"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit Nothing
+ runWorker
+ -- this is possible to handle using an exception handler instead.
+ hPutStrLn stderr "kill and log"
+ setGlobalAllocationLimitHandler KillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 3")
+ runWorker
+ threadDelay 1000
+ hPutStrLn stderr "done"
=====================================
testsuite/tests/rts/T22859.stderr
=====================================
@@ -0,0 +1,152 @@
+default behaviour
+worker starting
+2
+3
+worker died
+T22859: allocation limit exceeded
+HasCallStack backtrace:
+ collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception
+ toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO
+ throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base
+
+
+just log once on the hook being triggered
+worker starting
+2
+3
+allocation limit triggered 1
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+29
+worker done
+just log on the hook being triggered
+worker starting
+2
+3
+allocation limit triggered 2
+4
+5
+allocation limit triggered 2
+6
+7
+allocation limit triggered 2
+8
+9
+allocation limit triggered 2
+10
+11
+allocation limit triggered 2
+12
+13
+allocation limit triggered 2
+14
+15
+allocation limit triggered 2
+16
+17
+allocation limit triggered 2
+18
+19
+allocation limit triggered 2
+20
+21
+allocation limit triggered 2
+22
+23
+allocation limit triggered 2
+24
+25
+allocation limit triggered 2
+26
+27
+allocation limit triggered 2
+28
+29
+allocation limit triggered 2
+30
+29
+worker done
+kill from the hook
+worker starting
+2
+3
+worker died
+T22859: allocation limit exceeded
+HasCallStack backtrace:
+ collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception
+ toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO
+ throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base
+
+
+do nothing
+worker starting
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+29
+worker done
+kill and log
+worker starting
+2
+3
+allocation limit triggered 3
+worker died
+T22859: allocation limit exceeded
+HasCallStack backtrace:
+ collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception
+ toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO
+ throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base
+
+
+done
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -643,3 +643,4 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru
test('T25560', [req_c_rts, ignore_stderr], compile_and_run, [''])
test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main'])
+test('T22859', [js_skip], compile_and_run, ['-with-rtsopts -A8K'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3d7e58c1e689091e0d900b319e3192…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3d7e58c1e689091e0d900b319e3192…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/int-index/visible-forall-gadts] Docs update 2
by Vladislav Zavialov (＠int-index) 10 Jun '25
by Vladislav Zavialov (＠int-index) 10 Jun '25
10 Jun '25
Vladislav Zavialov pushed to branch wip/int-index/visible-forall-gadts at Glasgow Haskell Compiler / GHC
Commits:
79866e89 by Vladislav Zavialov at 2025-06-10T12:01:53+03:00
Docs update 2
- - - - -
3 changed files:
- compiler/Language/Haskell/Syntax/Decls.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/exts/required_type_arguments.rst
Changes:
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -970,9 +970,10 @@ data ConDecl pass
-- The following fields describe the type after the '::'
-- See Note [GADT abstract syntax]
, con_outer_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass)
- -- ^ The outermost type variable binders, be they explicit or
- -- implicit. The 'XRec' is used to anchor exact print
- -- annotations, AnnForall and AnnDot.
+ -- ^ The outermost type variable binders, be they explicit or implicit;
+ -- cf. HsSigType that also stores the outermost sig_bndrs separately
+ -- from the forall telescopes in sig_body.
+ -- See Note [Representing type signatures] in Language.Haskell.Syntax.Type
, con_inner_bndrs :: [HsForAllTelescope pass]
-- ^ The forall telescopes other than the outermost invisible forall.
, con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -72,6 +72,18 @@ Language
* The :extension:`MonadComprehensions` extension now implies :extension:`ParallelListComp` as was originally intended (see `Monad Comprehensions <https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/monad_comprehension…>`_).
+* In accordance with `GHC Proposal #281 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0281-v…>`_,
+ section 4.7 "Data constructors", the :extension:`RequiredTypeArguments`
+ extension now allows visible forall in types of data constructors
+ (:ghc-ticket:`25127`). The following declaration is now accepted by GHC:
+
+ ::
+
+ data T a where
+ Typed :: forall a -> a -> T a
+
+ See :ref:`visible-forall-in-gadts` for details.
+
Compiler
~~~~~~~~
=====================================
docs/users_guide/exts/required_type_arguments.rst
=====================================
@@ -428,6 +428,8 @@ The :extension:`RequiredTypeArguments` extension does not add dependent
functions, which would be a much bigger step. Rather :extension:`RequiredTypeArguments`
just makes it possible for the type arguments of a function to be compulsory.
+.. _visible-forall-in-gadts:
+
Visible forall in GADTs
~~~~~~~~~~~~~~~~~~~~~~~
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/79866e89b641c9c80892fa9f6c4d2b2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/79866e89b641c9c80892fa9f6c4d2b2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/amg/castz] 9 commits: WIP: store CoVarSet instead of [Coercion] in ZCoercion
by Adam Gundry (＠adamgundry) 10 Jun '25
by Adam Gundry (＠adamgundry) 10 Jun '25
10 Jun '25
Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC
Commits:
f459ecc1 by Adam Gundry at 2025-06-09T21:13:49+02:00
WIP: store CoVarSet instead of [Coercion] in ZCoercion
- - - - -
34eae6a1 by Adam Gundry at 2025-06-09T20:31:23+01:00
WIP: use castCoToCo in arity and occurrence analysis
- - - - -
030a1d36 by Adam Gundry at 2025-06-09T20:31:37+01:00
WIP: use castCoToCo in rule matching
- - - - -
967543c7 by Adam Gundry at 2025-06-09T20:34:10+01:00
WIP: use castCoToCo in SimpleOpt
- - - - -
3734e3b9 by Adam Gundry at 2025-06-09T20:51:34+01:00
Tidy up mkCastZ
- - - - -
64177f47 by Adam Gundry at 2025-06-09T20:51:42+01:00
Improve Note [Zapped casts]
- - - - -
8cf3d717 by Adam Gundry at 2025-06-09T20:56:50+01:00
Tidy up utilities
- - - - -
3fb84e30 by Adam Gundry at 2025-06-09T21:16:39+01:00
Document that -fzap-casts is enabled by default
- - - - -
32459579 by Adam Gundry at 2025-06-09T21:24:20+01:00
Tidy up pprOptCastCoercion
- - - - -
21 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.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/Ppr.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/TyCo/Tidy.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Zonk/Type.hs
- docs/users_guide/debugging.rst
Changes:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -54,10 +54,7 @@ module GHC.Core.Coercion (
-- ** Cast coercions
castCoToCo,
- mkSymCastCo,
mkTransCastCo, mkTransCastCoCo, mkTransCoCastCo,
- mkPisCastCo,
- zapCo, zapCos, zapCastCo,
-- ** Decomposition
instNewTyCon_maybe,
@@ -76,7 +73,7 @@ module GHC.Core.Coercion (
pickLR,
isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,
- isReflCastCo, isReflexiveCastCo,
+ isReflexiveCastCo,
isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo,
mkCoherenceRightMCo,
@@ -2421,7 +2418,7 @@ seqMCo (MCo co) = seqCo co
seqCastCoercion :: CastCoercion -> ()
seqCastCoercion (CCoercion co) = seqCo co
-seqCastCoercion (ZCoercion ty cos) = seqType ty `seq` seqCos cos
+seqCastCoercion (ZCoercion ty cos) = seqType ty `seq` seqVarSet cos
seqCo :: Coercion -> ()
seqCo (Refl ty) = seqType ty
@@ -2858,54 +2855,23 @@ eqCastCoercionX env = eqTypeX env `on` castCoercionRKind
-- have discarded the original 'Coercion'.
castCoToCo :: Type -> CastCoercion -> CoercionR
castCoToCo _ (CCoercion co) = co
-castCoToCo lhs_ty (ZCoercion rhs_ty cos) = mkUnivCo ZCoercionProv cos Representational lhs_ty rhs_ty
-
-mkSymCastCo :: Type -> CastCoercion -> Coercion
-mkSymCastCo lhs_ty cco = mkSymCo (castCoToCo lhs_ty cco)
+castCoToCo lhs_ty (ZCoercion rhs_ty cos) = mkUnivCo ZCoercionProv (map CoVarCo (nonDetEltsUniqSet cos)) Representational lhs_ty rhs_ty
-- | Compose two 'CastCoercion's transitively, like 'mkTransCo'. If either is
-- zapped the whole result will be zapped.
mkTransCastCo :: HasDebugCallStack => CastCoercion -> CastCoercion -> CastCoercion
mkTransCastCo cco (CCoercion co) = mkTransCastCoCo cco co
-mkTransCastCo cco (ZCoercion ty cos) = ZCoercion ty (zapCastCo cco ++ cos)
+mkTransCastCo cco (ZCoercion ty cos) = ZCoercion ty (shallowCoVarsOfCastCo cco `unionVarSet` cos)
-- | Transitively compose a 'CastCoercion' followed by a 'Coercion'.
mkTransCastCoCo :: HasDebugCallStack => CastCoercion -> Coercion -> CastCoercion
mkTransCastCoCo (CCoercion co1) co2 = CCoercion (mkTransCo co1 co2)
-mkTransCastCoCo (ZCoercion _ cos) co2 = ZCoercion (coercionRKind co2) (zapCo co2 ++ cos)
+mkTransCastCoCo (ZCoercion _ cos) co2 = ZCoercion (coercionRKind co2) (shallowCoVarsOfCo co2 `unionVarSet` cos)
-- | Transitively compose a 'Coercion' followed by a 'CastCoercion'.
mkTransCoCastCo :: HasDebugCallStack => Coercion -> CastCoercion -> CastCoercion
mkTransCoCastCo co1 (CCoercion co2) = CCoercion (mkTransCo co1 co2)
-mkTransCoCastCo co1 (ZCoercion ty cos) = ZCoercion ty (zapCo co1 ++ cos)
-
--- TODO: Adapt this or rebuildLam to work for ZCoercion
-mkPisCastCo :: Role -> [Var] -> Type -> CastCoercion -> CastCoercion
-mkPisCastCo r vs expr_ty = CCoercion . mkPiCos r vs . castCoToCo expr_ty
-
-
-zapCo :: Coercion -> [Coercion]
-zapCo co = zapCos [co]
-
--- | Throw away the structure of coercions, retaining only the set of variables
--- on which they depend.
---
--- It is important we use only the *shallow* free CoVars here, because those are
--- the ones on which the original coercions necessarily depended and which may
--- be substituted away later. If we use the deep CoVars here, we can end up
--- retaining references to CoVars that are no longer in scope (see Note [Shallow
--- and deep free variables] in GHC.Core.TyCo.FVs).
-zapCos :: [Coercion] -> [Coercion]
-zapCos cos = map mkCoVarCo $ nonDetEltsUniqSet (shallowCoVarsOfCos cos) -- TODO nonDetEltsUniqSet justified?
-
-zapCastCo :: CastCoercion -> [Coercion]
-zapCastCo (CCoercion co) = zapCo co
-zapCastCo (ZCoercion _ cos) = cos
-
-
-isReflCastCo :: CastCoercion -> Bool
-isReflCastCo (CCoercion co) = isReflCo co
-isReflCastCo (ZCoercion _ _) = False -- TODO: track this?
+mkTransCoCastCo co1 (ZCoercion ty cos) = ZCoercion ty (shallowCoVarsOfCo co1 `unionVarSet` cos)
-- | Slowly checks if the coercion is reflexive. Don't call this in a loop,
-- as it walks over the entire coercion.
=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -279,7 +279,7 @@ expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc
cast_co_fvs :: CastCoercion -> FV
cast_co_fvs (CCoercion co) fv_cand in_scope acc = (tyCoFVsOfCo co) fv_cand in_scope acc
-cast_co_fvs (ZCoercion ty cos) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` mapUnionFV tyCoFVsOfCo cos) fv_cand in_scope acc
+cast_co_fvs (ZCoercion ty cos) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCoVarSet cos) fv_cand in_scope acc
---------
rhs_fvs :: (Id, CoreExpr) -> FV
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -2221,9 +2221,10 @@ etaInfoApp in_scope expr eis
go subst (Tick t e) eis
= Tick (substTickish subst t) (go subst e eis)
- go subst (Cast e (CCoercion co)) (EI bs mco) -- TODO: etaInfoApp ZCoercion
+ go subst (Cast e cco) (EI bs mco)
= go subst e (EI bs mco')
where
+ co = castCoToCo (exprType e) cco -- TODO: can we avoid this?
mco' = checkReflexiveMCo (Core.substCo subst co `mkTransMCoR` mco)
-- See Note [Check for reflexive casts in eta expansion]
@@ -2701,13 +2702,13 @@ same fix.
tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> SubDemand -> Maybe CoreExpr
-- Return an expression equal to (\bndrs. body)
tryEtaReduce rec_ids bndrs body eval_sd
- = go (reverse bndrs) body (CCoercion (mkRepReflCo (exprType body)))
+ = go (reverse bndrs) body (mkRepReflCo (exprType body))
where
incoming_arity = count isId bndrs -- See Note [Eta reduction makes sense], point (2)
go :: [Var] -- Binders, innermost first, types [a3,a2,a1]
-> CoreExpr -- Of type tr
- -> CastCoercion -- Of type tr ~ ts
+ -> Coercion -- Of type tr ~ ts
-> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts
-- See Note [Eta reduction with casted arguments]
-- for why we have an accumulating coercion
@@ -2717,7 +2718,7 @@ tryEtaReduce rec_ids bndrs body eval_sd
-- See Note [Eta reduction with casted function]
go bs (Cast e co1) co2
- = go bs e (co1 `mkTransCastCo` co2)
+ = go bs e (castCoToCo (exprType e) co1 `mkTransCo` co2)
go bs (Tick t e) co
| tickishFloatable t
@@ -2740,7 +2741,7 @@ tryEtaReduce rec_ids bndrs body eval_sd
, remaining_bndrs `ltLength` bndrs
-- Only reply Just if /something/ has happened
, ok_fun fun
- , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCastCo co
+ , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co
reduced_bndrs = mkVarSet (dropList remaining_bndrs bndrs)
-- reduced_bndrs are the ones we are eta-reducing away
, used_vars `disjointVarSet` reduced_bndrs
@@ -2749,7 +2750,7 @@ tryEtaReduce rec_ids bndrs body eval_sd
-- See Note [Eta reduction makes sense], intro and point (1)
-- NB: don't compute used_vars from exprFreeVars (mkCast fun co)
-- because the latter may be ill formed if the guard fails (#21801)
- = Just (mkLams (reverse remaining_bndrs) (mkCastCo fun co))
+ = Just (mkLams (reverse remaining_bndrs) (mkCast fun co))
go _remaining_bndrs _fun _ = -- pprTrace "tER fail" (ppr _fun $$ ppr _remaining_bndrs) $
Nothing
@@ -2797,17 +2798,17 @@ tryEtaReduce rec_ids bndrs body eval_sd
---------------
ok_arg :: Var -- Of type bndr_t
-> CoreExpr -- Of type arg_t
- -> CastCoercion -- Of kind (t1~t2)
+ -> Coercion -- Of kind (t1~t2)
-> Type -- Type (arg_t -> t1) of the function
-- to which the argument is supplied
- -> Maybe (CastCoercion -- Of type (arg_t -> t1 ~ bndr_t -> t2)
- -- (and similarly for tyvars, coercion args)
+ -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2)
+ -- (and similarly for tyvars, coercion args)
, [CoreTickish])
-- See Note [Eta reduction with casted arguments]
- ok_arg bndr (Type arg_ty) (CCoercion co) fun_ty
+ ok_arg bndr (Type arg_ty) co fun_ty
| Just tv <- getTyVar_maybe arg_ty
, bndr == tv = case splitForAllForAllTyBinder_maybe fun_ty of
- Just (Bndr _ vis, _) -> Just (CCoercion fco, [])
+ Just (Bndr _ vis, _) -> Just (fco, [])
where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag kco co
-- The lambda we are eta-reducing always has visibility
-- 'coreTyLamForAllTyFlag' which may or may not match
@@ -2817,24 +2818,23 @@ tryEtaReduce rec_ids bndrs body eval_sd
(text "fun:" <+> ppr bndr
$$ text "arg:" <+> ppr arg_ty
$$ text "fun_ty:" <+> ppr fun_ty)
- ok_arg bndr (Var v) (CCoercion co) fun_ty
+ ok_arg bndr (Var v) co fun_ty
| bndr == v
, let mult = idMult bndr
, Just (_af, fun_mult, _, _) <- splitFunTy_maybe fun_ty
, mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort
- = Just (CCoercion $ mkFunResCo Representational bndr co, [])
- ok_arg bndr (Cast e co_arg) (CCoercion co) fun_ty
+ = Just (mkFunResCo Representational bndr co, [])
+ ok_arg bndr (Cast e co_arg) co fun_ty
| (ticks, Var v) <- stripTicksTop tickishFloatable e
, Just (_, fun_mult, _, _) <- splitFunTy_maybe fun_ty
, bndr == v
, fun_mult `eqType` idMult bndr
- = Just (CCoercion $ mkFunCoNoFTF Representational (multToCo fun_mult) (mkSymCastCo (exprType e) co_arg) co, ticks)
+ = Just (mkFunCoNoFTF Representational (multToCo fun_mult) (mkSymCo (castCoToCo (exprType e) co_arg)) co, ticks)
-- The simplifier combines multiple casts into one,
-- so we can have a simple-minded pattern match here
ok_arg bndr (Tick t arg) co fun_ty
| tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty
= Just (co', t:ticks)
- -- TODO ok_arg for ZCoercion?
ok_arg _ _ _ _ = Nothing
-- | Can we eta-reduce the given function
@@ -3107,13 +3107,13 @@ collectBindersPushingCo e
go :: [Var] -> CoreExpr -> ([Var], CoreExpr)
-- The accumulator is in reverse order
go bs (Lam b e) = go (b:bs) e
- go bs (Cast e (CCoercion co)) = go_c bs e co -- TODO: ought to have ZCoercion case or go_c generalised
+ go bs (Cast e co) = go_c bs e (castCoToCo (exprType e) co) -- TODO: can we do better?
go bs e = (reverse bs, e)
-- We are in a cast; peel off casts until we hit a lambda.
go_c :: [Var] -> CoreExpr -> Coercion -> ([Var], CoreExpr)
-- (go_c bs e c) is same as (go bs e (e |> c))
- go_c bs (Cast e (CCoercion co1)) co2 = go_c bs e (co1 `mkTransCo` co2) -- TODO ditto
+ go_c bs (Cast e co1) co2 = go_c bs e (castCoToCo (exprType e) co1 `mkTransCo` co2) -- TODO: can we do better?
go_c bs (Lam b e) co = go_lam bs b e co
go_c bs e co = (reverse bs, mkCast e co)
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -2405,13 +2405,17 @@ coercionDmdEnv co = coercionsDmdEnv [co]
castCoercionDmdEnv :: CastCoercion -> DmdEnv
castCoercionDmdEnv (CCoercion co) = coercionDmdEnv co
-castCoercionDmdEnv (ZCoercion _ cos) = coercionsDmdEnv cos
+castCoercionDmdEnv (ZCoercion _ cos) = coVarSetDmdEnv cos
coercionsDmdEnv :: [Coercion] -> DmdEnv
coercionsDmdEnv cos
= mkTermDmdEnv $ mapVarEnv (const topDmd) $ getUniqSet $ coVarsOfCos cos
-- The VarSet from coVarsOfCos is really a VarEnv Var
+coVarSetDmdEnv :: CoVarSet -> DmdEnv
+coVarSetDmdEnv cos
+ = mkTermDmdEnv $ mapVarEnv (const topDmd) $ getUniqSet cos -- TODO shallow/deep confusion?
+
addVarDmd :: DmdType -> Var -> Demand -> DmdType
addVarDmd (DmdType fv ds) var dmd
= DmdType (addVarDmdEnv fv var dmd) ds
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -3435,8 +3435,8 @@ scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision
-- We use this same function in SpecConstr, and Simplify.Iteration,
-- when something binder-swap-like is happening
scrutOkForBinderSwap (Var v) = DoBinderSwap v MRefl
-scrutOkForBinderSwap (Cast (Var v) (CCoercion co)) -- TODO scrutOkForBinderSwap for ZCoercion
- | not (isDictId v) = DoBinderSwap v (MCo (mkSymCo co))
+scrutOkForBinderSwap (Cast (Var v) co)
+ | not (isDictId v) = DoBinderSwap v (MCo (mkSymCo (castCoToCo (idType v) co))) -- TODO: can we do better?
-- Cast: see Note [Case of cast]
-- isDictId: see Note [Care with binder-swap on dictionaries]
-- The isDictId rejects a Constraint/Constraint binder-swap, perhaps
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -644,7 +644,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)
mk_worker_unfolding top_lvl work_id work_rhs
= case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers
unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
- | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCastCo (exprType rhs) co) })
+ | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo (castCoToCo (exprType rhs) co)) })
_ -> mkLetUnfolding env top_lvl VanillaSrc work_id False work_rhs
tryCastWorkerWrapper env _ _ bndr rhs -- All other bindings
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1836,7 +1836,7 @@ rebuildLam env bndrs@(bndr:_) body cont
| -- Note [Casts and lambdas]
seCastSwizzle env
, not (any bad bndrs)
- = mkCastCo (mk_lams bndrs body) (mkPisCastCo Representational bndrs (exprType body) co)
+ = mkCast (mk_lams bndrs body) (mkPiCos Representational bndrs (castCoToCo (exprType body) co))
where
co_vars = tyCoVarsOfCastCo co
bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Literal( pprLiteral )
import GHC.Types.Name( pprInfixName, pprPrefixName )
import GHC.Types.Var
+import GHC.Types.Var.Set
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Demand
@@ -171,10 +172,12 @@ noParens pp = pp
pprOptCastCoercion :: CastCoercion -> SDoc
pprOptCastCoercion (CCoercion co) = pprOptCo co
-pprOptCastCoercion (ZCoercion ty cos) = -- TODO review ppr format
- sdocOption sdocSuppressCoercions $ \case
- True -> angleBrackets (text "ZapCo:" <> int (sum (map coercionSize cos))) <+> dcolon <+> co_type
- False -> parens $ sep [text "Zap", ppr cos, dcolon <+> co_type]
+pprOptCastCoercion (ZCoercion ty cos) = pprOptZappedCo ty cos
+
+pprOptZappedCo :: Type -> CoVarSet -> SDoc
+pprOptZappedCo ty cos = sdocOption sdocSuppressCoercions $ \case
+ True -> angleBrackets (text "ZapCo:" <> int (sizeVarSet cos)) <+> dcolon <+> co_type
+ False -> parens $ sep [text "ZapCo", ppr cos, dcolon <+> co_type]
where
co_type = sdocOption sdocSuppressCoercionTypes $ \case
True -> int (typeSize ty) <+> text "..."
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -1108,15 +1108,13 @@ match renv subst (Coercion co1) (Coercion co2) MRefl
-- Note [Casts in the target]
-- Note [Cancel reflexive casts]
-match renv subst e1 (Cast e2 (CCoercion co2)) mco
- = match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoR co2 mco))
+match renv subst e1 (Cast e2 co2) mco
+ = match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoR (castCoToCo (exprType e2) co2) mco))
-- checkReflexiveMCo: cancel casts if possible
-- This is important: see Note [Cancel reflexive casts]
-match renv subst (Cast e1 (CCoercion co1)) e2 mco
- = matchTemplateCast renv subst e1 co1 e2 mco
-
--- TODO: rule matching for ZCoercion
+match renv subst (Cast e1 co1) e2 mco
+ = matchTemplateCast renv subst e1 (castCoToCo (exprType e1) co1) e2 mco
------------------------ Literals ---------------------
match _ subst (Lit lit1) (Lit lit2) mco
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -33,6 +33,7 @@ import GHC.Core.DataCon
import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) )
import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
, isInScope, substTyVarBndr, cloneTyVarBndr )
+import GHC.Core.TyCo.Subst
import GHC.Core.Predicate( isCoVarType )
import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )
@@ -324,7 +325,7 @@ simple_opt_expr env expr
----------------------
go_cast_co (CCoercion co) = CCoercion (go_co co)
- go_cast_co (ZCoercion ty cos) = ZCoercion (substTyUnchecked subst ty) (substCos subst cos)
+ go_cast_co (ZCoercion ty cos) = ZCoercion (substTyUnchecked subst ty) (substCoVarSet subst cos)
go_co co = optCoercion (so_co_opts (soe_opts env)) subst co
@@ -439,14 +440,13 @@ simple_app env e as
finish_app :: HasDebugCallStack
=> SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
-- See Note [Eliminate casts in function position]
-finish_app env (Cast (Lam x e) (CCoercion co)) as@(_:_)
+finish_app env (Cast (Lam x e) cco) as@(_:_)
| not (isTyVar x) && not (isCoVar x)
+ , let co = castCoToCo (exprType (Lam x e)) cco
, assert (not $ x `elemVarSet` tyCoVarsOfCo co) True
, Just (x',e') <- pushCoercionIntoLambda (soeInScope env) x e co
= simple_app (soeZapSubst env) (Lam x' e') as
--- TODO: ZCoercion version of the finish_app
-
finish_app env fun args
= foldl mk_app fun args
where
@@ -1297,13 +1297,11 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
go subst floats (Tick t expr) cont
| not (tickishIsCode t) = go subst floats expr cont
- go subst floats (Cast expr (CCoercion co1)) (CC args m_co2)
- | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args
+ go subst floats (Cast expr co1) (CC args m_co2)
+ | Just (args', m_co1') <- pushCoArgs (subst_co subst (castCoToCo (exprType expr) co1)) args
-- See Note [Push coercions in exprIsConApp_maybe]
= go subst floats expr (CC args' (m_co1' `mkTransMCo` m_co2))
- -- TODO: ZCoercion in exprIsConApp_maybe
-
go subst floats (App fun arg) (CC args mco)
| let arg_type = exprType arg
, not (isTypeArg arg) && needsCaseBinding arg_type arg
@@ -1590,19 +1588,18 @@ exprIsLambda_maybe ise (Tick t e)
= Just (x, e, t:ts)
-- Also possible: A casted lambda. Push the coercion inside
-exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e (CCoercion co))
+exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e cco)
| Just (x, e,ts) <- exprIsLambda_maybe ise casted_e
-- Only do value lambdas.
-- this implies that x is not in scope in gamma (makes this code simpler)
, not (isTyVar x) && not (isCoVar x)
+ , let co = castCoToCo (exprType casted_e) cco
, assert (not $ x `elemVarSet` tyCoVarsOfCo co) True
, Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co
, let res = Just (x',e',ts)
= --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])
res
--- TODO: exprIsLambda_maybe for ZCoercion
-
-- Another attempt: See if we find a partial unfolding
exprIsLambda_maybe ise@(ISE in_scope_set id_unf) e
| (Var f, as, ts) <- collectArgsTicks tickishFloatable e
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -18,10 +18,10 @@ module GHC.Core.TyCo.FVs
coVarsOfType, coVarsOfTypes,
coVarsOfCo, coVarsOfCos,
coVarsOfCastCo,
- shallowCoVarsOfCos,
+ shallowCoVarsOfCo, shallowCoVarsOfCos, shallowCoVarsOfCastCo,
tyCoVarsOfCastCoercionDSet,
tyCoVarsOfCoDSet,
- tyCoFVsOfCo, tyCoFVsOfCos,
+ tyCoFVsOfCo, tyCoFVsOfCos, tyCoFVsOfCoVarSet,
tyCoVarsOfCoList,
coVarsOfCoDSet, coVarsOfCosDSet,
@@ -303,7 +303,7 @@ runTyCoVars f = appEndo f emptyVarSet
tyCoVarsOfCastCo :: CastCoercion -> TyCoVarSet
tyCoVarsOfCastCo (CCoercion co) = coVarsOfCo co
-tyCoVarsOfCastCo (ZCoercion ty cos) = tyCoVarsOfType ty `unionVarSet` tyCoVarsOfCos cos -- TODO: more efficient?
+tyCoVarsOfCastCo (ZCoercion ty cos) = tyCoVarsOfType ty `unionVarSet` cos
tyCoVarsOfType :: Type -> TyCoVarSet
-- The "deep" TyCoVars of the the type
@@ -412,6 +412,16 @@ shallowTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and sy
shallowCoVarsOfCos :: [Coercion] -> CoVarSet
shallowCoVarsOfCos cos = filterVarSet isCoVar $ shallowTyCoVarsOfCos cos
+shallowCoVarsOfCo :: Coercion -> CoVarSet
+shallowCoVarsOfCo co = filterVarSet isCoVar $ shallowTyCoVarsOfCo co
+
+shallowCoVarsOfType :: Type -> CoVarSet
+shallowCoVarsOfType ty = filterVarSet isCoVar $ shallowTyCoVarsOfType ty
+
+shallowCoVarsOfCastCo :: CastCoercion -> CoVarSet
+shallowCoVarsOfCastCo (CCoercion co) = shallowCoVarsOfCo co
+shallowCoVarsOfCastCo (ZCoercion ty cos) = shallowCoVarsOfType ty `unionVarSet` cos
+
{- *********************************************************************
* *
@@ -432,7 +442,7 @@ See #14880.
coVarsOfCastCo :: CastCoercion -> CoVarSet
coVarsOfCastCo (CCoercion co) = coVarsOfCo co
-coVarsOfCastCo (ZCoercion ty cos) = coVarsOfType ty `unionVarSet` coVarsOfCos cos -- TODO: more efficient?
+coVarsOfCastCo (ZCoercion ty cos) = coVarsOfType ty `unionVarSet` cos -- TODO cos doesn't include deep, this isn't enough?
-- See Note [Finding free coercion variables]
coVarsOfType :: Type -> CoVarSet
@@ -666,7 +676,10 @@ tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co
tyCoFVsOfCastCoercion :: CastCoercion -> FV
tyCoFVsOfCastCoercion (CCoercion co) = tyCoFVsOfCo co
-tyCoFVsOfCastCoercion (ZCoercion ty cos) = unionsFV (tyCoFVsOfType ty : map tyCoFVsOfCo cos)
+tyCoFVsOfCastCoercion (ZCoercion ty cos) = tyCoFVsOfType ty `unionFV` tyCoFVsOfCoVarSet cos
+
+tyCoFVsOfCoVarSet :: CoVarSet -> FV
+tyCoFVsOfCoVarSet = nonDetStrictFoldVarSet (unionFV . tyCoFVsOfCoVar) emptyFV -- TODO better way? Nondeterminism?
tyCoFVsOfCo :: Coercion -> FV
-- Extracts type and coercion variables from a coercion
=====================================
compiler/GHC/Core/TyCo/Ppr.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Types.Var
import GHC.Iface.Type
+import GHC.Types.Unique.Set
import GHC.Types.Var.Set
import GHC.Types.Var.Env
@@ -138,7 +139,7 @@ pprCastCo co = getPprStyle $ \ sty -> pprIfaceCastCoercion (tidyToIfaceCastCoSty
tidyToIfaceCastCoSty :: CastCoercion -> PprStyle -> IfaceCastCoercion
tidyToIfaceCastCoSty (CCoercion co) sty = IfaceCCoercion (tidyToIfaceCoSty co sty)
-tidyToIfaceCastCoSty (ZCoercion ty cos) sty = IfaceZCoercion (tidyToIfaceType ty) (map (flip tidyToIfaceCoSty sty) cos) -- TODO
+tidyToIfaceCastCoSty (ZCoercion ty cos) sty = IfaceZCoercion (tidyToIfaceType ty) (map (flip tidyToIfaceCoSty sty . CoVarCo) (nonDetEltsUniqSet cos)) -- TODO
tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion
tidyToIfaceCoSty co sty
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -77,7 +77,7 @@ import {-# SOURCE #-} GHC.Core.Type( chooseFunTyFlag, typeKind, typeTypeOrConstr
-- friends:
import GHC.Types.Var
-import GHC.Types.Var.Set( elemVarSet )
+import GHC.Types.Var.Set
import GHC.Core.TyCon
import GHC.Core.Coercion.Axiom
@@ -847,16 +847,17 @@ Note [Zapped casts]
~~~~~~~~~~~~~~~~~~~
A "zapped cast" is a Cast that does not store the full Coercion being used to
cast, but instead stores the type resulting from the cast and a set of CoVars
-used in the original coercion. This reduces the effectiveness of Core Lint,
-because it cannot check the original coercion.
+used in the original coercion. The CastCoercion type is used to represent
+the coercion argument to a cast; it may be either a full coercion (CCoercion)
+or zapped (ZCoercion).
Zapping casts is motivated by performance (see #8095 and related tickets).
Sometimes the structure of the coercion can be very large, for example when
using type families that take many reduction steps, and when Core Lint is
not being used, the full structure of the coercion is not needed. We merely
need the result type (to support exprType) and the set of coercion variables
-(to avoid floating a coercion out of the scope in which it is valid).
-TODO: reference another note about this.
+(to avoid floating a coercion out of the scope in which it is valid, see
+Note [The importance of tracking UnivCo dependencies]).
Zapped casts are introduced in exactly one place: finish_rewrite in
GHC.Tc.Solver.Solve. This uses a heuristic (isSmallCo) to determine whether
@@ -870,15 +871,32 @@ which is much smaller than:
This arises in practice with the Rep type family from GHC Generics.
+We can convert a ZCoercion back into a normal Coercion using castCoToCo to
+produce a UnivCo; such coercions can be identified for debugging with the
+ZCoercionProv provenance. This is sometimes necessary in the optimizer, when a
+Cast needs to be moved elsewhere. Since a UnivCo must store both the left and
+right hand side types, it is less compact than a ZCoercion, so it is best to
+avoid castCoToCo where possible.
+
The `-fzap-casts` and `-fno-zap-casts` flags can be used to enable or disable
cast zapping, for comparative performance testing or to ensure casts are not
-zapped when debugging the compiler. In addition, using `-dcore-lint` will
-automatically imply `-fno-zap-casts`.
+zapped when debugging the compiler.
+
+Zapping reduces the effectiveness of Core Lint, because it cannot check that
+the original coercion was well-typed. Thus `-dcore-lint` will automatically
+imply `-fno-zap-casts` for the same module. However, imported modules may still
+include zapped casts.
TODO: probably the boot libraries ought to be distributed with `-fno-zap-casts`,
so users can get full checks from `-dcore-lint`.
-TODO: for simplicity ZCoercion currently stores a list of Coercions, but in
-principle we need only the CoVars.
+ZCoercion discards the structure of the coercion, retaining only the set of variables
+on which it depends. It is important we store only the "shallow" free CoVars in the
+set, because those are the ones on which the original coercions necessarily depended
+and which may be substituted away later. If we use the deep CoVars, we can end up
+retaining references to CoVars that are no longer in scope. See also
+Note [Shallow and deep free variables] in GHC.Core.TyCo.FVs.
+
+TODO: review determinism; are our uses of nonDetEltsUniqSet and similar safe?
-}
@@ -887,7 +905,7 @@ principle we need only the CoVars.
-- and free CoVars. See Note [Zapped casts].
data CastCoercion
= CCoercion CoercionR -- Not zapped; the Coercion has Representational role
- | ZCoercion Type [Coercion] -- Zapped; the Coercions are just variables (TODO: use CoVarSet instead?)
+ | ZCoercion Type CoVarSet -- Zapped; stores only the RHS type and free CoVars
deriving Data.Data
-- | A 'Coercion' is concrete evidence of the equality/convertibility
@@ -2069,7 +2087,7 @@ typesSize tys = foldr ((+) . typeSize) 0 tys
castCoercionSize :: CastCoercion -> Int
castCoercionSize (CCoercion co) = coercionSize co
-castCoercionSize (ZCoercion ty cos) = typeSize ty + sum (map coercionSize cos)
+castCoercionSize (ZCoercion ty cos) = typeSize ty + sizeVarSet cos
coercionSize :: Coercion -> Int
coercionSize (Refl ty) = typeSize ty
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -34,7 +34,7 @@ module GHC.Core.TyCo.Subst
substTyUnchecked, substTysUnchecked, substScaledTysUnchecked, substThetaUnchecked,
substTyWithUnchecked, substScaledTyUnchecked,
substCoUnchecked, substCoWithUnchecked,
- substCastCo, substCastCoUnchecked,
+ substCastCo, substCoVarSet,
substTyWithInScope,
substTys, substScaledTys, substTheta,
lookupTyVar,
@@ -846,12 +846,12 @@ lookupTyVar (Subst _ _ tenv _) tv
lookupVarEnv tenv tv
substCastCo :: HasDebugCallStack => Subst -> CastCoercion -> CastCoercion
-substCastCo subst (CCoercion co) = CCoercion (substCo subst co)
-substCastCo subst (ZCoercion ty cos) = ZCoercion (substTy subst ty) (map (substCo subst) cos) -- TODO: zap?
+substCastCo subst (CCoercion co) = CCoercion (substCo subst co)
+substCastCo subst (ZCoercion ty cos) = ZCoercion (substTy subst ty) (substCoVarSet subst cos)
+
+substCoVarSet :: HasDebugCallStack => Subst -> CoVarSet -> CoVarSet
+substCoVarSet subst = nonDetStrictFoldVarSet (unionVarSet . shallowCoVarsOfCo . substCoVar subst) emptyVarSet -- TODO better impl; determinism?
-substCastCoUnchecked :: Subst -> CastCoercion -> CastCoercion
-substCastCoUnchecked subst (CCoercion co) = CCoercion (substCoUnchecked subst co)
-substCastCoUnchecked subst (ZCoercion ty cos) = ZCoercion (substTyUnchecked subst ty) (map (substCoUnchecked subst) cos) -- TODO: zap?
-- | Substitute within a 'Coercion'
-- The substitution has to satisfy the invariants described in
=====================================
compiler/GHC/Core/TyCo/Tidy.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.Core.TyCo.FVs
import GHC.Types.Name hiding (varName)
import GHC.Types.Var
import GHC.Types.Var.Env
+import GHC.Types.Var.Set
import GHC.Utils.Misc (strictMap)
import Data.List (mapAccumL)
@@ -366,4 +367,4 @@ tidyCos env = strictMap (tidyCo env)
tidyCastCo :: TidyEnv -> CastCoercion -> CastCoercion
tidyCastCo env (CCoercion co) = CCoercion (tidyCo env co)
-tidyCastCo env (ZCoercion ty cos) = ZCoercion (tidyType env ty) (tidyCos env cos)
+tidyCastCo env (ZCoercion ty cos) = ZCoercion (tidyType env ty) (mapVarSet (tidyTyCoVarOcc env) cos)
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -77,6 +77,7 @@ import GHC.Core.Type as Type
import GHC.Core.Predicate( isCoVarType )
import GHC.Core.FamInstEnv
import GHC.Core.TyCo.Compare( eqType, eqTypeX )
+import GHC.Core.TyCo.FVs
import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.TyCon
@@ -297,13 +298,13 @@ mkCast expr co
-- | Wrap the given expression in a zapped cast (see Note [Zapped casts] in
-- GHC.Core.TyCo.Rep).
-mkCastZ :: HasDebugCallStack => CoreExpr -> Type -> [Coercion] -> CoreExpr
+mkCastZ :: HasDebugCallStack => CoreExpr -> Type -> CoVarSet -> CoreExpr
mkCastZ expr ty cos =
case expr of
- Cast expr co -> mkCastZ expr ty (zapCastCo co ++ cos)
+ Cast expr co -> mkCastZ expr ty (shallowCoVarsOfCastCo co `unionVarSet` cos)
Tick t expr -> Tick t (mkCastZ expr ty cos)
- -- TODO: do we need other cases from mkCast?
- _ -> Cast expr (ZCoercion ty (zapCos cos))
+ Coercion e_co | isCoVarType ty -> Coercion (mkCoCastCo e_co (ZCoercion ty cos))
+ _ -> Cast expr (ZCoercion ty cos)
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -85,6 +85,7 @@ import GHC.Types.Tickish
import GHC.Types.Demand ( isNopSig )
import GHC.Types.Cpr ( topCprSig )
import GHC.Types.SrcLoc (unLoc)
+import GHC.Types.Unique.Set
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -275,7 +276,7 @@ toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x
----------------
toIfaceCastCoercion :: CastCoercion -> IfaceCastCoercion
toIfaceCastCoercion (CCoercion co) = IfaceCCoercion (toIfaceCoercion co)
-toIfaceCastCoercion (ZCoercion ty cos) = IfaceZCoercion (toIfaceType ty) (map toIfaceCoercion cos)
+toIfaceCastCoercion (ZCoercion ty cos) = IfaceZCoercion (toIfaceType ty) (map (toIfaceCoercion . CoVarCo) (nonDetEltsUniqSet cos)) -- TODO determinism
toIfaceCoercion :: Coercion -> IfaceCoercion
toIfaceCoercion = toIfaceCoercionX emptyVarSet
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -63,6 +63,7 @@ import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.Coercion.Axiom
import GHC.Core.FVs
+import GHC.Core.TyCo.FVs
import GHC.Core.TyCo.Rep -- needs to build types & coercions in a knot
import GHC.Core.TyCo.Subst ( substTyCoVars )
import GHC.Core.InstEnv
@@ -1566,7 +1567,7 @@ tcIfaceTyLit (IfaceCharTyLit n) = return (CharTyLit n)
tcIfaceCastCoercion :: IfaceCastCoercion -> IfL CastCoercion
tcIfaceCastCoercion (IfaceCCoercion co) = CCoercion <$> tcIfaceCo co
-tcIfaceCastCoercion (IfaceZCoercion ty cos) = ZCoercion <$> tcIfaceType ty <*> mapM tcIfaceCo cos
+tcIfaceCastCoercion (IfaceZCoercion ty cos) = ZCoercion <$> tcIfaceType ty <*> (shallowCoVarsOfCos <$> mapM tcIfaceCo cos)
tcIfaceCo :: IfaceCoercion -> IfL Coercion
tcIfaceCo = go
=====================================
compiler/GHC/Tc/Solver/Solve.hs
=====================================
@@ -36,6 +36,7 @@ import GHC.Core.Predicate
import GHC.Core.Reduction
import GHC.Core.Coercion
import GHC.Core.Class( classHasSCs )
+import GHC.Core.TyCo.FVs
import GHC.Core.TyCo.Rep (Coercion(..))
import GHC.Types.Id( idType )
@@ -1494,7 +1495,7 @@ finish_rewrite
mkCastCoercion :: Bool -> Type -> Coercion -> CastCoercion
mkCastCoercion zap_casts lhs_ty co
| isSmallCo co || not zap_casts = CCoercion co
- | otherwise = ZCoercion lhs_ty (zapCo co)
+ | otherwise = ZCoercion lhs_ty (shallowCoVarsOfCo co)
-- | Is this coercion probably smaller than its type? This is a rough heuristic,
-- but crucially we treat axioms (perhaps wrapped in Sym/Sub/etc.) as small
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -64,6 +64,7 @@ import GHC.Tc.Zonk.TcType
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.TyCon
+import GHC.Core.TyCo.FVs
import GHC.Utils.Outputable
import GHC.Utils.Misc
@@ -78,11 +79,13 @@ import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Var
import GHC.Types.Var.Env
+import GHC.Types.Var.Set
import GHC.Types.Id
import GHC.Types.TypeEnv
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Unique.FM
+import GHC.Types.Unique.Set
import GHC.Types.TyThing
import GHC.Tc.Types.BasicTypes
@@ -532,15 +535,18 @@ zonkScaledTcTypeToTypeX (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX m
zonkTcTypeToTypeX :: TcType -> ZonkTcM Type
zonkTcTypesToTypesX :: [TcType] -> ZonkTcM [Type]
zonkCoToCo :: Coercion -> ZonkTcM Coercion
-zonkCosToCos :: [Coercion] -> ZonkTcM [Coercion]
-(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, zonkCosToCos)
+_zonkCosToCos :: [Coercion] -> ZonkTcM [Coercion]
+(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _zonkCosToCos)
= case mapTyCoX zonk_tycomapper of
(zty, ztys, zco, zcos) ->
(ZonkT . flip zty, ZonkT . flip ztys, ZonkT . flip zco, ZonkT. flip zcos)
zonkCastCo :: CastCoercion -> ZonkTcM CastCoercion
zonkCastCo (CCoercion co) = CCoercion <$> zonkCoToCo co
-zonkCastCo (ZCoercion ty cos) = ZCoercion <$> zonkTcTypeToTypeX ty <*> zonkCosToCos cos
+zonkCastCo (ZCoercion ty cos) = ZCoercion <$> zonkTcTypeToTypeX ty <*> zonkCoVarSet cos
+
+zonkCoVarSet :: CoVarSet -> ZonkTcM CoVarSet
+zonkCoVarSet = fmap shallowCoVarsOfCos . mapM zonkCoVarOcc . nonDetEltsUniqSet
zonkScaledTcTypesToTypesX :: [Scaled TcType] -> ZonkTcM [Scaled Type]
zonkScaledTcTypesToTypesX scaled_tys =
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -1223,14 +1223,16 @@ Other
:type: dynamic
:since: TODO
+ :default: enabled
Reduce the size of Core terms by discarding coercion proofs that are needed
only for debugging the compiler. This usually helps improve compile-time
performance for some programs that make heavy use of type families.
- When this flag is enabled, Core Lint will be less effective at verifying the
- correctness of Core programs involving casts. Hence this is automatically
- switched off by :ghc-flag:`-dcore-lint`.
+ This is enabled by default. When it is enabled, Core Lint will be less
+ effective at verifying the correctness of Core programs involving casts.
+ Hence it is automatically switched off by :ghc-flag:`-dcore-lint`, or you
+ can disable it using ``-fno-zap-casts``.
.. ghc-flag:: -dno-typeable-binds
:shortdesc: Don't generate bindings for Typeable methods
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/adef6e9ba1968b1ab4d7dc1e46f57c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/adef6e9ba1968b1ab4d7dc1e46f57c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/int-index/visible-forall-gadts] Update documentation and comments
by Vladislav Zavialov (＠int-index) 09 Jun '25
by Vladislav Zavialov (＠int-index) 09 Jun '25
09 Jun '25
Vladislav Zavialov pushed to branch wip/int-index/visible-forall-gadts at Glasgow Haskell Compiler / GHC
Commits:
1c4190ad by Vladislav Zavialov at 2025-06-10T01:13:41+03:00
Update documentation and comments
- - - - -
3 changed files:
- compiler/GHC/Core/DataCon.hs
- docs/users_guide/exts/gadt_syntax.rst
- docs/users_guide/exts/required_type_arguments.rst
Changes:
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -642,12 +642,17 @@ Note [DataCon user type variable binders]
A DataCon has two different sets of type variables:
* dcUserTyVarBinders, for the type variables binders in the order in which they
- originally arose in the user-written type signature.
+ originally arose in the user-written type signature, and with user-specified
+ visibilities.
- They are the forall'd binders of the data con /wrapper/, which the user calls.
- - Their order *does* matter for TypeApplications, so they are full TyVarBinders,
- complete with visibilities.
+ - With RequiredTypeArguments, some of the foralls may be visible, e.g.
+ MkT :: forall a b. forall c -> (a, b, c) -> T a b c
+ so the binders are full TyVarBinders, complete with visibilities.
+
+ - Even if we only consider invisible foralls, the order and specificity of
+ binders matter for TypeApplications.
* dcUnivTyVars and dcExTyCoVars, for the "true underlying" (i.e. of the data
con worker) universal type variable and existential type/coercion variables,
@@ -659,8 +664,8 @@ A DataCon has two different sets of type variables:
and as a consequence, they do not come equipped with visibilities
(that is, they are TyVars/TyCoVars instead of ForAllTyBinders).
-Often (dcUnivTyVars ++ dcExTyCoVars) = dcUserTyVarBinders; but they may differ
-for two reasons, coming next:
+Often (dcUnivTyVars ++ dcExTyCoVars) = binderVars dcUserTyVarBinders; but they
+may differ for two reasons, coming next:
--- Reason (R1): Order of quantification in GADT syntax ---
=====================================
docs/users_guide/exts/gadt_syntax.rst
=====================================
@@ -124,19 +124,26 @@ grammar is subject to change in the future.
.. code-block:: none
- gadt_con ::= conids '::' opt_forall opt_ctxt gadt_body
+ gadt_con ::= conids '::' foralls opt_ctxt gadt_body
conids ::= conid
| conid ',' conids
- opt_forall ::= <empty>
- | 'forall' tv_bndrs '.'
+ foralls ::= <empty>
+ | forall_telescope foralls
- tv_bndrs ::= <empty>
- | tv_bndr tv_bndrs
+ forall_telescope ::= 'forall' tv_bndrs_spec '.'
+ | 'forall' tv_bndrs '->' -- with RequiredTypeArguments
- tv_bndr ::= tyvar
- | '(' tyvar '::' ctype ')'
+ tv_bndrs ::= <empty> | tv_bndr tv_bndrs
+ tv_bndrs_spec ::= <empty> | tv_bndr_spec tv_bndrs_spec
+
+ tv_bndr ::= tyvar
+ | '(' tyvar '::' ctype ')'
+
+ tv_bndr_spec ::= tv_bndr
+ | '{' tyvar '}'
+ | '{' tyvar '::' ctype '}'
opt_ctxt ::= <empty>
| btype '=>'
@@ -162,7 +169,7 @@ grammar is subject to change in the future.
| fieldname ',' fieldnames
opt_unpack ::= opt_bang
- : {-# UNPACK #-} opt_bang
+ | {-# UNPACK #-} opt_bang
| {-# NOUNPACK #-} opt_bang
opt_bang ::= <empty>
@@ -188,22 +195,25 @@ syntactically allowed. Some further various observations about this grammar:
- GADT constructor types are currently not permitted to have nested ``forall``\ s
or ``=>``\ s. (e.g., something like ``MkT :: Int -> forall a. a -> T`` would be
rejected.) As a result, ``gadt_sig`` puts all of its quantification and
- constraints up front with ``opt_forall`` and ``opt_context``. Note that
+ constraints up front with ``foralls`` and ``opt_context``. Note that
higher-rank ``forall``\ s and ``=>``\ s are only permitted if they do not appear
directly to the right of a function arrow in a `prefix_gadt_body`. (e.g.,
something like ``MkS :: Int -> (forall a. a) -> S`` is allowed, since
parentheses separate the ``forall`` from the ``->``.)
+
- Furthermore, GADT constructors do not permit outermost parentheses that
- surround the ``opt_forall`` or ``opt_ctxt``, if at least one of them are
+ surround the ``foralls`` or ``opt_ctxt``, if at least one of them are
used. For example, ``MkU :: (forall a. a -> U)`` would be rejected, since
it would treat the ``forall`` as being nested.
Note that it is acceptable to use parentheses in a ``prefix_gadt_body``.
For instance, ``MkV1 :: forall a. (a) -> (V1)`` is acceptable, as is
``MkV2 :: forall a. (a -> V2)``.
+
- The function arrows in a ``prefix_gadt_body``, as well as the function
arrow in a ``record_gadt_body``, are required to be used infix. For
example, ``MkA :: (->) Int A`` would be rejected.
+
- GHC uses the function arrows in a ``prefix_gadt_body`` and
``prefix_gadt_body`` to syntactically demarcate the function and result
types. Note that GHC does not attempt to be clever about looking through
@@ -224,6 +234,7 @@ syntactically allowed. Some further various observations about this grammar:
data B where
MkB :: B1 -> B2
+
- GHC will accept any combination of ``!``/``~`` and
``{-# UNPACK #-}``/``{-# NOUNPACK #-}``, although GHC will ignore some
combinations. For example, GHC will produce a warning if you write
=====================================
docs/users_guide/exts/required_type_arguments.rst
=====================================
@@ -427,3 +427,68 @@ coming from dependently-typed languages or proof assistants.
The :extension:`RequiredTypeArguments` extension does not add dependent
functions, which would be a much bigger step. Rather :extension:`RequiredTypeArguments`
just makes it possible for the type arguments of a function to be compulsory.
+
+Visible forall in GADTs
+~~~~~~~~~~~~~~~~~~~~~~~
+
+**Since:** GHC 9.14
+
+When :extension:`RequiredTypeArguments` is in effect, the use of ``forall a ->``
+in data constructor declarations is allowed: ::
+
+ data T a where
+ Typed :: forall a -> a -> T a
+
+There are no restrictions placed on the flavour of the parent declaration:
+the data constructor may be introduced as part of a ``data``, ``data instance``,
+``newtype``, or ``newtype instance`` declaration.
+
+The use of visible forall in the type of a data constructor imposes no
+restrictions on where the data constructor may occur. Examples:
+
+* in expressions ::
+
+ t1 = Typed Int 42
+ t2 = Typed String "hello"
+ t3 = Typed (Int -> Bool) even
+
+* in patterns ::
+
+ f1 (Typed a x) = x :: a
+ f2 (Typed Int n) = n*2
+ f3 (Typed ((->) w Bool) g) = not . g
+
+* in types (with :extension:`DataKinds`) ::
+
+ type T1 = Typed Nat 42
+ type T2 = Typed Symbol "hello"
+ type T3 = Typed (Type -> Constraint) Num
+
+At the moment, all foralls in the type of a data constructor (including visible
+foralls) must occur before constraints or value arguments: ::
+
+ data D x where
+ -- OK (one forall at the front of the type)
+ MkD1 :: forall a b ->
+ a ->
+ b ->
+ D (a, b)
+
+ -- OK (multpile foralls at the front of the type)
+ MkD2 :: forall a.
+ forall b ->
+ a ->
+ b ->
+ D (a, b)
+
+ -- Rejected (forall after a value argument)
+ MkD3 :: forall a ->
+ a ->
+ forall b ->
+ b ->
+ D (a, b)
+
+This restriction is intended to be lifted in the future (:ghc-ticket:`18389`).
+
+The use of visible forall instead of invisible forall has no effect on how data
+is represented on the heap.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c4190ad44f5bd2624ac275cd4a630d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c4190ad44f5bd2624ac275cd4a630d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0