[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
[Git][ghc/ghc][master] Fix various failures to -fprint-unicode-syntax
by Marge Bot (＠marge-bot) 09 Jun '25
by Marge Bot (＠marge-bot) 09 Jun '25
09 Jun '25
Marge Bot pushed to branch master 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
- - - - -
13 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
- 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)
=====================================
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/-/commit/e2467dbd01bd55a5cd279f628d18bde…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2467dbd01bd55a5cd279f628d18bde…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Hadrian: Add option to generate .hie files for stage1 libraries
by Marge Bot (＠marge-bot) 09 Jun '25
by Marge Bot (＠marge-bot) 09 Jun '25
09 Jun '25
Marge Bot pushed to branch master 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
- - - - -
9 changed files:
- 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
Changes:
=====================================
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" }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/35826d8b61b7c057dc8eff4c206eabc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/35826d8b61b7c057dc8eff4c206eabc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/krzysztof-cleanup] Minor misc cleanup
by Krzysztof Gogolewski (＠monoidal) 09 Jun '25
by Krzysztof Gogolewski (＠monoidal) 09 Jun '25
09 Jun '25
Krzysztof Gogolewski pushed to branch wip/krzysztof-cleanup at Glasgow Haskell Compiler / GHC
Commits:
101068c6 by Krzysztof Gogolewski at 2025-06-09T17:13:34+02:00
Minor misc cleanup
- Remove outdated comments
- Change mkFastString "literal" to fsLit "literal" so that the rule
fires, and move "literal" right next to fsLit in StgToCmm/Layout.hs
- Simplify code
- Add missing cases to rnfRuntimeRep
No functional change, except for the missing cases in rnfRuntimeRep.
- - - - -
8 changed files:
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/Stg/Utils.hs
- compiler/GHC/StgToCmm/Layout.hs
- compiler/GHC/Types/RepType.hs
- docs/users_guide/ghc_config.py.in
- libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -425,13 +425,11 @@ coreToStgExpr expr@(App _ _)
coreToStgExpr expr@(Lam _ _)
= let
(args, body) = myCollectBinders expr
- in
- case filterStgBinders args of
-
- [] -> coreToStgExpr body
+ in assertPpr
+ (null (filterStgBinders args))
+ (text "coreToStgExpr: unexpected value lambda: " $$ ppr expr)
+ (coreToStgExpr body)
- _ -> pprPanic "coretoStgExpr" $
- text "Unexpected value lambda:" $$ ppr expr
coreToStgExpr (Tick tick expr)
= do
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -391,7 +391,7 @@ import GHC.Types.Basic
import GHC.Core
import GHC.Core.DataCon
import GHC.Core.TyCon
-import GHC.Data.FastString (FastString, mkFastString, fsLit)
+import GHC.Data.FastString (FastString, fsLit)
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID)
@@ -681,7 +681,7 @@ elimCase rho args bndr (MultiValAlt _) [GenStgAlt{ alt_con = _
elimCase rho args@(tag_arg : real_args) bndr (MultiValAlt _) alts
| isUnboxedSumBndr bndr
- = do tag_bndr <- mkId (mkFastString "tag") tagTy
+ = do tag_bndr <- mkId (fsLit "tag") tagTy
-- this won't be used but we need a binder anyway
let rho1 = extendRho rho bndr (MultiVal args)
scrut' = case tag_arg of
@@ -871,10 +871,9 @@ mapSumIdBinders alt_bndr args rhs rho0
-- text "rhs" <+> ppr rhs $$
-- text "rhs_with_casts" <+> ppr rhs_with_casts
-- ) $
- if isMultiValBndr alt_bndr
- then return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs)
- else assert (typed_id_args `lengthIs` 1) $
- return (extendRho rho0 alt_bndr (UnaryVal (head typed_id_args)), rhs_with_casts rhs)
+ case typed_id_args of
+ [arg] -> return (extendRho rho0 alt_bndr (UnaryVal arg), rhs_with_casts rhs)
+ _ -> return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs)
-- Convert the argument to the given type, and wrap the conversion
-- around the given expression. Use the given Id as a name for the
@@ -923,7 +922,7 @@ mkUbxSum dc ty_args args0 us
= let
_ :| sum_slots = ubxSumRepType ty_args
-- drop tag slot
- field_slots = (mapMaybe (repSlotTy . stgArgRep) args0)
+ field_slots = (mapMaybe (repSlotTy . stgArgRep1) args0)
tag = dataConTag dc
layout' = layoutUbxSum sum_slots field_slots
@@ -1076,13 +1075,13 @@ unariseArgBinder is_con_arg rho x =
-- break the post-unarisation invariant that says unboxed tuple/sum
-- binders should vanish. See Note [Post-unarisation invariants].
| isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)
- -> do x' <- mkId (mkFastString "us") (primRepToType rep)
+ -> do x' <- mkId (fsLit "us") (primRepToType rep)
return (extendRho rho x (MultiVal [StgVarArg x']), [x'])
| otherwise
-> return (extendRhoWithoutValue rho x, [x])
reps -> do
- xs <- mkIds (mkFastString "us") (map primRepToType reps)
+ xs <- mkIds (fsLit "us") (map primRepToType reps)
return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
--------------------------------------------------------------------------------
@@ -1150,13 +1149,6 @@ mkIds fs tys = mkUnarisedIds fs tys
mkId :: FastString -> NvUnaryType -> UniqSM Id
mkId s t = mkUnarisedId s t
-isMultiValBndr :: Id -> Bool
-isMultiValBndr id
- | [_] <- typePrimRep (idType id)
- = False
- | otherwise
- = True
-
isUnboxedSumBndr :: Id -> Bool
isUnboxedSumBndr = isUnboxedSumType . idType
=====================================
compiler/GHC/Stg/Utils.hs
=====================================
@@ -41,9 +41,6 @@ mkUnarisedIds fs tys = mapM (mkUnarisedId fs) tys
mkUnarisedId :: MonadUnique m => FastString -> NvUnaryType -> m Id
mkUnarisedId s t = mkSysLocalM s ManyTy t
--- Checks if id is a top level error application.
--- isErrorAp_maybe :: Id ->
-
-- | Extract the default case alternative
-- findDefaultStg :: [Alt b] -> ([Alt b], Maybe (Expr b))
findDefaultStg
=====================================
compiler/GHC/StgToCmm/Layout.hs
=====================================
@@ -390,12 +390,12 @@ slowArgs platform args sccProfilingEnabled -- careful: reps contains voids (V),
stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat
this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args
save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just $ cccsExpr platform)]
- save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit $ "stg_restore_cccs_" ++ arg_reps)
- arg_reps = case maximum (fmap fst args1) of
- V64 -> "v64"
- V32 -> "v32"
- V16 -> "v16"
- _ -> "d"
+ save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId label_name
+ label_name = case maximum (fmap fst args1) of
+ V64 -> fsLit "stg_restore_cccs_v64"
+ V32 -> fsLit "stg_restore_cccs_v32"
+ V16 -> fsLit "stg_restore_cccs_v16"
+ _ -> fsLit "stg_restore_cccs_d"
=====================================
compiler/GHC/Types/RepType.hs
=====================================
@@ -295,11 +295,9 @@ instance Outputable SlotTy where
ppr FloatSlot = text "FloatSlot"
ppr (VecSlot n e) = text "VecSlot" <+> ppr n <+> ppr e
-repSlotTy :: [PrimRep] -> Maybe SlotTy
-repSlotTy reps = case reps of
- [] -> Nothing
- [rep] -> Just (primRepSlot rep)
- _ -> pprPanic "repSlotTy" (ppr reps)
+repSlotTy :: PrimOrVoidRep -> Maybe SlotTy
+repSlotTy VoidRep = Nothing
+repSlotTy (NVRep rep) = Just (primRepSlot rep)
primRepSlot :: PrimRep -> SlotTy
primRepSlot (BoxedRep mlev) = case mlev of
=====================================
docs/users_guide/ghc_config.py.in
=====================================
@@ -15,8 +15,6 @@ else:
libs_base_uri = '../libraries'
-# N.B. If you add a package to this list be sure to also add a corresponding
-# LIBRARY_VERSION macro call to configure.ac.
lib_versions = {
'base': '@LIBRARY_base_UNIT_ID@',
'ghc-prim': '@LIBRARY_ghc_prim_UNIT_ID@',
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs
=====================================
@@ -167,6 +167,9 @@ rnfKindRep (KindRepTypeLitD _ t) = rnfString t
rnfRuntimeRep :: RuntimeRep -> ()
rnfRuntimeRep (VecRep !_ !_) = ()
+rnfRuntimeRep (TupleRep rs) = rnfList rnfRuntimeRep rs
+rnfRuntimeRep (SumRep rs) = rnfList rnfRuntimeRep rs
+rnfRuntimeRep (BoxedRep !_) = ()
rnfRuntimeRep !_ = ()
rnfList :: (a -> ()) -> [a] -> ()
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2294,7 +2294,7 @@ instance ExactPrint (HsBind GhcPs) where
bind' <- markAnnotated bind
return (PatSynBind x bind')
- exact x = error $ "HsBind: exact for " ++ showAst x
+ exact (VarBind x _ _) = dataConCantHappen x
-- ---------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/101068c6fa26e0192dd91e44f63e347…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/101068c6fa26e0192dd91e44f63e347…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/krzysztof-cleanup
by Krzysztof Gogolewski (＠monoidal) 09 Jun '25
by Krzysztof Gogolewski (＠monoidal) 09 Jun '25
09 Jun '25
Krzysztof Gogolewski pushed new branch wip/krzysztof-cleanup at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/krzysztof-cleanup
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/amg/castz] WIP: introduce cast zapping as an alternative to coercion zapping
by Adam Gundry (＠adamgundry) 09 Jun '25
by Adam Gundry (＠adamgundry) 09 Jun '25
09 Jun '25
Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC
Commits:
adef6e9b by Adam Gundry at 2025-06-09T16:58:52+02:00
WIP: introduce cast zapping as an alternative to coercion zapping
- - - - -
54 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/LateCC/OverloadedCalls.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Map/Expr.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/Seq.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Stats.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Core/TyCo/Ppr.hs-boot
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Rep.hs-boot
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/TyCo/Tidy.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/HsToCore/Foreign/Prim.hs
- compiler/GHC/HsToCore/Foreign/Wasm.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Types/EvTerm.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Types/Id/Make.hs
- docs/core-spec/CoreLint.ott
- docs/core-spec/CoreSyn.ott
- docs/users_guide/debugging.rst
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/adef6e9ba1968b1ab4d7dc1e46f57ce…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/adef6e9ba1968b1ab4d7dc1e46f57ce…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
09 Jun '25
Adriaan Leijnse pushed to branch wip/aidylns/RecConWildE at Glasgow Haskell Compiler / GHC
Commits:
aa05ad6f by Adriaan Leijnse at 2025-06-09T15:11:42+02:00
RecConWildE
- - - - -
9 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/ThToHs.hs
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- + testsuite/tests/th/T24537.hs
- + testsuite/tests/th/T24537.stdout
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -60,7 +60,7 @@ templateHaskellNames = [
lamCasesEName, tupEName, unboxedTupEName, unboxedSumEName,
condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,
fromEName, fromThenEName, fromToEName, fromThenToEName,
- listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
+ listEName, sigEName, recConEName, recConWildEName, recUpdEName, staticEName, unboundVarEName,
labelEName, implicitParamVarEName, getFieldEName, projectionEName,
typeEName, forallEName, forallVisEName, constrainedEName,
-- FieldExp
@@ -347,10 +347,11 @@ fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
fromToEName = libFun (fsLit "fromToE") fromToEIdKey
fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
-- end ArithSeq
-listEName, sigEName, recConEName, recUpdEName :: Name
+listEName, sigEName, recConEName, recConWildEName, recUpdEName :: Name
listEName = libFun (fsLit "listE") listEIdKey
sigEName = libFun (fsLit "sigE") sigEIdKey
recConEName = libFun (fsLit "recConE") recConEIdKey
+recConWildEName = libFun (fsLit "recConWildE") recConWildEIdKey
recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
staticEName = libFun (fsLit "staticE") staticEIdKey
unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey
@@ -892,7 +893,7 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,
- getFieldEIdKey, projectionEIdKey, typeEIdKey, forallEIdKey,
+ getFieldEIdKey, projectionEIdKey, typeEIdKey, recConWildEIdKey, forallEIdKey,
forallVisEIdKey, constrainedEIdKey :: Unique
varEIdKey = mkPreludeMiscIdUnique 270
conEIdKey = mkPreludeMiscIdUnique 271
@@ -934,6 +935,7 @@ typeEIdKey = mkPreludeMiscIdUnique 306
forallEIdKey = mkPreludeMiscIdUnique 802
forallVisEIdKey = mkPreludeMiscIdUnique 803
constrainedEIdKey = mkPreludeMiscIdUnique 804
+recConWildEIdKey = mkPreludeMiscIdUnique 806
-- type FieldExp = ...
fieldExpIdKey :: Unique
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1666,7 +1666,7 @@ repE (ExplicitSum _ alt arity e)
repE (RecordCon { rcon_con = c, rcon_flds = flds })
= do { x <- lookupWithUserRdrLOcc c;
fs <- repFields flds;
- repRecCon x fs }
+ repRecCon x fs $ fmap (\(L _ (RecFieldsDotDot n)) -> n) $ rec_dotdot flds }
repE (RecordUpd { rupd_expr = e, rupd_flds = RegularRecUpdFields { recUpdFields = flds } })
= do { x <- repLE e;
fs <- repUpdFields flds;
@@ -1833,7 +1833,7 @@ repLGRHS (L _ (GRHS _ ss rhs))
; return (gs, guarded) }
repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp])
-repFields (HsRecFields { rec_flds = flds })
+repFields (HsRecFields { rec_flds = flds }) -- The select on field names here caused a bug in TH after rec_dotdot was added.
= repListM fieldExpTyConName rep_fld flds
where
rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
@@ -2580,8 +2580,14 @@ repListExp (MkC es) = rep2 listEName [es]
repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
-repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp))
-repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
+repRecCon :: Core TH.Name -> Core [M TH.FieldExp] -> Maybe Int -> MetaM (Core (M TH.Exp))
+repRecCon (MkC c) (MkC fs) hasWildCard =
+ case hasWildCard of
+ { Nothing -> rep2 recConEName [c,fs]
+ ; Just n -> do
+ MkC n' <- coreIntLit n
+ rep2 recConWildEName [c,fs,n']
+ }
repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp))
repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1180,9 +1180,8 @@ cvtl e = wrapLA (cvt e)
cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtSigType t
; let pe = parenthesizeHsExpr sigPrec e'
; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') }
- cvt (RecConE c flds) = do { c' <- cNameN c
- ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds
- ; return $ mkRdrRecordCon c' (HsRecFields noExtField flds' Nothing) noAnn }
+ cvt (RecConE c flds) = thToHsRecCon c flds Nothing
+ cvt (RecConWildE c flds n) = thToHsRecCon c flds (Just (L noAnn (RecFieldsDotDot n)))
cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds'
<- mapM (cvtFld (wrapParLA mkFieldOcc))
@@ -1226,6 +1225,11 @@ cvtl e = wrapLA (cvt e)
mkHsForAllVisTele noAnn tvs'
; return $ HsForAll noExtField tele body' }
+thToHsRecCon c flds maybeDotDot = do
+ { c' <- cNameN c
+ ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds
+ ; return $ mkRdrRecordCon c' (HsRecFields noExtField flds' maybeDotDot) noAnn }
+
{- | #16895 Ensure an infix expression's operator is a variable/constructor.
Consider this example:
=====================================
libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
=====================================
@@ -231,8 +231,9 @@ pprExp _ (ArithSeqE d) = ppr d
pprExp _ (ListE es) = brackets (commaSep es)
pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e
<+> dcolon <+> pprType sigPrec t
-pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields fs)
-pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
+pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields Nothing fs)
+pprExp _ (RecConWildE nm fs n) = pprName' Applied nm <> braces (pprFields (Just n) fs)
+pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields Nothing fs) -- FIXME: this can also have dots in surface syntax
pprExp i (StaticE e) = parensIf (i >= appPrec) $
text "static"<+> pprExp appPrec e
pprExp _ (UnboundVarE v) = pprName' Applied v
@@ -250,8 +251,16 @@ pprExp i (ForallE tvars body) =
pprExp i (ConstrainedE ctx body) =
parensIf (i >= funPrec) $ sep [pprCtxWith pprExp ctx, pprExp qualPrec body]
-pprFields :: [(Name,Exp)] -> Doc
-pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)
+-- See Note [DotDot fields] in Language.Haskell.Syntax.Pat.
+pprFields :: Maybe Int -> [(Name,Exp)] -> Doc
+pprFields dotdot fs =
+ sep
+ . punctuate comma
+ . (case dotdot of
+ Nothing -> id
+ Just n -> (`mappend` [text ".."]) . take n)
+ . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)
+ $ fs
pprMaybeExp :: Precedence -> Maybe Exp -> Doc
pprMaybeExp _ Nothing = empty
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
=====================================
@@ -378,6 +378,9 @@ sigE e t = do { e1 <- e; t1 <- t; pure (SigE e1 t1) }
recConE :: Quote m => Name -> [m (Name,Exp)] -> m Exp
recConE c fs = do { flds <- sequenceA fs; pure (RecConE c flds) }
+recConWildE :: Quote m => Name -> [m (Name,Exp)] -> Int -> m Exp
+recConWildE c fs n = do { flds <- sequenceA fs; pure (RecConWildE c flds n) }
+
recUpdE :: Quote m => m Exp -> [m (Name,Exp)] -> m Exp
recUpdE e fs = do { e1 <- e; flds <- sequenceA fs; pure (RecUpdE e1 flds) }
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -1885,6 +1885,11 @@ data Exp
| ListE [ Exp ] -- ^ @{ [1,2,3] }@
| SigE Exp Type -- ^ @{ e :: t }@
| RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@
+ -- Record constructor without a wild card.
+ | RecConWildE Name [FieldExp] Int -- ^ @{ T { x = y, z = w, ... } }@
+ -- I.e. like `RecConE` but with a wild card.
+ -- See Note [DotDot fields] in Language.Haskell.Syntax.Pat
+ -- for the meaning of the Int parameter.
| RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@
| StaticE Exp -- ^ @{ static e }@
| UnboundVarE Name -- ^ @{ _x }@
=====================================
testsuite/tests/th/T24537.hs
=====================================
@@ -0,0 +1,16 @@
+{-# Language TemplateHaskell #-}
+{-# Language RecordWildCards #-}
+module Main where
+
+import Language.Haskell.TH.Ppr
+
+data G = H { field0 :: Int, field1 :: String }
+
+main :: IO ()
+main = do
+ let pr mq = do
+ q <- mq
+ print q
+ print . pprint $ q
+ pr [e|let field0 = 3 in H {field0,..}|]
+ pr [e|let { field0 = 3; field1 = "a" } in H {field0,..}|]
=====================================
testsuite/tests/th/T24537.stdout
=====================================
@@ -0,0 +1,4 @@
+LetE [ValD (VarP field0_0) (NormalB (LitE (IntegerL 3))) []] (RecConWildE Main.H [(Main.field0,VarE field0_0)] 1)
+"let field0_0 = 3\n in Main.H{Main.field0 = field0_0, ..}"
+LetE [ValD (VarP field0_2) (NormalB (LitE (IntegerL 3))) [],ValD (VarP field1_1) (NormalB (LitE (StringL "a"))) []] (RecConWildE Main.H [(Main.field0,VarE field0_2),(Main.field1,VarE field1_1)] 1)
+"let {field0_0 = 3; field1_1 = \"a\"}\n in Main.H{Main.field0 = field0_0, ..}"
=====================================
testsuite/tests/th/all.T
=====================================
@@ -637,3 +637,4 @@ test('T25083', [extra_files(['T25083_A.hs', 'T25083_B.hs'])], multimod_compile_a
test('T25174', normal, compile, [''])
test('T25179', normal, compile, [''])
test('FunNameTH', normal, compile, [''])
+test('T24537', normal, compile_and_run, ['-v0 -ddump-splices -dsuppress-uniques'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aa05ad6fef59aa57785eceb74967229…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aa05ad6fef59aa57785eceb74967229…
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) 09 Jun '25
by Teo Camarasu (＠teo) 09 Jun '25
09 Jun '25
Teo Camarasu pushed to branch wip/T22859 at Glasgow Haskell Compiler / GHC
Commits:
fc2f44a3 by Teo Camarasu at 2025-06-09T15:06:01+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);
+ getStablePrt((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/fc2f44a3254dbafa6be037710e753a3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc2f44a3254dbafa6be037710e753a3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0