diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2022-12-19 17:48:38 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-12-22 23:39:49 -0500 |
commit | 02ed7d783244bd95ee897825650426de6f5fb3e2 (patch) | |
tree | 220e2cb9f8de3e7616c1f880ed266fdd7713b522 | |
parent | 99757ce8e32d9809c71b09583aa881943a450086 (diff) | |
download | haskell-02ed7d783244bd95ee897825650426de6f5fb3e2.tar.gz |
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.
-rw-r--r-- | compiler/GHC/Builtin/Names.hs | 66 | ||||
-rw-r--r-- | compiler/GHC/Core/Make.hs | 161 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/ConstantFold.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Iteration.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/SpecConstr.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Type.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/CoreToStg/Prep.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Pmc/Solver.hs | 4 | ||||
-rw-r--r-- | libraries/base/Control/Exception/Base.hs | 17 | ||||
-rw-r--r-- | libraries/ghc-prim/GHC/Prim/Panic.hs | 10 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T22634.hs | 11 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
12 files changed, 182 insertions, 102 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index acc402b4a3..0b2ace3dfb 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/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, diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 08d08b5008..2d567786ea 100644 --- a/compiler/GHC/Core/Make.hs +++ b/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. @@ -1091,6 +1063,56 @@ 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 + diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 81dd594090..3d36368d5b 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/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 diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs index 1e285dcccd..d8b95e7358 100644 --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/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") {- ************************************************************************ diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index fed1f32879..157cec6e49 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/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 } diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index fdd5edbba2..76326b6c50 100644 --- a/compiler/GHC/Core/Type.hs +++ b/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 ------------------ diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 0b9259bc0e..78ce8e16f1 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/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'') } diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs index c3f57e83af..b70c868c2f 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/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 {}) diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs index c2c675c65d..06ae041624 100644 --- a/libraries/base/Control/Exception/Base.hs +++ b/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 diff --git a/libraries/ghc-prim/GHC/Prim/Panic.hs b/libraries/ghc-prim/GHC/Prim/Panic.hs index a24f82ee07..35bcfc42e3 100644 --- a/libraries/ghc-prim/GHC/Prim/Panic.hs +++ b/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 diff --git a/testsuite/tests/simplCore/should_compile/T22634.hs b/testsuite/tests/simplCore/should_compile/T22634.hs new file mode 100644 index 0000000000..f4cfa38a6d --- /dev/null +++ b/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 diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index a8c08fa688..edbefd6145 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -454,6 +454,7 @@ 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, ['']) |