diff options
48 files changed, 409 insertions, 269 deletions
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 6895677a8f..ad584a325e 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -1088,7 +1088,7 @@ proxyHashId ty = mkForAllTys [kv, tv] (mkProxyPrimTy k t) kv = kKiVar k = mkTyVarTy kv - tv:_ = tyVarList k + [tv] = mkTemplateTyVars [k] t = mkTyVarTy tv ------------------------------------------------ diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index 8bdee4ae5f..3c115f419c 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -717,19 +717,30 @@ errorName :: Name errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID eRROR_ID :: Id -eRROR_ID = pc_bottoming_Id1 errorName errorTy +eRROR_ID = pc_bottoming_Id2 errorName errorTy errorTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] -errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy) +errorTy = mkSigmaTy [openAlphaTyVar] [] + (mkFunTys [ mkClassPred + ipClass + [ mkStrLitTy (fsLit "callStack") + , mkTyConTy callStackTyCon ] + , mkListTy charTy] + openAlphaTy) undefinedName :: Name undefinedName = mkWiredInIdName gHC_ERR (fsLit "undefined") undefinedKey uNDEFINED_ID uNDEFINED_ID :: Id -uNDEFINED_ID = pc_bottoming_Id0 undefinedName undefinedTy +uNDEFINED_ID = pc_bottoming_Id1 undefinedName undefinedTy undefinedTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] -undefinedTy = mkSigmaTy [openAlphaTyVar] [] openAlphaTy +undefinedTy = mkSigmaTy [openAlphaTyVar] [] + (mkFunTy (mkClassPred + ipClass + [ mkStrLitTy (fsLit "callStack") + , mkTyConTy callStackTyCon ]) + openAlphaTy) {- Note [Error and friends have an "open-tyvar" forall] @@ -773,10 +784,11 @@ pc_bottoming_Id1 name ty strict_sig = mkClosedStrictSig [evalDmd] botRes -- These "bottom" out, no matter what their arguments -pc_bottoming_Id0 :: Name -> Type -> Id --- Same but arity zero -pc_bottoming_Id0 name ty +pc_bottoming_Id2 :: Name -> Type -> Id +-- Same but arity two +pc_bottoming_Id2 name ty = mkVanillaGlobalWithInfo name ty bottoming_info where bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig - strict_sig = mkClosedStrictSig [] botRes + `setArityInfo` 2 + strict_sig = mkClosedStrictSig [evalDmd, evalDmd] botRes diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 9d95b485f3..8be97dfe40 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -61,7 +61,7 @@ import Var -- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv ) import TysWiredIn import TysPrim -import PrelNames( funTyConKey, ipClassName ) +import PrelNames( funTyConKey ) import Name import BasicTypes import Binary @@ -636,7 +636,7 @@ pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args) pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc pprTyTcApp ctxt_prec tc tys dflags - | ifaceTyConName tc == ipClassName + | ifaceTyConName tc == getName ipTyCon , ITC_Type (IfaceLitTy (IfaceStrTyLit n)) (ITC_Type ty ITC_Nil) <- tys = char '?' <> ftext n <> ptext (sLit "::") <> ppr_ty TopPrec ty diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 12a1543d44..e56307fa94 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -320,9 +320,6 @@ basicKnownKeyNames -- Type-level naturals knownNatClassName, knownSymbolClassName, - -- Implicit parameters - ipClassName, - -- Source locations callStackDataConName, callStackTyConName, srcLocDataConName, @@ -1172,18 +1169,14 @@ knownNatClassName = clsQual gHC_TYPELITS (fsLit "KnownNat") knownNatClassNam knownSymbolClassName :: Name knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey --- Implicit parameters -ipClassName :: Name -ipClassName = clsQual gHC_CLASSES (fsLit "IP") ipClassNameKey - -- Source Locations callStackDataConName, callStackTyConName, srcLocDataConName :: Name callStackDataConName - = dcQual gHC_STACK (fsLit "CallStack") callStackDataConKey + = dcQual gHC_TYPES (fsLit "CallStack") callStackDataConKey callStackTyConName - = tcQual gHC_STACK (fsLit "CallStack") callStackTyConKey + = tcQual gHC_TYPES (fsLit "CallStack") callStackTyConKey srcLocDataConName - = dcQual gHC_SRCLOC (fsLit "SrcLoc") srcLocDataConKey + = dcQual gHC_TYPES (fsLit "SrcLoc") srcLocDataConKey -- plugins pLUGINS :: Module @@ -1312,9 +1305,6 @@ knownSymbolClassNameKey = mkPreludeClassUnique 43 ghciIoClassKey :: Unique ghciIoClassKey = mkPreludeClassUnique 44 -ipClassNameKey :: Unique -ipClassNameKey = mkPreludeClassUnique 45 - {- ************************************************************************ * * @@ -1540,6 +1530,14 @@ callStackTyConKey = mkPreludeTyConUnique 182 typeRepTyConKey :: Unique typeRepTyConKey = mkPreludeTyConUnique 183 +-- Implicit Parameters +ipTyConKey :: Unique +ipTyConKey = mkPreludeTyConUnique 184 + +ipCoNameKey :: Unique +ipCoNameKey = mkPreludeTyConUnique 185 + + ---------------- Template Haskell ------------------- -- USES TyConUniques 200-299 ----------------------------------------------------- @@ -1615,6 +1613,9 @@ callStackDataConKey, srcLocDataConKey :: Unique callStackDataConKey = mkPreludeDataConUnique 36 srcLocDataConKey = mkPreludeDataConUnique 37 +ipDataConKey :: Unique +ipDataConKey = mkPreludeDataConUnique 38 + {- ************************************************************************ * * diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index d45c6880a0..5ce89ad7ef 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -10,7 +10,8 @@ -- | This module defines TyCons that can't be expressed in Haskell. -- They are all, therefore, wired-in TyCons. C.f module TysWiredIn module TysPrim( - tyVarList, alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, + mkTemplateTyVars, + alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTy, betaTy, gammaTy, deltaTy, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars, kKiVar, @@ -205,18 +206,19 @@ alphaTyVars is a list of type variables for use in templates: ["a", "b", ..., "z", "t1", "t2", ... ] -} -tyVarList :: Kind -> [TyVar] -tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u) - (mkTyVarOccFS (mkFastString name)) - noSrcSpan) kind - | u <- [2..], - let name | c <= 'z' = [c] - | otherwise = 't':show u - where c = chr (u-2 + ord 'a') - ] +mkTemplateTyVars :: [Kind] -> [TyVar] +mkTemplateTyVars kinds = + [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u) + (mkTyVarOccFS (mkFastString name)) + noSrcSpan) k + | (k,u) <- zip kinds [2..], + let name | c <= 'z' = [c] + | otherwise = 't':show u + where c = chr (u-2 + ord 'a') + ] alphaTyVars :: [TyVar] -alphaTyVars = tyVarList liftedTypeKind +alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind betaTyVars :: [TyVar] betaTyVars = tail alphaTyVars @@ -234,14 +236,15 @@ alphaTy, betaTy, gammaTy, deltaTy :: Type -- result type for "error", so that we can have (error Int# "Help") openAlphaTyVars :: [TyVar] openAlphaTyVar, openBetaTyVar :: TyVar -openAlphaTyVars@(openAlphaTyVar:openBetaTyVar:_) = tyVarList openTypeKind +openAlphaTyVars@(openAlphaTyVar:openBetaTyVar:_) + = mkTemplateTyVars $ repeat openTypeKind openAlphaTy, openBetaTy :: Type openAlphaTy = mkTyVarTy openAlphaTyVar openBetaTy = mkTyVarTy openBetaTyVar kKiVar :: KindVar -kKiVar = (tyVarList superKind) !! 10 +kKiVar = (mkTemplateTyVars $ repeat superKind) !! 10 {- ************************************************************************ diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index f8ee24fbe8..449377d03c 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -75,6 +75,11 @@ module TysWiredIn ( eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon, coercibleTyCon, coercibleDataCon, coercibleClass, + -- * Implicit Parameters + ipTyCon, ipDataCon, ipClass, + + callStackTyCon, + mkWiredInTyConName -- This is used in TcTypeNats to define the -- built-in functions for evaluation. ) where @@ -88,6 +93,8 @@ import PrelNames import TysPrim -- others: +import CoAxiom +import Coercion import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import Module ( Module ) import Type ( mkTyConApp ) @@ -160,6 +167,7 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , coercibleTyCon , typeNatKindCon , typeSymbolKindCon + , ipTyCon ] mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name @@ -174,6 +182,13 @@ mkWiredInDataConName built_in modu fs unique datacon (AConLike (RealDataCon datacon)) -- Relevant DataCon built_in +mkWiredInCoAxiomName :: BuiltInSyntax -> Module -> FastString -> Unique + -> CoAxiom Branched -> Name +mkWiredInCoAxiomName built_in modu fs unique ax + = mkWiredInName modu (mkTcOccFS fs) unique + (ACoAxiom ax) -- Relevant CoAxiom + built_in + -- See Note [Kind-changing of (~) and Coercible] eqTyConName, eqBoxDataConName :: Name eqTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon @@ -896,14 +911,14 @@ eqTyCon = mkAlgTyCon eqTyConName where kv = kKiVar k = mkTyVarTy kv - a:b:_ = tyVarList k + [a,b] = mkTemplateTyVars [k,k] eqBoxDataCon :: DataCon eqBoxDataCon = pcDataCon eqBoxDataConName args [TyConApp eqPrimTyCon (map mkTyVarTy args)] eqTyCon where kv = kKiVar k = mkTyVarTy kv - a:b:_ = tyVarList k + [a,b] = mkTemplateTyVars [k,k] args = [kv, a, b] @@ -914,7 +929,7 @@ coercibleTyCon = mkClassTyCon where kind = (ForAllTy kv $ mkArrowKinds [k, k] constraintKind) kv = kKiVar k = mkTyVarTy kv - a:b:_ = tyVarList k + [a,b] = mkTemplateTyVars [k,k] tvs = [kv, a, b] rhs = DataTyCon [coercibleDataCon] False @@ -923,8 +938,59 @@ coercibleDataCon = pcDataCon coercibleDataConName args [TyConApp eqReprPrimTyCon where kv = kKiVar k = mkTyVarTy kv - a:b:_ = tyVarList k + [a,b] = mkTemplateTyVars [k,k] args = [kv, a, b] coercibleClass :: Class coercibleClass = mkClass (tyConTyVars coercibleTyCon) [] [] [] [] [] (mkAnd []) coercibleTyCon + +{- +Note [The Implicit Parameter class] + +Implicit parameters `?x :: a` are desugared into dictionaries for the +class `IP "x" a`, which is defined (in GHC.Classes) as + + class IP (x :: Symbol) a | x -> a + +This class is wired-in so that `error` and `undefined`, which have +wired-in types, can use the implicit-call-stack feature to provide +a call-stack alongside the error message. +-} + +ipDataConName, ipTyConName, ipCoName :: Name +ipDataConName = mkWiredInDataConName UserSyntax gHC_CLASSES (fsLit "IP") + ipDataConKey ipDataCon +ipTyConName = mkWiredInTyConName UserSyntax gHC_CLASSES (fsLit "IP") + ipTyConKey ipTyCon +ipCoName = mkWiredInCoAxiomName BuiltInSyntax gHC_CLASSES (fsLit "NTCo:IP") + ipCoNameKey (toBranchedAxiom ipCoAxiom) + +-- See Note [The Implicit Parameter class] +ipTyCon :: TyCon +ipTyCon = mkClassTyCon ipTyConName kind [ip,a] [] rhs ipClass NonRecursive + where + kind = mkArrowKinds [typeSymbolKind, liftedTypeKind] constraintKind + [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind] + rhs = NewTyCon ipDataCon (mkTyVarTy a) ([], mkTyVarTy a) ipCoAxiom + +ipCoAxiom :: CoAxiom Unbranched +ipCoAxiom = mkNewTypeCo ipCoName ipTyCon [ip,a] [Nominal, Nominal] (mkTyVarTy a) + where + [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind] + +ipDataCon :: DataCon +ipDataCon = pcDataCon ipDataConName [ip,a] ts ipTyCon + where + [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind] + ts = [mkTyVarTy a] + +ipClass :: Class +ipClass = mkClass (tyConTyVars ipTyCon) [([ip], [a])] [] [] [] [] (mkAnd []) + ipTyCon + where + [ip, a] = tyConTyVars ipTyCon + +-- this is a fake version of the CallStack TyCon so we can refer to it +-- in MkCore.errorTy +callStackTyCon :: TyCon +callStackTyCon = pcNonRecDataTyCon callStackTyConName Nothing [] [] diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 8a7ca4d5c1..897828d5ec 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -37,6 +37,7 @@ import FamInst( tcGetFamInstEnvs ) import TyCon import TcType import TysPrim +import TysWiredIn import Id import Var import VarSet @@ -56,7 +57,7 @@ import BasicTypes import Outputable import FastString import Type(mkStrLitTy) -import PrelNames( ipClassName, gHC_PRIM ) +import PrelNames( gHC_PRIM ) import TcValidity (checkValidType) import Control.Monad @@ -225,8 +226,7 @@ tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds" tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside - = do { ipClass <- tcLookupClass ipClassName - ; (given_ips, ip_binds') <- + = do { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds -- If the binding binds ?x = E, we must now diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index d2b0c59244..354515a72e 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -46,7 +46,7 @@ import Var import VarSet import VarEnv import TysWiredIn -import TysPrim( intPrimTy, addrPrimTy ) +import TysPrim( intPrimTy ) import PrimOp( tagToEnumKey ) import PrelNames import DynFlags @@ -191,7 +191,6 @@ tcExpr (NegApp expr neg_expr) res_ty tcExpr (HsIPVar x) res_ty = do { let origin = IPOccOrigin x - ; ipClass <- tcLookupClass ipClassName {- Implicit parameters must have a *tau-type* not a. type scheme. We enforce this by creating a fresh type variable as its type. (Because res_ty may not @@ -1067,25 +1066,19 @@ tcInferIdWithOrig orig id_name = do { dflags <- getDynFlags ; if gopt Opt_IgnoreAsserts dflags then tc_infer_id orig id_name - else tc_infer_assert dflags orig } + else tc_infer_assert orig } | otherwise = tc_infer_id orig id_name -tc_infer_assert :: DynFlags -> CtOrigin -> TcM (HsExpr TcId, TcRhoType) +tc_infer_assert :: CtOrigin -> TcM (HsExpr TcId, TcRhoType) -- Deal with an occurrence of 'assert' -- See Note [Adding the implicit parameter to 'assert'] -tc_infer_assert dflags orig - = do { sloc <- getSrcSpanM - ; assert_error_id <- tcLookupId assertErrorName +tc_infer_assert orig + = do { assert_error_id <- tcLookupId assertErrorName ; (wrap, id_rho) <- deeplyInstantiate orig (idType assert_error_id) - ; let (arg_ty, res_ty) = case tcSplitFunTy_maybe id_rho of - Nothing -> pprPanic "assert type" (ppr id_rho) - Just arg_res -> arg_res - ; ASSERT( arg_ty `tcEqType` addrPrimTy ) - return (HsApp (L sloc (mkHsWrap wrap (HsVar assert_error_id))) - (L sloc (srcSpanPrimLit dflags sloc)) - , res_ty) } + ; return (mkHsWrap wrap (HsVar assert_error_id), id_rho) + } tc_infer_id :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType) -- Return type is deeply instantiated @@ -1133,17 +1126,12 @@ tc_infer_id orig id_name | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id) | otherwise = return () -srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr TcId -srcSpanPrimLit dflags span - = HsLit (HsStringPrim "" (unsafeMkByteString - (showSDocOneLine dflags (ppr span)))) - {- Note [Adding the implicit parameter to 'assert'] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker transforms (assert e1 e2) to (assertError "Foo.hs:27" -e1 e2). This isn't really the Right Thing because there's no way to -"undo" if you want to see the original source code in the typechecker +The typechecker transforms (assert e1 e2) to (assertError e1 e2). +This isn't really the Right Thing because there's no way to "undo" +if you want to see the original source code in the typechecker output. We'll have fix this in due course, when we care more about being able to reconstruct the exact original program. diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 605929efbe..39ab4e621b 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -72,7 +72,7 @@ import Util import Data.Maybe( isNothing ) import Control.Monad ( unless, when, zipWithM ) -import PrelNames( ipClassName, funTyConKey, allNameStrings ) +import PrelNames( funTyConKey, allNameStrings ) {- ---------------------------- @@ -490,7 +490,6 @@ tc_hs_type hs_ty@(HsExplicitTupleTy _ tys) exp_kind tc_hs_type ipTy@(HsIParamTy n ty) exp_kind = do { ty' <- tc_lhs_type ty ekLifted ; checkExpectedKind ipTy constraintKind exp_kind - ; ipClass <- tcLookupClass ipClassName ; let n' = mkStrLitTy $ hsIPNameFS n ; return (mkClassPred ipClass [n',ty']) } diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 0684fdf1d5..6feb3f0c33 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -20,9 +20,9 @@ import CoAxiom(sfInteractTop, sfInteractInert) import Var import TcType -import PrelNames ( knownNatClassName, knownSymbolClassName, ipClassNameKey, +import PrelNames ( knownNatClassName, knownSymbolClassName, callStackTyConKey, typeableClassName ) -import TysWiredIn ( typeNatKind, typeSymbolKind ) +import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind ) import Id( idType ) import Class import TyCon @@ -704,7 +704,7 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs else continueWith workItem } - | cls `hasKey` ipClassNameKey + | cls == ipClass , isGiven ev_w = interactGivenIP inerts workItem @@ -1755,7 +1755,7 @@ Other notes: -- i.e. (IP "name" CallStack) isCallStackIP :: CtLoc -> Class -> [Type] -> Maybe (EvTerm -> EvCallStack) isCallStackIP loc cls tys - | cls `hasKey` ipClassNameKey + | cls == ipClass , [_ip_name, ty] <- tys , Just (tc, _) <- splitTyConApp_maybe ty , tc `hasKey` callStackTyConKey diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index 9815958da7..18d3b32fdd 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -29,7 +29,7 @@ import TysWiredIn ( typeNatKind, typeSymbolKind , promotedEQDataCon , promotedGTDataCon ) -import TysPrim ( tyVarList, mkArrowKinds ) +import TysPrim ( mkArrowKinds, mkTemplateTyVars ) import PrelNames ( gHC_TYPELITS , typeNatAddTyFamNameKey , typeNatMulTyFamNameKey @@ -106,7 +106,7 @@ typeNatLeqTyCon :: TyCon typeNatLeqTyCon = mkFamilyTyCon name (mkArrowKinds [ typeNatKind, typeNatKind ] boolKind) - (take 2 $ tyVarList typeNatKind) + (mkTemplateTyVars [ typeNatKind, typeNatKind ]) (BuiltInSynFamTyCon ops) NoParentTyCon @@ -123,7 +123,7 @@ typeNatCmpTyCon :: TyCon typeNatCmpTyCon = mkFamilyTyCon name (mkArrowKinds [ typeNatKind, typeNatKind ] orderingKind) - (take 2 $ tyVarList typeNatKind) + (mkTemplateTyVars [ typeNatKind, typeNatKind ]) (BuiltInSynFamTyCon ops) NoParentTyCon @@ -140,7 +140,7 @@ typeSymbolCmpTyCon :: TyCon typeSymbolCmpTyCon = mkFamilyTyCon name (mkArrowKinds [ typeSymbolKind, typeSymbolKind ] orderingKind) - (take 2 $ tyVarList typeSymbolKind) + (mkTemplateTyVars [ typeSymbolKind, typeSymbolKind ]) (BuiltInSynFamTyCon ops) NoParentTyCon @@ -162,7 +162,7 @@ mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon2 op tcb = mkFamilyTyCon op (mkArrowKinds [ typeNatKind, typeNatKind ] typeNatKind) - (take 2 $ tyVarList typeNatKind) + (mkTemplateTyVars [ typeNatKind, typeNatKind ]) (BuiltInSynFamTyCon tcb) NoParentTyCon diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 1ee53ba582..a2feeef723 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -163,7 +163,7 @@ import TyCon import TysPrim import {-# SOURCE #-} TysWiredIn ( eqTyCon, coercibleTyCon, typeNatKind, typeSymbolKind ) import PrelNames ( eqTyConKey, coercibleTyConKey, - ipClassNameKey, openTypeKindTyConKey, + ipTyConKey, openTypeKindTyConKey, constraintKindTyConKey, liftedTypeKindTyConKey ) import CoAxiom @@ -908,10 +908,10 @@ isIPPred ty = case tyConAppTyCon_maybe ty of _ -> False isIPTyCon :: TyCon -> Bool -isIPTyCon tc = tc `hasKey` ipClassNameKey +isIPTyCon tc = tc `hasKey` ipTyConKey isIPClass :: Class -> Bool -isIPClass cls = cls `hasKey` ipClassNameKey +isIPClass cls = cls `hasKey` ipTyConKey -- Class and it corresponding TyCon have the same Unique isCTupleClass :: Class -> Bool diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs index e2be8a0ec4..291e14ccc1 100644 --- a/compiler/types/TypeRep.hs +++ b/compiler/types/TypeRep.hs @@ -703,7 +703,7 @@ pprTyTcApp :: TyPrec -> TyCon -> [Type] -> SDoc -- Used for types only; so that we can make a -- special case for type-level lists pprTyTcApp p tc tys - | tc `hasKey` ipClassNameKey + | tc `hasKey` ipTyConKey , [LitTy (StrTyLit n),ty] <- tys = maybeParen p FunPrec $ char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty diff --git a/docs/users_guide/7.12.1-notes.xml b/docs/users_guide/7.12.1-notes.xml index 386095e1d9..582966639e 100644 --- a/docs/users_guide/7.12.1-notes.xml +++ b/docs/users_guide/7.12.1-notes.xml @@ -46,8 +46,8 @@ </listitem> <listitem> <para> - Implicit parameters of the new base type - <literal>GHC.Stack.CallStack</literal> are treated + Implicit parameters of the new ghc-prim type + <literal>GHC.Types.CallStack</literal> are treated specially, and automatically solved for the current source location. For example <programlisting> @@ -66,7 +66,7 @@ parameter does not matter. </para> <para> - See the release notes for base for a description of the + See the release notes for ghc-prim for a description of the <literal>CallStack</literal> type. </para> </listitem> @@ -249,19 +249,16 @@ </listitem> <listitem> <para> - A new module <literal>GHC.SrcLoc</literal> was added, - exporting a new type <literal>SrcLoc</literal>. A - <literal>SrcLoc</literal> contains package, module, - and file names, as well as start and end positions. + The functions <literal>error</literal>, + <literal>undefined</literal>, and + <literal>assertError</literal> now take an implicit + <literal>CallStack</literal> parameter, and will + output a formatted call stack alongside the error + message. </para> - </listitem> - <listitem> <para> - A new type <literal>CallStack</literal> was added for use - with the new implicit callstack parameters. A - <literal>CallStack</literal> is a - <literal>[(String, SrcLoc)]</literal>, sorted by most-recent - call. + See <xref linkend="implicit-parameters-special"/> for a description of the + implicit call stack feature. </para> </listitem> <listitem> @@ -400,6 +397,22 @@ Version number XXXXX (was 0.3.1.0) </para> </listitem> + <listitem> + <para> + A new type <literal>SrcLoc</literal> was added. A + <literal>SrcLoc</literal> contains package, module, + and file names, as well as start and end positions. + </para> + </listitem> + <listitem> + <para> + A new type <literal>CallStack</literal> was added for use + with the new implicit callstack parameters. A + <literal>CallStack</literal> is a + <literal>[(String, SrcLoc)]</literal>, sorted by most-recent + call. + </para> + </listitem> </itemizedlist> </sect3> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 92cbdc05a7..f8fa9c34c6 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -8124,9 +8124,9 @@ inner binding of <literal>?x</literal>, so <literal>(f 9)</literal> will return </para> </sect3> -<sect3><title>Special implicit parameters</title> +<sect3 id="implicit-parameters-special"><title>Special implicit parameters</title> <para> -GHC treats implicit parameters of type <literal>GHC.Stack.CallStack</literal> +GHC treats implicit parameters of type <literal>GHC.Types.CallStack</literal> specially, by resolving them to the current location in the program. Consider: <programlisting> f :: String diff --git a/libraries/Cabal b/libraries/Cabal -Subproject f47732a50d4bd103c5660c2fbcd77cbce8c521b +Subproject ad1136358d10d68f3d94fa2fe0f11a25331bdf1 diff --git a/libraries/array b/libraries/array -Subproject 68323b26865ec86a53237ca8974e82bf406a971 +Subproject 2f5b772f4475d70a68c6f9d10390ac9812afdb7 diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs index 9c388f4450..1383972c7a 100644 --- a/libraries/base/Control/Exception.hs +++ b/libraries/base/Control/Exception.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification #-} +{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification, PatternSynonyms #-} ----------------------------------------------------------------------------- -- | @@ -56,6 +56,7 @@ module Control.Exception ( RecSelError(..), RecUpdError(..), ErrorCall(..), + pattern ErrorCall, TypeError(..), -- * Throwing exceptions diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs index ece5c69dd5..ba2502f379 100644 --- a/libraries/base/Control/Exception/Base.hs +++ b/libraries/base/Control/Exception/Base.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- @@ -38,7 +39,7 @@ module Control.Exception.Base ( RecConError(..), RecSelError(..), RecUpdError(..), - ErrorCall(..), + ErrorCall(..), pattern ErrorCall, TypeError(..), -- #10284, custom error type for deferred type errors -- * Throwing exceptions diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs index 9bd71327d9..8cdb10709d 100644 --- a/libraries/base/GHC/Err.hs +++ b/libraries/base/GHC/Err.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -28,17 +28,17 @@ import GHC.Prim import GHC.Integer () -- Make sure Integer is compiled first -- because GHC depends on it in a wired-in way -- so the build system doesn't see the dependency -import {-# SOURCE #-} GHC.Exception( errorCallException ) +import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException ) -- | 'error' stops execution and displays an error message. -error :: [Char] -> a -error s = raise# (errorCallException s) +error :: (?callStack :: CallStack) => [Char] -> a +error s = raise# (errorCallWithCallStackException s ?callStack) -- | A special case of 'error'. -- It is expected that compilers will recognize this and insert error -- messages which are more appropriate to the context in which 'undefined' -- appears. -undefined :: a +undefined :: (?callStack :: CallStack) => a undefined = error "Prelude.undefined" -- | Used for compiler-generated error message; diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs index b82ae114e6..3fbae05c9a 100644 --- a/libraries/base/GHC/Exception.hs +++ b/libraries/base/GHC/Exception.hs @@ -2,6 +2,8 @@ {-# LANGUAGE NoImplicitPrelude , ExistentialQuantification , MagicHash + , RecordWildCards + , PatternSynonyms #-} {-# OPTIONS_HADDOCK hide #-} @@ -22,9 +24,12 @@ module GHC.Exception ( Exception(..) -- Class , throw - , SomeException(..), ErrorCall(..), ArithException(..) + , SomeException(..), ErrorCall(..), pattern ErrorCall, ArithException(..) , divZeroException, overflowException, ratioZeroDenomException - , errorCallException + , errorCallException, errorCallWithCallStackException + , showCallStack, popCallStack, showSrcLoc + -- re-export CallStack and SrcLoc from GHC.Types + , CallStack(..), SrcLoc(..) ) where import Data.Maybe @@ -158,17 +163,61 @@ throw e = raise# (toException e) -- |This is thrown when the user calls 'error'. The @String@ is the -- argument given to 'error'. -newtype ErrorCall = ErrorCall String +data ErrorCall = ErrorCallWithLocation String String deriving (Eq, Ord) +pattern ErrorCall err <- ErrorCallWithLocation err _ where + ErrorCall err = ErrorCallWithLocation err "" + instance Exception ErrorCall instance Show ErrorCall where - showsPrec _ (ErrorCall err) = showString err + showsPrec _ (ErrorCallWithLocation err "") = showString err + showsPrec _ (ErrorCallWithLocation err loc) = showString (err ++ '\n' : loc) errorCallException :: String -> SomeException errorCallException s = toException (ErrorCall s) +errorCallWithCallStackException :: String -> CallStack -> SomeException +errorCallWithCallStackException s stk + = toException (ErrorCallWithLocation s (showCallStack (popCallStack stk))) + + +-- | Pretty print 'SrcLoc' +-- +-- @since 4.8.2.0 +showSrcLoc :: SrcLoc -> String +showSrcLoc SrcLoc {..} + = foldr (++) "" + [ srcLocFile, ":" + , show srcLocStartLine, ":" + , show srcLocStartCol, " in " + , srcLocPackage, ":", srcLocModule + ] + +-- | Pretty print 'CallStack' +-- +-- @since 4.8.2.0 +showCallStack :: CallStack -> String +showCallStack (CallStack stk@(_:_)) + = unlines ("CallStack:" : map (indent . showCallSite) stk) + where + -- Data.OldList isn't available yet, so we repeat the definition here + unlines [] = [] + unlines [l] = l + unlines (l:ls) = l ++ '\n' : unlines ls + indent l = " " ++ l + showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc +showCallStack _ = error "CallStack cannot be empty!" + + +-- | Remove the most recent callsite from the 'CallStack' +-- +-- @since 4.8.2.0 +popCallStack :: CallStack -> CallStack +popCallStack (CallStack (_:rest)) = CallStack rest +popCallStack _ = error "CallStack cannot be empty!" + -- |Arithmetic exceptions. data ArithException = Overflow diff --git a/libraries/base/GHC/Exception.hs-boot b/libraries/base/GHC/Exception.hs-boot index aa19897363..594f2665e8 100644 --- a/libraries/base/GHC/Exception.hs-boot +++ b/libraries/base/GHC/Exception.hs-boot @@ -25,10 +25,13 @@ to get a visibly-bottom value. -} module GHC.Exception ( SomeException, errorCallException, + errorCallWithCallStackException, divZeroException, overflowException, ratioZeroDenomException ) where -import GHC.Types( Char ) +import GHC.Types( Char, CallStack ) data SomeException divZeroException, overflowException, ratioZeroDenomException :: SomeException + errorCallException :: [Char] -> SomeException +errorCallWithCallStackException :: [Char] -> CallStack -> SomeException diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs index 482027b742..e723ebdf33 100644 --- a/libraries/base/GHC/IO/Exception.hs +++ b/libraries/base/GHC/IO/Exception.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric, NoImplicitPrelude, MagicHash, - ExistentialQuantification #-} + ExistentialQuantification, ImplicitParams #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} @@ -352,10 +352,12 @@ instance Show IOException where -- Note the use of "lazy". This means that -- assert False (throw e) -- will throw the assertion failure rather than e. See trac #5561. -assertError :: Addr# -> Bool -> a -> a -assertError str predicate v +assertError :: (?callStack :: CallStack) => Bool -> a -> a +assertError predicate v | predicate = lazy v - | otherwise = throw (AssertionFailed (untangle str "Assertion failed")) + | otherwise = throw (AssertionFailed + ("Assertion failed\n" + ++ showCallStack (popCallStack ?callStack))) unsupportedOperation :: IOError unsupportedOperation = diff --git a/libraries/base/GHC/SrcLoc.hs b/libraries/base/GHC/SrcLoc.hs deleted file mode 100644 index 23a109bd8f..0000000000 --- a/libraries/base/GHC/SrcLoc.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | @since 4.8.2.0 -module GHC.SrcLoc - ( SrcLoc - , srcLocPackage - , srcLocModule - , srcLocFile - , srcLocStartLine - , srcLocStartCol - , srcLocEndLine - , srcLocEndCol - - -- * Pretty printing - , showSrcLoc - ) where - --- | A single location in the source code. --- --- @since 4.8.2.0 -data SrcLoc = SrcLoc - { srcLocPackage :: String - , srcLocModule :: String - , srcLocFile :: String - , srcLocStartLine :: Int - , srcLocStartCol :: Int - , srcLocEndLine :: Int - , srcLocEndCol :: Int - } deriving (Show, Eq) - --- | Pretty print 'SrcLoc' --- --- @since 4.8.2.0 -showSrcLoc :: SrcLoc -> String -showSrcLoc SrcLoc {..} - = concat [ srcLocFile, ":" - , show srcLocStartLine, ":" - , show srcLocStartCol, " in " - , srcLocPackage, ":", srcLocModule - ] diff --git a/libraries/base/GHC/Stack.hsc b/libraries/base/GHC/Stack.hsc index 40fba7dcc8..a2283ff656 100644 --- a/libraries/base/GHC/Stack.hsc +++ b/libraries/base/GHC/Stack.hsc @@ -18,18 +18,10 @@ {-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-} module GHC.Stack ( -- * Call stacks - -- ** Simulated by the RTS currentCallStack, whoCreated, errorWithStackTrace, - -- ** Explicitly created via implicit-parameters - -- - -- @since 4.8.2.0 - CallStack, - getCallStack, - showCallStack, - -- * Internals CostCentreStack, CostCentre, @@ -44,8 +36,6 @@ module GHC.Stack ( renderStack ) where -import Data.List ( unlines ) - import Foreign import Foreign.C @@ -56,8 +46,6 @@ import GHC.Foreign as GHC import GHC.IO.Encoding import GHC.Exception import GHC.List ( concatMap, null, reverse ) -import GHC.Show -import GHC.SrcLoc #define PROFILING #include "Rts.h" @@ -139,52 +127,4 @@ errorWithStackTrace x = unsafeDupablePerformIO $ do stack <- ccsToStrings =<< getCurrentCCS x if null stack then throwIO (ErrorCall x) - else throwIO (ErrorCall (x ++ '\n' : renderStack stack)) - - ----------------------------------------------------------------------- --- Explicit call-stacks built via ImplicitParams ----------------------------------------------------------------------- - --- | @CallStack@s are an alternate method of obtaining the call stack at a given --- point in the program. --- --- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will --- solve it with the current location. If another @CallStack@ implicit-parameter --- is in-scope (e.g. as a function argument), the new location will be appended --- to the one in-scope, creating an explicit call-stack. For example, --- --- @ --- myerror :: (?loc :: CallStack) => String -> a --- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc) --- @ --- ghci> myerror "die" --- *** Exception: die --- ?loc, called at MyError.hs:7:51 in main:MyError --- myerror, called at <interactive>:2:1 in interactive:Ghci1 --- --- @CallStack@s do not interact with the RTS and do not require compilation with --- @-prof@. On the other hand, as they are built up explicitly using --- implicit-parameters, they will generally not contain as much information as --- the simulated call-stacks maintained by the RTS. --- --- The @CallStack@ type is abstract, but it can be converted into a --- @[(String, SrcLoc)]@ via 'getCallStack'. The @String@ is the name of function --- that was called, the 'SrcLoc' is the call-site. The list is ordered with the --- most recently called function at the head. --- --- @since 4.8.2.0 -data CallStack = CallStack { getCallStack :: [(String, SrcLoc)] } - -- See Note [Overview of implicit CallStacks] - deriving (Show, Eq) - --- | Pretty print 'CallStack' --- --- @since 4.8.2.0 -showCallStack :: CallStack -> String -showCallStack (CallStack (root:rest)) - = unlines (showCallSite root : map (indent . showCallSite) rest) - where - indent l = " " ++ l - showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc -showCallStack _ = error "CallStack cannot be empty!" + else throwIO (ErrorCallWithLocation x (renderStack stack)) diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 21a8ae7bcb..33734a00c7 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -248,7 +248,6 @@ Library GHC.StaticPtr GHC.STRef GHC.Show - GHC.SrcLoc GHC.Stable GHC.Stack GHC.Stats diff --git a/libraries/base/tests/assert.stderr b/libraries/base/tests/assert.stderr index 8d99aa0a64..7183f1e763 100644 --- a/libraries/base/tests/assert.stderr +++ b/libraries/base/tests/assert.stderr @@ -1,2 +1,4 @@ -assert: assert.hs:9:11-16: Assertion failed +assert: Assertion failed +CallStack: + assert, called at assert.hs:9:11 in main:Main diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index 7bc746f256..6dcd5f1a7f 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -30,10 +30,11 @@ module GHC.Types ( SPEC(..), Nat, Symbol, Coercible, + SrcLoc(..), CallStack(..) ) where import GHC.Prim - +import GHC.Tuple () infixr 5 : @@ -308,3 +309,51 @@ you're reading this in 2023 then things went wrong). See #8326. -- Libraries can specify this by using 'SPEC' data type to inform which -- loops should be aggressively specialized. data SPEC = SPEC | SPEC2 + +-- | A single location in the source code. +-- +-- @since 4.8.2.0 +data SrcLoc = SrcLoc + { srcLocPackage :: [Char] + , srcLocModule :: [Char] + , srcLocFile :: [Char] + , srcLocStartLine :: Int + , srcLocStartCol :: Int + , srcLocEndLine :: Int + , srcLocEndCol :: Int + } + +---------------------------------------------------------------------- +-- Explicit call-stacks built via ImplicitParams +---------------------------------------------------------------------- + +-- | @CallStack@s are an alternate method of obtaining the call stack at a given +-- point in the program. +-- +-- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will +-- solve it with the current location. If another @CallStack@ implicit-parameter +-- is in-scope (e.g. as a function argument), the new location will be appended +-- to the one in-scope, creating an explicit call-stack. For example, +-- +-- @ +-- myerror :: (?loc :: CallStack) => String -> a +-- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc) +-- @ +-- ghci> myerror "die" +-- *** Exception: die +-- CallStack: +-- ?loc, called at MyError.hs:7:51 in main:MyError +-- myerror, called at <interactive>:2:1 in interactive:Ghci1 +-- +-- @CallStack@s do not interact with the RTS and do not require compilation with +-- @-prof@. On the other hand, as they are built up explicitly using +-- implicit-parameters, they will generally not contain as much information as +-- the simulated call-stacks maintained by the RTS. +-- +-- A @CallStack@ is a @[(String, SrcLoc)]@. The @String@ is the name of +-- function that was called, the 'SrcLoc' is the call-site. The list is +-- ordered with the most recently called function at the head. +-- +-- @since 4.8.2.0 +data CallStack = CallStack { getCallStack :: [([Char], SrcLoc)] } + -- See Note [Overview of implicit CallStacks] diff --git a/testsuite/tests/annotations/should_fail/annfail12.stderr b/testsuite/tests/annotations/should_fail/annfail12.stderr index b3cbb4eb14..37e8378a7e 100644 --- a/testsuite/tests/annotations/should_fail/annfail12.stderr +++ b/testsuite/tests/annotations/should_fail/annfail12.stderr @@ -1,6 +1,8 @@ -annfail12.hs:5:1: +annfail12.hs:5:1: error: Exception when trying to run compile-time code: You were meant to see this error! +CallStack: + error, called at annfail12.hs:5:12 in main:Annfail12 In the annotation: {-# ANN f (error "You were meant to see this error!" :: Int) #-} diff --git a/testsuite/tests/cabal/cabal07/cabal07.stderr b/testsuite/tests/cabal/cabal07/cabal07.stderr index 39f80ff93f..049d77c9bf 100644 --- a/testsuite/tests/cabal/cabal07/cabal07.stderr +++ b/testsuite/tests/cabal/cabal07/cabal07.stderr @@ -1,6 +1,7 @@ -Q.hs:3:8: +Q.hs:3:8: error: Could not find module ‘Data.Set’ - It is a member of the hidden package ‘containers-<VERSION>@<HASH>’. + It is a member of the hidden package ‘containers-0.5.6.2@0tT640fErehCGZtZRn6YbE’. Perhaps you need to add ‘containers’ to the build-depends in your .cabal file. Use -v to see a list of the files searched for. +ExitFailure 1
\ No newline at end of file diff --git a/testsuite/tests/deriving/should_run/T9576.stderr b/testsuite/tests/deriving/should_run/T9576.stderr index bc2a0b3247..49d41a3a36 100644 --- a/testsuite/tests/deriving/should_run/T9576.stderr +++ b/testsuite/tests/deriving/should_run/T9576.stderr @@ -1,4 +1,4 @@ -T9576: T9576.hs:6:31: +T9576: T9576.hs:6:31: error: No instance for (Show Foo) arising from a use of ‘showsPrec’ In the second argument of ‘(.)’, namely ‘(showsPrec 11 b1)’ In the second argument of ‘showParen’, namely diff --git a/testsuite/tests/driver/T1372/T1372.stderr b/testsuite/tests/driver/T1372/T1372.stderr index 2f6bb5f94a..d48426cc9d 100644 --- a/testsuite/tests/driver/T1372/T1372.stderr +++ b/testsuite/tests/driver/T1372/T1372.stderr @@ -1,2 +1,3 @@ -
-Main.hs:5:5: error: Data constructor not in scope: T
+ +Main.hs:5:5: error: Data constructor not in scope: T +ExitFailure 1
\ No newline at end of file diff --git a/testsuite/tests/ghci.debugger/scripts/break009.stdout b/testsuite/tests/ghci.debugger/scripts/break009.stdout index cd9436e34a..b926ed2474 100644 --- a/testsuite/tests/ghci.debugger/scripts/break009.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break009.stdout @@ -2,3 +2,5 @@ Breakpoint 0 activated at ../Test6.hs:5:8-11 Stopped at ../Test6.hs:5:8-11 _result :: a = _ *** Exception: Prelude.head: empty list +CallStack: + error, called at libraries/base/GHC/List.hs:1009:3 in base:GHC.List diff --git a/testsuite/tests/ghci.debugger/scripts/break011.stdout b/testsuite/tests/ghci.debugger/scripts/break011.stdout index b84023b643..dafc1fc397 100644 --- a/testsuite/tests/ghci.debugger/scripts/break011.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break011.stdout @@ -1,4 +1,6 @@ *** Exception: foo +CallStack: + error, called at <interactive>:2:1 in interactive:Ghci1 Stopped at <exception thrown> _exception :: e = _ Stopped at <exception thrown> @@ -7,17 +9,29 @@ _exception :: e = _ -2 : main (../Test7.hs:2:8-29) <end of history> Logged breakpoint at ../Test7.hs:2:18-28 -_result :: a +_result :: a12 Logged breakpoint at ../Test7.hs:2:8-29 -_result :: IO a +_result :: IO a12 no more logged breakpoints Logged breakpoint at ../Test7.hs:2:18-28 -_result :: a +_result :: a12 Stopped at <exception thrown> _exception :: e already at the beginning of the history -_exception = SomeException "foo" -_result :: a = _ -_exception :: SomeException = SomeException "foo" +_exception = SomeException + (ErrorCallWithLocation + "foo" + "CallStack: + error, called at ../Test7.hs:2:18 in main:Main") +_result :: a12 = _ +_exception :: SomeException = SomeException + (ErrorCallWithLocation + "foo" + "CallStack: + error, called at ../Test7.hs:2:18 in main:Main") *** Exception: foo +CallStack: + error, called at ../Test7.hs:2:18 in main:Main *** Exception: foo +CallStack: + error, called at ../Test7.hs:2:18 in main:Main diff --git a/testsuite/tests/ghci.debugger/scripts/break017.stdout b/testsuite/tests/ghci.debugger/scripts/break017.stdout index 305289d216..4825e435bb 100644 --- a/testsuite/tests/ghci.debugger/scripts/break017.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break017.stdout @@ -8,5 +8,8 @@ Printing 1 as = 'b' : 'c' : (_t1::[Char]) Forcing *** Exception: Prelude.undefined +CallStack: + error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err + undefined, called at <interactive>:3:17 in interactive:Ghci1 Printing 2 as = 'b' : 'c' : (_t2::[Char]) diff --git a/testsuite/tests/ghci/scripts/T10501.stderr b/testsuite/tests/ghci/scripts/T10501.stderr index 6c3cc16efd..b9e45ccc66 100644 --- a/testsuite/tests/ghci/scripts/T10501.stderr +++ b/testsuite/tests/ghci/scripts/T10501.stderr @@ -1,2 +1,7 @@ *** Exception: Prelude.head: empty list +CallStack: + error, called at libraries/base/GHC/List.hs:1009:3 in base:GHC.List *** Exception: Prelude.undefined +CallStack: + error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err + undefined, called at <interactive>:1:17 in interactive:Ghci1 diff --git a/testsuite/tests/ghci/scripts/T5557.stdout b/testsuite/tests/ghci/scripts/T5557.stdout index e8585c00f0..aa3a83242e 100644 --- a/testsuite/tests/ghci/scripts/T5557.stdout +++ b/testsuite/tests/ghci/scripts/T5557.stdout @@ -1,2 +1,8 @@ *** Exception: Prelude.undefined +CallStack: + error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err + undefined, called at <interactive>:2:12 in interactive:Ghci1 *** Exception: Prelude.undefined +CallStack: + error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err + undefined, called at <interactive>:3:12 in interactive:Ghci1 diff --git a/testsuite/tests/ghci/scripts/ghci055.stdout b/testsuite/tests/ghci/scripts/ghci055.stdout index 1bac2ab20e..03245e2097 100644 --- a/testsuite/tests/ghci/scripts/ghci055.stdout +++ b/testsuite/tests/ghci/scripts/ghci055.stdout @@ -1,3 +1,6 @@ -*** Exception: Prelude.undefined
-x :: t = *** Exception: Prelude.undefined
-y :: Integer = 3
+*** Exception: Prelude.undefined +CallStack: + error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err + undefined, called at <interactive>:1:7 in interactive:Ghci1 +x :: t = _ +y :: Integer = 3 diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index affc2671a8..7ded1feac4 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -452,7 +452,7 @@ test('T5321Fun', # (increase due to new codegen) # 2014-09-03: 299656164 (specialisation and inlining) # 10/12/2014: 206406188 # Improvements in constraint solver - (wordsize(64), 429921312, 10)]) + (wordsize(64), 509921312, 10)]) # prev: 585521080 # 29/08/2012: 713385808 # (increase due to new codegen) # 15/05/2013: 628341952 # (reason for decrease unknown) @@ -462,6 +462,9 @@ test('T5321Fun', # 06/11/2014: 541287000 # Simon's flat-skol changes to the constraint solver # 10/12/2014: 408110888 # Improvements in constraint solver # 16/12/2014: 429921312 # Flattener parameterized over roles + # 10/08/2015: 509921312 + # (undefined now takes an implicit parameter and GHC -O0 does + # not recognize that the application is bottom) ], compile,['']) @@ -474,7 +477,7 @@ test('T5321FD', # (increase due to new codegen) # 2014-07-31: 211699816 (Windows) (-11%) # (due to better optCoercion, 5e7406d9, #9233) - (wordsize(64), 410895536, 10)]) + (wordsize(64), 470895536, 10)]) # prev: 418306336 # 29/08/2012: 492905640 # (increase due to new codegen) @@ -488,6 +491,9 @@ test('T5321FD', # (due to better optCoercion, 5e7406d9, #9233) # 2014-10-08 410895536 # (various changes; biggest improvements due to 949ad67 and FastString package ids) + # 2015-08-10: 470895536 + # (undefined now takes an implicit parameter and GHC -O0 does + # not recognize that the application is bottom) ], compile,['']) diff --git a/testsuite/tests/simplCore/should_compile/EvalTest.stdout b/testsuite/tests/simplCore/should_compile/EvalTest.stdout index 8bc22a42f2..b536c541c0 100644 --- a/testsuite/tests/simplCore/should_compile/EvalTest.stdout +++ b/testsuite/tests/simplCore/should_compile/EvalTest.stdout @@ -1 +1 @@ -rght [Dmd=<S,U>] :: AList a1 +rght [Dmd=<S,U>] :: AList a diff --git a/testsuite/tests/simplCore/should_compile/T4930.hs b/testsuite/tests/simplCore/should_compile/T4930.hs index ae5d4fd5f7..aeab39e39f 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.hs +++ b/testsuite/tests/simplCore/should_compile/T4930.hs @@ -1,5 +1,5 @@ module T4930 where foo :: Int -> Int -foo n = (if n < 5 then error "Too small" else n+2) +foo n = (if n < 5 then foo n else n+2) `seq` n+5 diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr index 3e140ddc92..552c8a8ddc 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.stderr +++ b/testsuite/tests/simplCore/should_compile/T4930.stderr @@ -1,39 +1,39 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 23, types: 11, coercions: 0} +Result size of Tidy Core = {terms: 35, types: 14, coercions: 0} --- RHS size: {terms: 2, types: 0, coercions: 0} -lvl :: [Char] -[GblId, Str=DmdType] -lvl = unpackCString# "Too small"# - --- RHS size: {terms: 2, types: 1, coercions: 0} -T4930.foo1 :: Int -[GblId, Str=DmdType b] -T4930.foo1 = error @ Int lvl +Rec { +-- RHS size: {terms: 23, types: 6, coercions: 0} +T4930.$wfoo [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# +[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>] +T4930.$wfoo = + \ (ww :: Int#) -> + case case tagToEnum# @ Bool (<# ww 5#) of _ [Occ=Dead] { + False -> I# (+# ww 2#); + True -> case T4930.$wfoo ww of ww1 { __DEFAULT -> I# ww1 } + } + of _ [Occ=Dead] { I# ipv -> + +# ww 5# + } +end Rec } --- RHS size: {terms: 16, types: 5, coercions: 0} -foo :: Int -> Int +-- RHS size: {terms: 10, types: 4, coercions: 0} +foo [InlPrag=INLINE[0]] :: Int -> Int [GblId, Arity=1, + Caf=NoCafRefs, Str=DmdType <S,1*U(U)>m, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (n [Occ=Once!] :: Int) -> - case n of _ [Occ=Dead] { I# x -> - case tagToEnum# @ Bool (<# x 5#) of _ [Occ=Dead] { - False -> I# (+# x 5#); - True -> T4930.foo1 - } + Tmpl= \ (w [Occ=Once!] :: Int) -> + case w of _ [Occ=Dead] { I# ww1 [Occ=Once] -> + case T4930.$wfoo ww1 of ww2 { __DEFAULT -> I# ww2 } }}] foo = - \ (n :: Int) -> - case n of _ [Occ=Dead] { I# x -> - case tagToEnum# @ Bool (<# x 5#) of _ [Occ=Dead] { - False -> I# (+# x 5#); - True -> T4930.foo1 - } + \ (w :: Int) -> + case w of _ [Occ=Dead] { I# ww1 -> + case T4930.$wfoo ww1 of ww2 { __DEFAULT -> I# ww2 } } diff --git a/testsuite/tests/th/T5358.stderr b/testsuite/tests/th/T5358.stderr index c899ed5aa6..695c69e3d9 100644 --- a/testsuite/tests/th/T5358.stderr +++ b/testsuite/tests/th/T5358.stderr @@ -2,6 +2,8 @@ T5358.hs:14:12: error: Exception when trying to run compile-time code: runTest called error: forall (t_0 :: *) . t_0 -> GHC.Types.Bool +CallStack: + error, called at T5358.hs:15:18 in main:T5358 Code: do { VarI _ t _ <- reify (mkName "prop_x1"); ($) error ((++) "runTest called error: " pprint t) } In the untyped splice: diff --git a/testsuite/tests/th/T5976.stderr b/testsuite/tests/th/T5976.stderr index 64cf33acef..f434458a01 100644 --- a/testsuite/tests/th/T5976.stderr +++ b/testsuite/tests/th/T5976.stderr @@ -1,5 +1,7 @@ -T5976.hs:1:1: +T5976.hs:1:1: error: Exception when trying to run compile-time code: bar - Code: error ((++) "foo " error "bar") +CallStack: + error, called at T5976.hs:3:21 in main:Main + Code: error ((++) "foo " error "bar") diff --git a/testsuite/tests/th/T7276a.stdout b/testsuite/tests/th/T7276a.stdout index 3e8c4878a8..410004b14d 100644 --- a/testsuite/tests/th/T7276a.stdout +++ b/testsuite/tests/th/T7276a.stdout @@ -1,14 +1,14 @@ -<interactive>:3:9: Warning: +<interactive>:3:9: warning: Couldn't match type ‘[Dec]’ with ‘Exp’ Expected type: Q Exp Actual type: DecsQ In the expression: [d| a = () |] :: Q Exp In an equation for ‘x’: x = [d| a = () |] :: Q Exp -<interactive>:1:1: +<interactive>:1:1: error: Exception when trying to run compile-time code: - <interactive>:3:9: + <interactive>:3:9: error: Couldn't match type ‘[Dec]’ with ‘Exp’ Expected type: Q Exp Actual type: DecsQ diff --git a/testsuite/tests/th/T8987.stderr b/testsuite/tests/th/T8987.stderr index 2b128bb101..6df4f7d4ec 100644 --- a/testsuite/tests/th/T8987.stderr +++ b/testsuite/tests/th/T8987.stderr @@ -1,5 +1,8 @@ -T8987.hs:1:1: +T8987.hs:1:1: error: Exception when trying to run compile-time code: Prelude.undefined +CallStack: + error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err + undefined, called at T8987.hs:6:23 in main:T8987 Code: (>>) reportWarning ['1', undefined] return [] diff --git a/testsuite/tests/th/TH_exn2.stderr b/testsuite/tests/th/TH_exn2.stderr index 79ec99171a..fb914289a3 100644 --- a/testsuite/tests/th/TH_exn2.stderr +++ b/testsuite/tests/th/TH_exn2.stderr @@ -1,6 +1,8 @@ -TH_exn2.hs:1:1: +TH_exn2.hs:1:1: error: Exception when trying to run compile-time code: Prelude.tail: empty list - Code: do { ds <- [d| |]; - return (tail ds) } +CallStack: + error, called at libraries/base/GHC/List.hs:1009:3 in base:GHC.List + Code: do { ds <- [d| |]; + return (tail ds) } diff --git a/utils/haddock b/utils/haddock -Subproject 6a1d4a65010932a660ceacda93c8c20fb5e1399 +Subproject 7570ed8595402bcd354b7b24de1f4b0e3e527a5 |