[Git][ghc/ghc][wip/T22802] 3 commits: rts: Use C11-compliant static assertion syntax
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Jan 27 13:09:10 UTC 2023
Simon Peyton Jones pushed to branch wip/T22802 at Glasgow Haskell Compiler / GHC
Commits:
e480fbc2 by Ben Gamari at 2023-01-27T05:01:24-05:00
rts: Use C11-compliant static assertion syntax
Previously we used `static_assert` which is only available in C23. By
contrast, C11 only provides `_Static_assert`.
Fixes #22777
- - - - -
2648c09c by Andrei Borzenkov at 2023-01-27T05:02:07-05:00
Replace errors from badOrigBinding with new one (#22839)
Problem: in 02279a9c the type-level [] syntax was changed from a built-in name
to an alias for the GHC.Types.List constructor. badOrigBinding assumes that if
a name is not built-in then it must have come from TH quotation, but this is
not necessarily the case with [].
The outdated assumption in badOrigBinding leads to incorrect error messages.
This code:
data []
Fails with "Cannot redefine a Name retrieved by a Template Haskell quote: []"
Unfortunately, there is not enough information in RdrName to directly determine
if the name was constructed via TH or by the parser, so this patch changes the
error message instead.
It unifies TcRnIllegalBindingOfBuiltIn and TcRnNameByTemplateHaskellQuote
into a new error TcRnBindingOfExistingName and changes its wording to avoid
guessing the origin of the name.
- - - - -
7e423687 by Simon Peyton Jones at 2023-01-27T13:09:47+00:00
Take account of loop breakers in specLookupRule
The key change is that in GHC.Core.Opt.Specialise.specLookupRule
we were using realIdUnfolding, which ignores the loop-breaker
flag. When given a loop breaker, rule matching therefore
looped infinitely -- #22802.
In fixing this I refactored a bit.
* Define GHC.Core.InScopeEnv as a data type, and use it.
(Previously it was a pair: hard to grep for.)
* Put several functions returning an IdUnfoldingFun into
GHC.Types.Id, namely
idUnfolding
alwaysActiveUnfoldingFun,
whenActiveUnfoldingFun,
noUnfoldingFun
and use them. (The are all loop-breaker aware.)
- - - - -
22 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- rts/include/Rts.h
- testsuite/tests/rename/should_fail/T14907b.stderr
- + testsuite/tests/rename/should_fail/T22839.hs
- + testsuite/tests/rename/should_fail/T22839.stderr
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/rename/should_fail/rnfail042.stderr
- + testsuite/tests/simplCore/should_compile/T22802.hs
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/th/T13968.stderr
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -83,7 +83,7 @@ module GHC.Core (
-- * Core rule data types
CoreRule(..),
- RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, RuleOpts,
+ RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts,
-- ** Operations on 'CoreRule's
ruleArity, ruleName, ruleIdName, ruleActivation,
@@ -1171,10 +1171,11 @@ data CoreRule
}
-- See Note [Extra args in the target] in GHC.Core.Rules
+type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
+
-- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are
-- currently in scope. See Note [The InScopeSet invariant].
-type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
-type InScopeEnv = (InScopeSet, IdUnfoldingFun)
+data InScopeEnv = ISE InScopeSet IdUnfoldingFun
type IdUnfoldingFun = Id -> Unfolding
-- A function that embodies how to unfold an Id if you need
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -2402,7 +2402,7 @@ match_cstring_foldr_lit _ _ _ _ _ = Nothing
-- Also, look into variable's unfolding just in case the expression we look for
-- is in a top-level thunk.
stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)
-stripStrTopTicks (_,id_unf) e = case e of
+stripStrTopTicks (ISE _ id_unf) e = case e of
Var v
| Just rhs <- expandUnfolding_maybe (id_unf v)
-> stripTicksTop tickishFloatable rhs
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1241,14 +1241,13 @@ getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
-- is 'otherwise' which we want exprIsConApp_maybe to be able to
-- see very early on
getUnfoldingInRuleMatch env
- = (in_scope, id_unf)
+ = ISE in_scope id_unf
where
in_scope = seInScope env
- id_unf id | unf_is_active id = idUnfolding id
- | otherwise = NoUnfolding
- unf_is_active id = isActive (sePhase env) (idInlineActivation id)
- -- When sm_rules was off we used to test for a /stable/ unfolding,
- -- but that seems wrong (#20941)
+ phase = sePhase env
+ id_unf = whenActiveUnfoldingFun (isActive phase)
+ -- When sm_rules was off we used to test for a /stable/ unfolding,
+ -- but that seems wrong (#20941)
----------------------
activeRule :: SimplMode -> Activation -> Bool
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1626,11 +1626,11 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- See Note [Inline specialisations] for why we do not
-- switch off specialisation for inline functions
- = do { -- debugTraceMsg (text "specCalls: some" <+> vcat
- -- [ text "function" <+> ppr fn
- -- , text "calls:" <+> ppr calls_for_me
- -- , text "subst" <+> ppr (se_subst env) ])
- ; foldlM spec_call ([], [], emptyUDs) calls_for_me }
+ = -- pprTrace "specCalls: some" (vcat
+ -- [ text "function" <+> ppr fn
+ -- , text "calls:" <+> ppr calls_for_me
+ -- , text "subst" <+> ppr (se_subst env) ]) $
+ foldlM spec_call ([], [], emptyUDs) calls_for_me
| otherwise -- No calls or RHS doesn't fit our preconceptions
= warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn))
@@ -1685,7 +1685,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
, rule_bndrs, rule_lhs_args
, spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
--- ; debugTraceMsg (text "spec_call" <+> vcat
+-- ; pprTrace "spec_call" (vcat
-- [ text "fun: " <+> ppr fn
-- , text "call info: " <+> ppr _ci
-- , text "useful: " <+> ppr useful
@@ -1698,7 +1698,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- , text "rhs_bndrs" <+> ppr rhs_bndrs
-- , text "rhs_body" <+> ppr rhs_body
-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
--- , ppr dx_binds ]
+-- , ppr dx_binds ]) $
+-- return ()
; if not useful -- No useful specialisation
|| already_covered rhs_env2 rules_acc rule_lhs_args
@@ -1795,12 +1796,13 @@ specLookupRule :: SpecEnv -> Id -> [CoreExpr]
-> CompilerPhase -- Look up rules as if we were in this phase
-> [CoreRule] -> Maybe (CoreRule, CoreExpr)
specLookupRule env fn args phase rules
- = lookupRule ropts (in_scope, realIdUnfolding) is_active fn args rules
+ = lookupRule ropts in_scope_env is_active fn args rules
where
- dflags = se_dflags env
- in_scope = getSubstInScope (se_subst env)
- ropts = initRuleOpts dflags
- is_active = isActive phase
+ dflags = se_dflags env
+ in_scope = getSubstInScope (se_subst env)
+ in_scope_env = ISE in_scope (whenActiveUnfoldingFun is_active)
+ ropts = initRuleOpts dflags
+ is_active = isActive phase
{- Note [Specialising DFuns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -514,7 +514,7 @@ lookupRule :: RuleOpts -> InScopeEnv
-- See Note [Extra args in the target]
-- See comments on matchRule
-lookupRule opts rule_env@(in_scope,_) is_active fn args rules
+lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules
= -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $
case go [] rules of
[] -> Nothing
@@ -574,11 +574,12 @@ isMoreSpecific _ (Rule {}) (BuiltinRule {}) = True
isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })
(Rule { ru_bndrs = bndrs2, ru_args = args2
, ru_name = rule_name2, ru_rhs = rhs2 })
- = isJust (matchN (full_in_scope, id_unfolding_fun)
+ = isJust (matchN in_scope_env
rule_name2 bndrs2 args2 args1 rhs2)
where
- id_unfolding_fun _ = NoUnfolding -- Don't expand in templates
full_in_scope = in_scope `extendInScopeSetList` bndrs1
+ in_scope_env = ISE full_in_scope noUnfoldingFun
+ -- noUnfoldingFun: don't expand in templates
noBlackList :: Activation -> Bool
noBlackList _ = False -- Nothing is black listed
@@ -687,7 +688,7 @@ matchN :: InScopeEnv
-- trailing ones, returning the result of applying the rule to a prefix
-- of the actual arguments.
-matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs
+matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs
= do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es
; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst)
(mkEmptySubst in_scope) $
@@ -872,7 +873,7 @@ see `init_menv` in `matchN`.
-}
rvInScopeEnv :: RuleMatchEnv -> InScopeEnv
-rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv)
+rvInScopeEnv renv = ISE (rnInScopeSet (rv_lcl renv)) (rv_unf renv)
-- * The domain of the TvSubstEnv and IdSubstEnv are the template
-- variables passed into the match.
@@ -1686,7 +1687,7 @@ ruleAppCheck_help env fn args rules
= text "Rule" <+> doubleQuotes (ftext name)
rule_info opts rule
- | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env)
+ | Just _ <- matchRule opts (ISE emptyInScopeSet (rc_id_unf env))
noBlackList fn args rough_args rule
= text "matches (which is very peculiar!)"
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -242,7 +242,7 @@ simple_opt_expr env expr
rec_ids = soe_rec_ids env
subst = soe_subst env
in_scope = getSubstInScope subst
- in_scope_env = (in_scope, simpleUnfoldingFun)
+ in_scope_env = ISE in_scope alwaysActiveUnfoldingFun
---------------
go (Var v)
@@ -761,11 +761,6 @@ add_info env old_bndr top_level new_rhs new_bndr
False -- may be bottom or not
new_rhs Nothing
-simpleUnfoldingFun :: IdUnfoldingFun
-simpleUnfoldingFun id
- | isAlwaysActive (idInlineActivation id) = idUnfolding id
- | otherwise = noUnfolding
-
wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Nothing body = body
wrapLet (Just (b,r)) body = Let (NonRec b r) body
@@ -1184,7 +1179,7 @@ data ConCont = CC [CoreExpr] Coercion
exprIsConApp_maybe :: HasDebugCallStack
=> InScopeEnv -> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
-exprIsConApp_maybe (in_scope, id_unf) expr
+exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
= go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr)))
where
go :: Either InScopeSet Subst
@@ -1304,7 +1299,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr
| (fun `hasKey` unpackCStringIdKey) ||
(fun `hasKey` unpackCStringUtf8IdKey)
, [arg] <- args
- , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg
+ , Just (LitString str) <- exprIsLiteral_maybe ise arg
= succeedWith in_scope floats $
dealWithStringLiteral fun str co
where
@@ -1400,7 +1395,7 @@ exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
-- Nevertheless we do need to look through unfoldings for
-- string literals, which are vigorously hoisted to top level
-- and not subsequently inlined
-exprIsLiteral_maybe env@(_, id_unf) e
+exprIsLiteral_maybe env@(ISE _ id_unf) e
= case e of
Lit l -> Just l
Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?
@@ -1430,14 +1425,14 @@ exprIsLambda_maybe _ (Lam x e)
= Just (x, e, [])
-- Still straightforward: Ticks that we can float out of the way
-exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e)
+exprIsLambda_maybe ise (Tick t e)
| tickishFloatable t
- , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e
+ , Just (x, e, ts) <- exprIsLambda_maybe ise e
= Just (x, e, t:ts)
-- Also possible: A casted lambda. Push the coercion inside
-exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
- | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e
+exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co)
+ | 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)
@@ -1448,7 +1443,7 @@ exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
res
-- Another attempt: See if we find a partial unfolding
-exprIsLambda_maybe (in_scope_set, id_unf) e
+exprIsLambda_maybe ise@(ISE in_scope_set id_unf) e
| (Var f, as, ts) <- collectArgsTicks tickishFloatable e
, idArity f > count isValArg as
-- Make sure there is hope to get a lambda
@@ -1456,7 +1451,7 @@ exprIsLambda_maybe (in_scope_set, id_unf) e
-- Optimize, for beta-reduction
, let e' = simpleOptExprWith defaultSimpleOpts (mkEmptySubst in_scope_set) (rhs `mkApps` as)
-- Recurse, because of possible casts
- , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
+ , Just (x', e'', ts') <- exprIsLambda_maybe ise e'
, let res = Just (x', e'', ts++ts')
= -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])
res
=====================================
compiler/GHC/HsToCore/Pmc/Solver.hs
=====================================
@@ -881,7 +881,7 @@ addCoreCt nabla x e = do
where
expr_ty = exprType e
expr_in_scope = mkInScopeSet (exprFreeVars e)
- in_scope_env = (expr_in_scope, const NoUnfolding)
+ in_scope_env = ISE expr_in_scope noUnfoldingFun
-- It's inconvenient to get hold of a global in-scope set
-- here, but it'll only be needed if exprIsConApp_maybe ends
-- up substituting inside a forall or lambda (i.e. seldom)
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -187,7 +187,7 @@ newTopSrcBinder (L loc rdr_name)
if isExternalName name then
do { this_mod <- getModule
; unless (this_mod == nameModule name)
- (addErrAt (locA loc) (badOrigBinding rdr_name))
+ (addErrAt (locA loc) (TcRnBindingOfExistingName rdr_name))
; return name }
else -- See Note [Binders in Template Haskell] in "GHC.ThToHs"
do { this_mod <- getModule
@@ -196,7 +196,7 @@ newTopSrcBinder (L loc rdr_name)
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { this_mod <- getModule
; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
- (addErrAt (locA loc) (badOrigBinding rdr_name))
+ (addErrAt (locA loc) (TcRnBindingOfExistingName rdr_name))
-- When reading External Core we get Orig names as binders,
-- but they should agree with the module gotten from the monad
--
@@ -205,7 +205,7 @@ newTopSrcBinder (L loc rdr_name)
-- the constructor is parsed as a type, and then GHC.Parser.PostProcess.tyConToDataCon
-- uses setRdrNameSpace to make it into a data constructors. At that point
-- the nice Exact name for the TyCon gets swizzled to an Orig name.
- -- Hence the badOrigBinding error message.
+ -- Hence the TcRnBindingOfExistingName error message.
--
-- MP 2022: I suspect this code path is never called for `rOOT_MAIN` anymore
@@ -2118,13 +2118,3 @@ lookupQualifiedDoName ctxt std_name
= case qualifiedDoModuleName_maybe ctxt of
Nothing -> lookupSyntaxName std_name
Just modName -> lookupNameWithQualifier std_name modName
-
-
--- Error messages
-
-badOrigBinding :: RdrName -> TcRnMessage
-badOrigBinding name
- | Just _ <- isBuiltInOcc_maybe occ = TcRnIllegalBindingOfBuiltIn occ
- | otherwise = TcRnNameByTemplateHaskellQuote name
- where
- occ = rdrNameOcc $ filterCTuple name
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Tc.Errors.Ppr
import GHC.Prelude
import GHC.Builtin.Names
-import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon )
+import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon, filterCTuple )
import GHC.Core.Coercion
import GHC.Core.Unify ( tcMatchTys )
@@ -968,10 +968,6 @@ instance Diagnostic TcRnMessage where
-> mkSimpleDecorated $
text "You cannot SPECIALISE" <+> quotes (ppr name)
<+> text "because its definition is not visible in this module"
- TcRnNameByTemplateHaskellQuote name -> mkSimpleDecorated $
- text "Cannot redefine a Name retrieved by a Template Haskell quote:" <+> ppr name
- TcRnIllegalBindingOfBuiltIn name -> mkSimpleDecorated $
- text "Illegal binding of built-in syntax:" <+> ppr name
TcRnPragmaWarning {pragma_warning_occ, pragma_warning_msg, pragma_warning_import_mod, pragma_warning_defined_mod}
-> mkSimpleDecorated $
sep [ sep [ text "In the use of"
@@ -1238,6 +1234,8 @@ instance Diagnostic TcRnMessage where
Left gbl_names -> vcat (map (\name -> quotes (ppr $ grePrintableName name) <+> pprNameProvenance name) gbl_names)
Right lcl_name -> quotes (ppr lcl_name) <+> text "defined at"
<+> ppr (nameSrcLoc lcl_name)
+ TcRnBindingOfExistingName name -> mkSimpleDecorated $
+ text "Illegal binding of an existing name:" <+> ppr (filterCTuple name)
diagnosticReason = \case
TcRnUnknownMessage m
@@ -1552,10 +1550,6 @@ instance Diagnostic TcRnMessage where
-> WarningWithoutFlag
TcRnSpecialiseNotVisible{}
-> WarningWithoutFlag
- TcRnNameByTemplateHaskellQuote{}
- -> ErrorWithoutFlag
- TcRnIllegalBindingOfBuiltIn{}
- -> ErrorWithoutFlag
TcRnPragmaWarning{}
-> WarningWithFlag Opt_WarnWarningsDeprecations
TcRnIllegalHsigDefaultMethods{}
@@ -1646,6 +1640,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnCapturedTermName{}
-> WarningWithFlag Opt_WarnTermVariableCapture
+ TcRnBindingOfExistingName{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -1962,10 +1958,6 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnSpecialiseNotVisible name
-> [SuggestSpecialiseVisibilityHints name]
- TcRnNameByTemplateHaskellQuote{}
- -> noHints
- TcRnIllegalBindingOfBuiltIn{}
- -> noHints
TcRnPragmaWarning{}
-> noHints
TcRnIllegalHsigDefaultMethods{}
@@ -2059,6 +2051,8 @@ instance Diagnostic TcRnMessage where
-> [suggestExtension LangExt.TupleSections]
TcRnCapturedTermName{}
-> [SuggestRenameTypeVariable]
+ TcRnBindingOfExistingName{}
+ -> noHints
diagnosticCode = constructorCode
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -2193,32 +2193,6 @@ data TcRnMessage where
-}
TcRnSpecialiseNotVisible :: !Name -> TcRnMessage
- {- TcRnNameByTemplateHaskellQuote is an error that occurs when one tries
- to use a Template Haskell splice to define a top-level identifier with
- an already existing name.
-
- (See issue #13968 (closed) on GHC's issue tracker for more details)
-
- Example(s):
-
- $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])
-
- Test cases:
- T13968
- -}
- TcRnNameByTemplateHaskellQuote :: !RdrName -> TcRnMessage
-
- {- TcRnIllegalBindingOfBuiltIn is an error that occurs when one uses built-in
- syntax for data constructors or class names.
-
- Use an OccName here because we don't want to print Prelude.(,)
-
- Test cases:
- rename/should_fail/T14907b
- rename/should_fail/rnfail042
- -}
- TcRnIllegalBindingOfBuiltIn :: !OccName -> TcRnMessage
-
{- TcRnPragmaWarning is a warning that can happen when usage of something
is warned or deprecated by pragma.
@@ -2773,6 +2747,22 @@ data TcRnMessage where
-}
TcRnSectionWithoutParentheses :: HsExpr GhcPs -> TcRnMessage
+ {- TcRnBindingOfExistingName is an error triggered by an attempt to rebind
+ built-in syntax, punned list or tuple syntax, or a name quoted via Template Haskell.
+
+ Examples:
+
+ data []
+ data (->)
+ $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])
+
+ Test cases: rename/should_fail/T14907b
+ rename/should_fail/T22839
+ rename/should_fail/rnfail042
+ th/T13968
+ -}
+ TcRnBindingOfExistingName :: RdrName -> TcRnMessage
+
deriving Generic
-- | Things forbidden in @type data@ declarations.
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -468,8 +468,6 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnNonOverloadedSpecialisePragma" = 35827
GhcDiagnosticCode "TcRnSpecialiseNotVisible" = 85337
GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl" = 50649
- GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = 40027
- GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = 69639
GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods" = 93006
GhcDiagnosticCode "TcRnBadGenericMethod" = 59794
@@ -502,6 +500,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnBadFamInstDecl" = 06206
GhcDiagnosticCode "TcRnNotOpenFamily" = 06207
GhcDiagnosticCode "TcRnCapturedTermName" = 54201
+ GhcDiagnosticCode "TcRnBindingOfExistingName" = 58805
-- IllegalNewtypeReason
GhcDiagnosticCode "DoesNotHaveSingleField" = 23517
@@ -607,6 +606,8 @@ type family GhcDiagnosticCode c = n | n -> c where
-- no longer reports. These are collected below.
GhcDiagnosticCode "Example outdated error" = 00000
+ GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = 40027
+ GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = 69639
{- *********************************************************************
* *
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -92,12 +92,14 @@ module GHC.Types.Id (
-- ** Reading 'IdInfo' fields
idArity,
idCallArity, idFunRepArity,
- idUnfolding, realIdUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo, idLFInfo_maybe,
idOneShotInfo,
idOccInfo,
+ IdUnfoldingFun, idUnfolding, realIdUnfolding,
+ alwaysActiveUnfoldingFun, whenActiveUnfoldingFun, noUnfoldingFun,
+
-- ** Writing 'IdInfo' fields
setIdUnfolding, zapIdUnfolding, setCaseBndrEvald,
setIdArity,
@@ -126,8 +128,9 @@ module GHC.Types.Id (
import GHC.Prelude
-import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding,
- isCompulsoryUnfolding, Unfolding( NoUnfolding ), isEvaldUnfolding, hasSomeUnfolding, noUnfolding )
+import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding
+ , isCompulsoryUnfolding, Unfolding( NoUnfolding )
+ , IdUnfoldingFun, isEvaldUnfolding, hasSomeUnfolding, noUnfolding )
import GHC.Types.Id.Info
import GHC.Types.Basic
@@ -744,9 +747,28 @@ idTagSig_maybe = tagSig . idInfo
-- loop breaker. See 'unfoldingInfo'.
--
-- If you really want the unfolding of a strong loopbreaker, call 'realIdUnfolding'.
-idUnfolding :: Id -> Unfolding
+idUnfolding :: IdUnfoldingFun
idUnfolding id = unfoldingInfo (idInfo id)
+noUnfoldingFun :: IdUnfoldingFun
+noUnfoldingFun _id = noUnfolding
+
+-- | Returns an unfolding only if
+-- (a) not a strong loop breaker and
+-- (b) always active
+alwaysActiveUnfoldingFun :: IdUnfoldingFun
+alwaysActiveUnfoldingFun id
+ | isAlwaysActive (idInlineActivation id) = idUnfolding id
+ | otherwise = noUnfolding
+
+-- | Returns an unfolding only if
+-- (a) not a strong loop breaker and
+-- (b) active in according to is_active
+whenActiveUnfoldingFun :: (Activation -> Bool) -> IdUnfoldingFun
+whenActiveUnfoldingFun is_active id
+ | is_active (idInlineActivation id) = idUnfolding id
+ | otherwise = NoUnfolding
+
realIdUnfolding :: Id -> Unfolding
-- ^ Expose the unfolding if there is one, including for loop breakers
realIdUnfolding id = realUnfoldingInfo (idInfo id)
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -469,7 +469,7 @@ setOccInfo info oc = oc `seq` info { occInfo = oc }
unfoldingInfo :: IdInfo -> Unfolding
unfoldingInfo info
| isStrongLoopBreaker (occInfo info) = trimUnfolding $ realUnfoldingInfo info
- | otherwise = realUnfoldingInfo info
+ | otherwise = realUnfoldingInfo info
setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo info uf
=====================================
rts/include/Rts.h
=====================================
@@ -167,7 +167,10 @@ void _warnFail(const char *filename, unsigned int linenum);
#endif /* DEBUG */
#if __STDC_VERSION__ >= 201112L
-#define GHC_STATIC_ASSERT(x, msg) static_assert((x), msg)
+// `_Static_assert` is provided by C11 but is deprecated and replaced by
+// `static_assert` in C23. Perhaps some day we should instead use the latter.
+// See #22777.
+#define GHC_STATIC_ASSERT(x, msg) _Static_assert((x), msg)
#else
#define GHC_STATIC_ASSERT(x, msg)
#endif
=====================================
testsuite/tests/rename/should_fail/T14907b.stderr
=====================================
@@ -1,9 +1,9 @@
-T14907b.hs:5:1: error: [GHC-69639]
- Illegal binding of built-in syntax: ()
+T14907b.hs:5:1: error: [GHC-58805]
+ Illegal binding of an existing name: ()
-T14907b.hs:6:1: error: [GHC-69639]
- Illegal binding of built-in syntax: (,)
+T14907b.hs:6:1: error: [GHC-58805]
+ Illegal binding of an existing name: (,)
-T14907b.hs:7:1: error: [GHC-69639]
- Illegal binding of built-in syntax: (,,)
+T14907b.hs:7:1: error: [GHC-58805]
+ Illegal binding of an existing name: (,,)
=====================================
testsuite/tests/rename/should_fail/T22839.hs
=====================================
@@ -0,0 +1,5 @@
+module T22839 where
+
+data []
+
+data (->)
=====================================
testsuite/tests/rename/should_fail/T22839.stderr
=====================================
@@ -0,0 +1,6 @@
+
+T22839.hs:3:1: error: [GHC-58805]
+ Illegal binding of an existing name: []
+
+T22839.hs:5:1: error: [GHC-58805]
+ Illegal binding of an existing name: ->
=====================================
testsuite/tests/rename/should_fail/all.T
=====================================
@@ -183,3 +183,4 @@ test('T21605a', normal, compile_fail, [''])
test('T21605b', normal, compile_fail, [''])
test('T21605c', normal, compile_fail, [''])
test('T21605d', normal, compile_fail, [''])
+test('T22839', normal, compile_fail, [''])
=====================================
testsuite/tests/rename/should_fail/rnfail042.stderr
=====================================
@@ -1,12 +1,12 @@
-rnfail042.hs:5:11: error: [GHC-69639]
- Illegal binding of built-in syntax: ()
+rnfail042.hs:5:11: error: [GHC-58805]
+ Illegal binding of an existing name: ()
-rnfail042.hs:6:10: error: [GHC-69639]
- Illegal binding of built-in syntax: (,,,)
+rnfail042.hs:6:10: error: [GHC-58805]
+ Illegal binding of an existing name: (,,,)
-rnfail042.hs:7:12: error: [GHC-69639]
- Illegal binding of built-in syntax: []
+rnfail042.hs:7:12: error: [GHC-58805]
+ Illegal binding of an existing name: []
-rnfail042.hs:8:13: error: [GHC-69639]
- Illegal binding of built-in syntax: :
+rnfail042.hs:8:13: error: [GHC-58805]
+ Illegal binding of an existing name: :
=====================================
testsuite/tests/simplCore/should_compile/T22802.hs
=====================================
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -O1 #-}
+module T22802 where
+
+class C a where
+ f :: a -> a -> a
+ g :: a -> a -> a
+instance C () where
+ f = g
+ g = f
+
+h :: a -> () -> ()
+h = mapFB f (const ())
+
+mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
+{-# INLINE [0] mapFB #-}
+mapFB c f = \x ys -> c (f x) ys
+
+{-# RULES
+"my-mapFB" forall c a b. mapFB (mapFB c a) b = mapFB c (a.b)
+ #-}
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -470,3 +470,4 @@ test('T22725', normal, compile, ['-O'])
test('T22502', normal, compile, ['-O'])
test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all'])
test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-aggressively'])
+test('T22802', normal, compile, ['-O'])
=====================================
testsuite/tests/th/T13968.stderr
=====================================
@@ -1,3 +1,3 @@
-T13968.hs:6:2: error: [GHC-40027]
- Cannot redefine a Name retrieved by a Template Haskell quote: succ
+T13968.hs:6:2: error: [GHC-58805]
+ Illegal binding of an existing name: succ
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9223f1cf509169e8425ac78fc05fc943fba81727...7e423687ed75e32cca797af1b63bbbd400a6ed44
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9223f1cf509169e8425ac78fc05fc943fba81727...7e423687ed75e32cca797af1b63bbbd400a6ed44
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230127/cb2c1b48/attachment-0001.html>
More information about the ghc-commits
mailing list