[Git][ghc/ghc][wip/T22634] 4 commits: rts: explicitly store return value of ccall checkClosure to prevent type error (#22617)
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Thu Dec 22 07:20:36 UTC 2022
Matthew Pickering pushed to branch wip/T22634 at Glasgow Haskell Compiler / GHC
Commits:
df7bc6b3 by Ying-Ruei Liang (TheKK) at 2022-12-21T14:31:54-05:00
rts: explicitly store return value of ccall checkClosure to prevent type error (#22617)
- - - - -
e193e537 by Simon Peyton Jones at 2022-12-21T14:32:30-05:00
Fix shadowing lacuna in OccurAnal
Issue #22623 demonstrated another lacuna in the implementation
of wrinkle (BS3) in Note [The binder-swap substitution] in
the occurrence analyser.
I was failing to add TyVar lambda binders using
addInScope/addOneInScope and that led to a totally bogus binder-swap
transformation.
Very easy to fix.
- - - - -
3d55d8ab by Simon Peyton Jones at 2022-12-21T14:32:30-05:00
Fix an assertion check in addToEqualCtList
The old assertion saw that a constraint ct could rewrite itself
(of course it can) and complained (stupid).
Fixes #22645
- - - - -
6810c15e by Simon Peyton Jones at 2022-12-22T07:18:28+00:00
Refactor mkRuntimeError
This patch fixes #22634. Because we don't have TYPE/CONSTRAINT
polymorphism, we need two error functions rather than one.
I took the opportunity to rname runtimeError to impossibleError,
to line up with mkImpossibleExpr, and avoid confusion with the
genuine runtime-error-constructing functions.
- - - - -
21 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/Tc/Solver/Types.hs
- libraries/base/Control/Exception/Base.hs
- libraries/ghc-prim/GHC/Prim/Panic.hs
- rts/ContinuationOps.cmm
- + testsuite/tests/simplCore/should_compile/T22623.hs
- + testsuite/tests/simplCore/should_compile/T22623a.hs
- + testsuite/tests/simplCore/should_compile/T22634.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/typecheck/should_fail/T22645.hs
- + testsuite/tests/typecheck/should_fail/T22645.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -2282,7 +2282,8 @@ wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendI
buildIdKey, foldrIdKey, recSelErrorIdKey,
seqIdKey, eqStringIdKey,
noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,
- runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,
+ impossibleErrorIdKey, impossibleConstraintErrorIdKey,
+ patErrorIdKey, voidPrimIdKey,
realWorldPrimIdKey, recConErrorIdKey,
unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey,
unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey,
@@ -2290,37 +2291,38 @@ wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendI
absentSumFieldErrorIdKey, cstringLengthIdKey
:: Unique
-wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders]
-absentErrorIdKey = mkPreludeMiscIdUnique 1
-augmentIdKey = mkPreludeMiscIdUnique 2
-appendIdKey = mkPreludeMiscIdUnique 3
-buildIdKey = mkPreludeMiscIdUnique 4
-absentConstraintErrorIdKey = mkPreludeMiscIdUnique 5
-foldrIdKey = mkPreludeMiscIdUnique 6
-recSelErrorIdKey = mkPreludeMiscIdUnique 7
-seqIdKey = mkPreludeMiscIdUnique 8
-absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9
-eqStringIdKey = mkPreludeMiscIdUnique 10
-noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11
-nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12
-runtimeErrorIdKey = mkPreludeMiscIdUnique 13
-patErrorIdKey = mkPreludeMiscIdUnique 14
-realWorldPrimIdKey = mkPreludeMiscIdUnique 15
-recConErrorIdKey = mkPreludeMiscIdUnique 16
-
-unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 17
-unpackCStringAppendUtf8IdKey = mkPreludeMiscIdUnique 18
-unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 19
-
-unpackCStringIdKey = mkPreludeMiscIdUnique 20
-unpackCStringAppendIdKey = mkPreludeMiscIdUnique 21
-unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 22
-
-voidPrimIdKey = mkPreludeMiscIdUnique 23
-typeErrorIdKey = mkPreludeMiscIdUnique 24
-divIntIdKey = mkPreludeMiscIdUnique 25
-modIntIdKey = mkPreludeMiscIdUnique 26
-cstringLengthIdKey = mkPreludeMiscIdUnique 27
+wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders]
+absentErrorIdKey = mkPreludeMiscIdUnique 1
+absentConstraintErrorIdKey = mkPreludeMiscIdUnique 2
+augmentIdKey = mkPreludeMiscIdUnique 3
+appendIdKey = mkPreludeMiscIdUnique 4
+buildIdKey = mkPreludeMiscIdUnique 5
+foldrIdKey = mkPreludeMiscIdUnique 6
+recSelErrorIdKey = mkPreludeMiscIdUnique 7
+seqIdKey = mkPreludeMiscIdUnique 8
+absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9
+eqStringIdKey = mkPreludeMiscIdUnique 10
+noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11
+nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12
+impossibleErrorIdKey = mkPreludeMiscIdUnique 13
+impossibleConstraintErrorIdKey = mkPreludeMiscIdUnique 14
+patErrorIdKey = mkPreludeMiscIdUnique 15
+realWorldPrimIdKey = mkPreludeMiscIdUnique 16
+recConErrorIdKey = mkPreludeMiscIdUnique 17
+
+unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 18
+unpackCStringAppendUtf8IdKey = mkPreludeMiscIdUnique 19
+unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 20
+
+unpackCStringIdKey = mkPreludeMiscIdUnique 21
+unpackCStringAppendIdKey = mkPreludeMiscIdUnique 22
+unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 23
+
+voidPrimIdKey = mkPreludeMiscIdUnique 24
+typeErrorIdKey = mkPreludeMiscIdUnique 25
+divIntIdKey = mkPreludeMiscIdUnique 26
+modIntIdKey = mkPreludeMiscIdUnique 27
+cstringLengthIdKey = mkPreludeMiscIdUnique 28
concatIdKey, filterIdKey, zipIdKey,
bindIOIdKey, returnIOIdKey, newStablePtrIdKey,
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -44,7 +44,7 @@ module GHC.Core.Make (
-- * Error Ids
mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds,
- rEC_CON_ERROR_ID, rUNTIME_ERROR_ID,
+ rEC_CON_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
pAT_ERROR_ID, rEC_SEL_ERROR_ID,
tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID
@@ -58,6 +58,7 @@ import GHC.Types.Var ( EvVar, setTyVarUnique, visArgConstraintLike )
import GHC.Types.TyThing
import GHC.Types.Id.Info
import GHC.Types.Cpr
+import GHC.Types.Basic( TypeOrConstraint(..) )
import GHC.Types.Demand
import GHC.Types.Name hiding ( varName )
import GHC.Types.Literal
@@ -847,7 +848,9 @@ mkJustExpr ty val = mkConApp justDataCon [Type ty, val]
-}
mkRuntimeErrorApp
- :: Id -- Should be of type (forall a. Addr# -> a)
+ :: Id -- Should be of type
+ -- forall (r::RuntimeRep) (a::TYPE r). Addr# -> a
+ -- or (a :: CONSTRAINT r)
-- where Addr# points to a UTF8 encoded string
-> Type -- The type to instantiate 'a'
-> String -- The string to print
@@ -859,10 +862,6 @@ mkRuntimeErrorApp err_id res_ty err_msg
where
err_string = Lit (mkLitString err_msg)
-mkImpossibleExpr :: Type -> CoreExpr
-mkImpossibleExpr res_ty
- = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
-
{-
************************************************************************
* *
@@ -884,25 +883,23 @@ crash).
errorIds :: [Id]
errorIds
- = [ rUNTIME_ERROR_ID,
- nON_EXHAUSTIVE_GUARDS_ERROR_ID,
+ = [ nON_EXHAUSTIVE_GUARDS_ERROR_ID,
nO_METHOD_BINDING_ERROR_ID,
pAT_ERROR_ID,
rEC_CON_ERROR_ID,
rEC_SEL_ERROR_ID,
- aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID,
+ iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID,
+ aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID,
aBSENT_SUM_FIELD_ERROR_ID,
tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284
]
-recSelErrorName, runtimeErrorName :: Name
-recConErrorName, patErrorName :: Name
+recSelErrorName, recConErrorName, patErrorName :: Name
nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
typeErrorName :: Name
absentSumFieldErrorName :: Name
recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID
-runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID
recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID
patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID
typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID
@@ -915,16 +912,15 @@ nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
err_nm :: String -> Unique -> Id -> Name
err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
-rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id
+rEC_SEL_ERROR_ID, rEC_CON_ERROR_ID :: Id
pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id
-rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
-rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
-rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
-pAT_ERROR_ID = mkRuntimeErrorId patErrorName
-nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
-nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
-tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName
+rEC_SEL_ERROR_ID = mkRuntimeErrorId TypeLike recSelErrorName
+rEC_CON_ERROR_ID = mkRuntimeErrorId TypeLike recConErrorName
+pAT_ERROR_ID = mkRuntimeErrorId TypeLike patErrorName
+nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId TypeLike noMethodBindingErrorName
+nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId TypeLike nonExhaustiveGuardsErrorName
+tYPE_ERROR_ID = mkRuntimeErrorId TypeLike typeErrorName
-- Note [aBSENT_SUM_FIELD_ERROR_ID]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1038,30 +1034,6 @@ mkExceptionId name
(divergingIdInfo [] `setCafInfo` NoCafRefs)
-- See Note [Wired-in exceptions are not CAFfy]
-mkRuntimeErrorId :: Name -> Id
--- Error function
--- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
--- with arity: 1
--- which diverges after being given one argument
--- The Addr# is expected to be the address of
--- a UTF8-encoded error string
-mkRuntimeErrorId name
- = mkVanillaGlobalWithInfo name runtimeErrorTy (divergingIdInfo [evalDmd])
- -- Do *not* mark them as NoCafRefs, because they can indeed have
- -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
- -- which has some CAFs
- -- In due course we may arrange that these error-y things are
- -- regarded by the GC as permanently live, in which case we
- -- can give them NoCaf info. As it is, any function that calls
- -- any pc_bottoming_Id will itself have CafRefs, which bloats
- -- SRTs.
-
-runtimeErrorTy :: Type
--- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
--- See Note [Error and friends have an "open-tyvar" forall]
-runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
- (mkVisFunTyMany addrPrimTy openAlphaTy)
-
-- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID', that
-- throws an (imprecise) exception after being supplied one value arg for every
-- argument 'Demand' in the list. The demands end up in the demand signature.
@@ -1089,6 +1061,56 @@ Notice the runtime-representation polymorphism. This ensures that
This is OK because it never returns, so the return type is irrelevant.
+************************************************************************
+* *
+ iMPOSSIBLE_ERROR_ID
+* *
+************************************************************************
+-}
+
+iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID :: Id
+iMPOSSIBLE_ERROR_ID = mkRuntimeErrorId TypeLike impossibleErrorName
+iMPOSSIBLE_CONSTRAINT_ERROR_ID = mkRuntimeErrorId ConstraintLike impossibleConstraintErrorName
+
+impossibleErrorName, impossibleConstraintErrorName :: Name
+impossibleErrorName = err_nm "impossibleError"
+ impossibleErrorIdKey iMPOSSIBLE_ERROR_ID
+impossibleConstraintErrorName = err_nm "impossibleConstraintError"
+ impossibleConstraintErrorIdKey iMPOSSIBLE_CONSTRAINT_ERROR_ID
+
+mkImpossibleExpr :: Type -> String -> CoreExpr
+mkImpossibleExpr res_ty str
+ = mkRuntimeErrorApp err_id res_ty str
+ where -- See Note [Type vs Constraint for error ids]
+ err_id | isConstraintLikeKind (typeKind res_ty) = iMPOSSIBLE_CONSTRAINT_ERROR_ID
+ | otherwise = iMPOSSIBLE_ERROR_ID
+
+{- Note [Type vs Constraint for error ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need both
+ iMPOSSIBLE_ERROR_ID :: forall (r::RuntimeRep) (a::TYPE r). Addr# -> a
+ iMPOSSIBLE_CONSTRAINT_ERROR_ID :: forall (r::RuntimeRep) (a::CONSTRAINT r). Addr# -> a
+
+because we don't have polymorphism over TYPE vs CONSTRAINT. You
+might wonder if iMPOSSIBLE_CONSTRAINT_ERROR_ID is ever needed in
+practice, but it is: see #22634. So:
+
+* In Control.Exception.Base we have
+ impossibleError :: forall (a::Type). Addr# -> a
+ impossibleConstraintError :: forall (a::Type). Addr# -> a
+ This generates the code for `impossibleError`, but because they are wired in
+ the interface file definitions are never looked at (indeed, they don't
+ even get serialised).
+
+* In this module GHC.Core.Make we define /wired-in/ Ids for
+ iMPOSSIBLE_ERROR_ID
+ iMPOSSIBLE_CONSTRAINT_ERROR_ID
+ with the desired above types (i.e. runtime-rep polymorphic, and returning a
+ constraint for the latter.
+
+Much the same plan works for aBSENT_ERROR_ID and aBSENT_CONSTRAINT_ERROR_ID
+
+
************************************************************************
* *
aBSENT_ERROR_ID
@@ -1176,6 +1198,7 @@ be relying on anything from it.
-- absentConstraintError :: forall (a :: Constraint). Addr# -> a
-- We don't have polymorphism over TypeOrConstraint!
-- mkAbsentErrorApp chooses which one to use, based on the kind
+-- See Note [Type vs Constraint for error ids]
mkAbsentErrorApp :: Type -- The type to instantiate 'a'
-> String -- The string to print
@@ -1193,29 +1216,69 @@ absentErrorName
= mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentError")
absentErrorIdKey aBSENT_ERROR_ID
-absentConstraintErrorName
+absentConstraintErrorName -- See Note [Type vs Constraint for error ids]
= mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentConstraintError")
absentConstraintErrorIdKey aBSENT_CONSTRAINT_ERROR_ID
aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID :: Id
aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID]
- = mkVanillaGlobalWithInfo absentErrorName absent_ty id_info
+ = mk_runtime_error_id absentErrorName absent_ty
where
-- absentError :: forall (a :: Type). Addr# -> a
absent_ty = mkSpecForAllTys [alphaTyVar] $
mkVisFunTyMany addrPrimTy (mkTyVarTy alphaTyVar)
-- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
-- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils
- id_info = divergingIdInfo [evalDmd] -- NB: CAFFY!
aBSENT_CONSTRAINT_ERROR_ID -- See Note [aBSENT_ERROR_ID]
- = mkVanillaGlobalWithInfo absentConstraintErrorName absent_ty id_info
+ = mk_runtime_error_id absentConstraintErrorName absent_ty
+ -- See Note [Type vs Constraint for error ids]
where
-- absentConstraintError :: forall (a :: Constraint). Addr# -> a
absent_ty = mkSpecForAllTys [alphaConstraintTyVar] $
mkFunTy visArgConstraintLike ManyTy
addrPrimTy (mkTyVarTy alphaConstraintTyVar)
- id_info = divergingIdInfo [evalDmd] -- NB: CAFFY!
+{-
+************************************************************************
+* *
+ mkRuntimeErrorId
+* *
+************************************************************************
+-}
+
+mkRuntimeErrorId :: TypeOrConstraint -> Name -> Id
+-- Error function
+-- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
+-- with arity: 1
+-- which diverges after being given one argument
+-- The Addr# is expected to be the address of
+-- a UTF8-encoded error string
+mkRuntimeErrorId torc name = mk_runtime_error_id name (mkRuntimeErrorTy torc)
+
+
+mk_runtime_error_id :: Name -> Type -> Id
+mk_runtime_error_id name ty
+ = mkVanillaGlobalWithInfo name ty (divergingIdInfo [evalDmd])
+ -- Do *not* mark them as NoCafRefs, because they can indeed have
+ -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
+ -- which has some CAFs
+ -- In due course we may arrange that these error-y things are
+ -- regarded by the GC as permanently live, in which case we
+ -- can give them NoCaf info. As it is, any function that calls
+ -- any pc_bottoming_Id will itself have CafRefs, which bloats
+ -- SRTs.
+
+mkRuntimeErrorTy :: TypeOrConstraint -> Type
+-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
+-- See Note [Error and friends have an "open-tyvar" forall]
+mkRuntimeErrorTy torc = mkSpecForAllTys [runtimeRep1TyVar, tyvar] $
+ mkFunctionType ManyTy addrPrimTy (mkTyVarTy tyvar)
+ where
+ (tyvar:_) = mkTemplateTyVars [kind]
+ kind = case torc of
+ TypeLike -> mkTYPEapp runtimeRep1Ty
+ ConstraintLike -> mkCONSTRAINTapp runtimeRep1Ty
+
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -1810,7 +1810,7 @@ tagToEnumRule = do
-- See Note [tagToEnum#]
_ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $
- return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
+ return $ mkImpossibleExpr ty "tagToEnum# on non-enumeration type"
------------------------------
dataToTagRule :: RuleM CoreExpr
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1820,7 +1820,8 @@ occAnalLam :: OccEnv -> CoreExpr -> (WithUsageDetails CoreExpr)
occAnalLam env (Lam bndr expr)
| isTyVar bndr
- = let (WithUsageDetails usage expr') = occAnalLam env expr
+ = let env1 = addOneInScope env bndr
+ WithUsageDetails usage expr' = occAnalLam env1 expr
in WithUsageDetails usage (Lam bndr expr')
-- Important: Keep the 'env' unchanged so that with a RHS like
-- \(@ x) -> K @x (f @x)
@@ -2466,10 +2467,11 @@ data OccEnv
-- If x :-> (y, co) is in the env,
-- then please replace x by (y |> mco)
-- Invariant of course: idType x = exprType (y |> mco)
- , occ_bs_env :: !(VarEnv (OutId, MCoercion))
- , occ_bs_rng :: !VarSet -- Vars free in the range of occ_bs_env
+ , occ_bs_env :: !(IdEnv (OutId, MCoercion))
-- Domain is Global and Local Ids
-- Range is just Local Ids
+ , occ_bs_rng :: !VarSet
+ -- Vars (TyVars and Ids) free in the range of occ_bs_env
}
@@ -2546,14 +2548,15 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
_ -> False
addOneInScope :: OccEnv -> CoreBndr -> OccEnv
+-- Needed for all Vars not just Ids
+-- See Note [The binder-swap substitution] (BS3)
addOneInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndr
| bndr `elemVarSet` rng_vars = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
| otherwise = env { occ_bs_env = swap_env `delVarEnv` bndr }
addInScope :: OccEnv -> [Var] -> OccEnv
--- See Note [The binder-swap substitution]
--- It's only necessary to call this on in-scope Ids,
--- but harmless to include TyVars too
+-- Needed for all Vars not just Ids
+-- See Note [The binder-swap substitution] (BS3)
addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs
| any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
| otherwise = env { occ_bs_env = swap_env `delVarEnvList` bndrs }
@@ -2712,25 +2715,29 @@ Some tricky corners:
(BS3) We need care when shadowing. Suppose [x :-> b] is in occ_bs_env,
and we encounter:
- - \x. blah
- Here we want to delete the x-binding from occ_bs_env
-
- - \b. blah
- This is harder: we really want to delete all bindings that
- have 'b' free in the range. That is a bit tiresome to implement,
- so we compromise. We keep occ_bs_rng, which is the set of
- free vars of rng(occc_bs_env). If a binder shadows any of these
- variables, we discard all of occ_bs_env. Safe, if a bit
- brutal. NB, however: the simplifer de-shadows the code, so the
- next time around this won't happen.
+ (i) \x. blah
+ Here we want to delete the x-binding from occ_bs_env
+
+ (ii) \b. blah
+ This is harder: we really want to delete all bindings that
+ have 'b' free in the range. That is a bit tiresome to implement,
+ so we compromise. We keep occ_bs_rng, which is the set of
+ free vars of rng(occc_bs_env). If a binder shadows any of these
+ variables, we discard all of occ_bs_env. Safe, if a bit
+ brutal. NB, however: the simplifer de-shadows the code, so the
+ next time around this won't happen.
These checks are implemented in addInScope.
-
- The occurrence analyser itself does /not/ do cloning. It could, in
- principle, but it'd make it a bit more complicated and there is no
- great benefit. The simplifer uses cloning to get a no-shadowing
- situation, the care-when-shadowing behaviour above isn't needed for
- long.
+ (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623)
+ because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we
+ must not replace `x` by `...a...` under /\a. ...x..., or similarly
+ under a case pattern match that binds `a`.
+
+ An alternative would be for the occurrence analyser to do cloning as
+ it goes. In principle it could do so, but it'd make it a bit more
+ complicated and there is no great benefit. The simplifer uses
+ cloning to get a no-shadowing situation, the care-when-shadowing
+ behaviour above isn't needed for long.
(BS4) The domain of occ_bs_env can include GlobaIds. Eg
case M.foo of b { alts }
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -132,7 +132,11 @@ data SimplifyOpts = SimplifyOpts
{ so_dump_core_sizes :: !Bool
, so_iterations :: !Int
, so_mode :: !SimplMode
+
, so_pass_result_cfg :: !(Maybe LintPassResultConfig)
+ -- Nothing => Do not Lint
+ -- Just cfg => Lint like this
+
, so_hpt_rules :: !RuleBase
, so_top_env_cfg :: !TopEnvConfig
}
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -3528,7 +3528,7 @@ missingAlt env case_bndr _ cont
-- See Note [Avoiding space leaks in OutType]
let cont_ty = contResultType cont
in seqType cont_ty `seq`
- return (emptyFloats env, mkImpossibleExpr cont_ty)
+ return (emptyFloats env, mkImpossibleExpr cont_ty "Simplify.Iteration.missingAlt")
{-
************************************************************************
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -1500,7 +1500,7 @@ scExpr' env (Case scrut b ty alts)
where
sc_con_app con args scrut' -- Known constructor; simplify
= do { let Alt _ bs rhs = findAlt con alts
- `orElse` Alt DEFAULT [] (mkImpossibleExpr ty)
+ `orElse` Alt DEFAULT [] (mkImpossibleExpr ty "SpecConstr")
alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
; scExpr alt_env' rhs }
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -3271,9 +3271,8 @@ mkCONSTRAINTapp_maybe :: RuntimeRepType -> Maybe Type
-- ^ Just like mkTYPEapp_maybe
{-# NOINLINE mkCONSTRAINTapp_maybe #-}
mkCONSTRAINTapp_maybe (TyConApp tc args)
- | key == liftedRepTyConKey = assert (null args) $ Just constraintKind -- CONSTRAINT LiftedRep
- where
- key = tyConUnique tc
+ | tc `hasKey` liftedRepTyConKey = assert (null args) $
+ Just constraintKind -- CONSTRAINT LiftedRep
mkCONSTRAINTapp_maybe _ = Nothing
------------------
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -868,8 +868,7 @@ cpeRhsE env (Case scrut bndr ty alts)
, not (altsAreExhaustive alts)
= addDefault alts (Just err)
| otherwise = alts
- where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty
- "Bottoming expression returned"
+ where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative"
; alts'' <- mapM (sat_alt env') alts'
; return (floats, Case scrut' bndr2 ty alts'') }
=====================================
compiler/GHC/HsToCore/Pmc/Solver.hs
=====================================
@@ -65,7 +65,7 @@ import GHC.Core.Map.Expr
import GHC.Core.Predicate (typeDeterminesValue)
import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe)
import GHC.Core.Utils (exprType)
-import GHC.Core.Make (mkListExpr, mkCharExpr, mkRuntimeErrorApp, rUNTIME_ERROR_ID)
+import GHC.Core.Make (mkListExpr, mkCharExpr, mkImpossibleExpr)
import GHC.Data.FastString
import GHC.Types.SrcLoc
@@ -972,7 +972,7 @@ makeDictsCoherent :: CoreExpr -> CoreExpr
makeDictsCoherent var@(Var v)
| let ty = idType v
, typeDeterminesValue ty
- = mkRuntimeErrorApp rUNTIME_ERROR_ID ty "dictionary"
+ = mkImpossibleExpr ty "Solver.makeDictsCoherent"
| otherwise
= var
makeDictsCoherent lit@(Lit {})
=====================================
compiler/GHC/Tc/Solver/Types.hs
=====================================
@@ -273,21 +273,29 @@ addToEqualCtList ct old_eqs
| debugIsOn
= case ct of
CEqCan { cc_lhs = TyVarLHS tv } ->
- let shares_lhs (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv
- shares_lhs _other = False
- in
- assert (all shares_lhs old_eqs) $
- assert (null ([ (ct1, ct2) | ct1 <- ct : old_eqs
- , ct2 <- ct : old_eqs
- , let { fr1 = ctFlavourRole ct1
- ; fr2 = ctFlavourRole ct2 }
- , fr1 `eqCanRewriteFR` fr2 ])) $
+ assert (all (shares_lhs tv) old_eqs) $
+ assertPpr (null bad_prs)
+ (vcat [ text "bad_prs" <+> ppr bad_prs
+ , text "ct:old_eqs" <+> ppr (ct : old_eqs) ]) $
(ct : old_eqs)
_ -> pprPanic "addToEqualCtList not CEqCan" (ppr ct)
| otherwise
= ct : old_eqs
+ where
+ shares_lhs tv (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv
+ shares_lhs _ _ = False
+ bad_prs = filter is_bad_pair (distinctPairs (ct : old_eqs))
+ is_bad_pair (ct1,ct2) = ctFlavourRole ct1 `eqCanRewriteFR` ctFlavourRole ct2
+
+distinctPairs :: [a] -> [(a,a)]
+-- distinctPairs [x1,...xn] is the list of all pairs [ ...(xi, xj)...]
+-- where i /= j
+-- NB: does not return pairs (xi,xi), which would be stupid in the
+-- context of addToEqualCtList (#22645)
+distinctPairs [] = []
+distinctPairs (x:xs) = concatMap (\y -> [(x,y),(y,x)]) xs ++ distinctPairs xs
-- returns Nothing when the new list is empty, to keep the environments smaller
filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList
=====================================
libraries/base/Control/Exception/Base.hs
=====================================
@@ -94,7 +94,8 @@ module Control.Exception.Base (
finally,
-- * Calls for GHC runtime
- recSelError, recConError, runtimeError,
+ recSelError, recConError,
+ impossibleError, impossibleConstraintError,
nonExhaustiveGuardsError, patError, noMethodBindingError,
typeError,
nonTermination, nestedAtomically, noMatchingContinuationPrompt,
@@ -409,21 +410,25 @@ instance Exception NoMatchingContinuationPrompt
-----
-- See Note [Compiler error functions] in ghc-prim:GHC.Prim.Panic
-recSelError, recConError, runtimeError,
- nonExhaustiveGuardsError, patError, noMethodBindingError,
- typeError
+recSelError, recConError, typeError,
+ nonExhaustiveGuardsError, patError, noMethodBindingError
:: Addr# -> a -- All take a UTF8-encoded C string
recSelError s = throw (RecSelError ("No match in record selector "
++ unpackCStringUtf8# s)) -- No location info unfortunately
-runtimeError s = errorWithoutStackTrace (unpackCStringUtf8# s) -- No location info unfortunately
-
nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
recConError s = throw (RecConError (untangle s "Missing field in record construction"))
noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
typeError s = throw (TypeError (unpackCStringUtf8# s))
+
+impossibleError, impossibleConstraintError :: Addr# -> a
+-- These two are used for impossible case alternatives, and lack location info
+impossibleError s = errorWithoutStackTrace (unpackCStringUtf8# s)
+impossibleConstraintError s = errorWithoutStackTrace (unpackCStringUtf8# s)
+
+
-- GHC's RTS calls this
nonTermination :: SomeException
nonTermination = toException NonTermination
=====================================
libraries/ghc-prim/GHC/Prim/Panic.hs
=====================================
@@ -111,9 +111,9 @@ absentConstraintError :: forall (a :: Type). Addr# -> a
-- We want to give this the type
-- forall (a :: Constraint). Addr# -> a
-- but Haskell source code doesn't allow functions that return Constraint
--- Fortunately, absentConstraintError is a wired-in Id with the above
--- desired type. So the only purpose of this definition is to give a
--- function to call. And for that purpose, absentError will do fine.
--- It's fine to lie about about the type; it is not looked at
--- because absentConstraintError is wired-in.
+-- So in this module we lie about the type. This is fine because
+-- absentConstraintError is a wired-in Id with the desired Constraint-kinded
+-- type; the type in the interface file is never looked at.
+-- The only purpose of this definition is to give a function to call,
+-- and for that purpose, delegating to absentError is fine.
absentConstraintError errmsg = absentError errmsg
=====================================
rts/ContinuationOps.cmm
=====================================
@@ -166,11 +166,12 @@ INFO_TABLE_FUN(stg_CONTINUATION,0,0,CONTINUATION,"CONTINUATION","CONTINUATION",2
// see Note [Continuations overview] in Continuation.c
stg_CONTINUATION_apply // explicit stack
{
+ W_ _unused;
P_ cont, io;
cont = R1;
io = R2;
- IF_DEBUG(sanity, ccall checkClosure(cont "ptr"));
+ IF_DEBUG(sanity, (_unused) = ccall checkClosure(cont "ptr"));
W_ new_stack_words, apply_mask_frame, mask_frame_offset;
new_stack_words = StgContinuation_stack_size(cont);
=====================================
testsuite/tests/simplCore/should_compile/T22623.hs
=====================================
@@ -0,0 +1,34 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module T22623 where
+
+import T22623a
+
+type BindNonEmptyList :: NonEmpty -> NonEmpty -> [Q]
+type family BindNonEmptyList (x :: NonEmpty) (y :: NonEmpty) :: [Q] where
+ BindNonEmptyList ('(:|) a as) c = Tail c ++ Foldr2 a c as
+
+sBindNonEmptyList ::
+ forall (t :: NonEmpty)
+ (c :: NonEmpty). SNonEmpty t -> SNonEmpty c -> SList (BindNonEmptyList t c :: [Q])
+sBindNonEmptyList
+ ((:%|) (sA :: SQ a) (sAs :: SList as)) (sC :: SNonEmpty c)
+ = let
+ sMyHead :: SNonEmpty c -> SQ (MyHead a c)
+ sMyHead ((:%|) x _) = x
+
+ sFoldr :: forall t. SList t -> SList (Foldr2 a c t)
+ sFoldr SNil = SNil
+ sFoldr (SCons _ sYs) = SCons (sMyHead sC) (sFoldr sYs)
+
+ sF :: Id (SLambda (ConstSym1 c))
+ sF = SLambda (const sC)
+
+ sBs :: SList (Tail c)
+ _ :%| sBs = applySing sF sA
+ in
+ sBs %++ sFoldr sAs
=====================================
testsuite/tests/simplCore/should_compile/T22623a.hs
=====================================
@@ -0,0 +1,60 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module T22623a where
+
+import Data.Kind
+
+type Id :: Type -> Type
+type family Id x
+type instance Id x = x
+
+data Q
+data SQ (x :: Q)
+
+data NonEmpty where
+ (:|) :: Q -> [Q] -> NonEmpty
+
+type Tail :: NonEmpty -> [Q]
+type family Tail y where
+ Tail ('(:|) _ y) = y
+type MyHead :: Q -> NonEmpty -> Q
+type family MyHead x y where
+ MyHead _ ('(:|) c _) = c
+
+type SList :: [Q] -> Type
+data SList z where
+ SNil :: SList '[]
+ SCons :: SQ x -> SList xs -> SList (x:xs)
+
+type SNonEmpty :: NonEmpty -> Type
+data SNonEmpty z where
+ (:%|) :: SQ x -> SList xs -> SNonEmpty (x :| xs)
+
+data TyFun
+type F = TyFun -> Type
+
+type Apply :: F -> Q -> NonEmpty
+type family Apply f x
+
+type ConstSym1 :: NonEmpty -> F
+data ConstSym1 (x :: NonEmpty) :: F
+type instance Apply (ConstSym1 x) _ = x
+
+type SLambda :: F -> Type
+newtype SLambda (f :: F) =
+ SLambda { applySing :: forall t. SQ t -> SNonEmpty (f `Apply` t) }
+
+type Foldr2 :: Q -> NonEmpty -> [Q] -> [Q]
+type family Foldr2 a c x where
+ Foldr2 _ _ '[] = '[]
+ Foldr2 a c (_:ys) = MyHead a c : Foldr2 a c ys
+
+type (++) :: [Q] -> [Q] -> [Q]
+type family (++) xs ys where
+ (++) '[] ys = ys
+ (++) ('(:) x xs) ys = '(:) x (xs ++ ys)
+
+(%++) :: forall (x :: [Q]) (y :: [Q]). SList x -> SList y -> SList (x ++ y)
+(%++) SNil sYs = sYs
+(%++) (SCons sX sXs) sYs = SCons sX (sXs %++ sYs)
=====================================
testsuite/tests/simplCore/should_compile/T22634.hs
=====================================
@@ -0,0 +1,11 @@
+module T226334 where
+
+import Data.Kind
+import Type.Reflection
+
+fromDynamic :: forall (a :: Type) (b :: Type). Typeable a => TypeRep b -> Maybe (a :~~: b)
+fromDynamic t = typeRep `eqTypeRep` t
+
+recursiveStrategy :: forall (a :: Type) (b :: Type). Typeable a
+ => TypeRep b -> Maybe ((Bool -> a) :~~: b)
+recursiveStrategy = fromDynamic
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -454,8 +454,10 @@ test('T21851_2', [grep_errmsg(r'wwombat') ], multimod_compile, ['T21851_2', '-O
# Should not inline m, so there shouldn't be a single YES
test('T22317', [grep_errmsg(r'ANSWER = YES') ], compile, ['-O -dinline-check m -ddebug-output'])
+test('T22634', normal, compile, ['-O -fcatch-nonexhaustive-cases'])
test('T22494', [grep_errmsg(r'case') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
test('T22491', normal, compile, ['-O2'])
test('T21476', normal, compile, [''])
test('T22272', normal, multimod_compile, ['T22272', '-O -fexpose-all-unfoldings -fno-omit-interface-pragmas -fno-ignore-interface-pragmas'])
test('T22459', normal, compile, [''])
+test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
=====================================
testsuite/tests/typecheck/should_fail/T22645.hs
=====================================
@@ -0,0 +1,9 @@
+module T22645 where
+
+import Data.Coerce
+
+type T :: (* -> *) -> * -> *
+data T m a = MkT (m a)
+
+p :: Coercible a b => T Maybe a -> T Maybe b
+p = coerce
=====================================
testsuite/tests/typecheck/should_fail/T22645.stderr
=====================================
@@ -0,0 +1,15 @@
+
+T22645.hs:9:5: error: [GHC-25897]
+ • Couldn't match type ‘a’ with ‘b’ arising from a use of ‘coerce’
+ ‘a’ is a rigid type variable bound by
+ the type signature for:
+ p :: forall a b. Coercible a b => T Maybe a -> T Maybe b
+ at T22645.hs:8:1-44
+ ‘b’ is a rigid type variable bound by
+ the type signature for:
+ p :: forall a b. Coercible a b => T Maybe a -> T Maybe b
+ at T22645.hs:8:1-44
+ • In the expression: coerce
+ In an equation for ‘p’: p = coerce
+ • Relevant bindings include
+ p :: T Maybe a -> T Maybe b (bound at T22645.hs:9:1)
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -666,3 +666,4 @@ test('T21447', normal, compile_fail, [''])
test('T21530a', normal, compile_fail, [''])
test('T21530b', normal, compile_fail, [''])
test('T22570', normal, compile_fail, [''])
+test('T22645', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bb2862491cac6bdf3fefc56d628aec28fb3b5bf9...6810c15e71cc9f3c590f4c37c37e35d1fd8009d1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bb2862491cac6bdf3fefc56d628aec28fb3b5bf9...6810c15e71cc9f3c590f4c37c37e35d1fd8009d1
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/20221222/40ff979b/attachment-0001.html>
More information about the ghc-commits
mailing list