Commit a7b751db authored by Eric Seidel's avatar Eric Seidel Committed by Ben Gamari

un-wire-in error, undefined, CallStack, and IP

I missed a crucial step in the wiring-in process of `CallStack` in D861,
the bit where you actually wire-in the Name... This led to a nasty bug
where GHC thought `CallStack` was not wired-in and tried to fingerprint
it, which failed because the defining module was not loaded.

But we don't need `CallStack` to be wired-in anymore since `error` and
`undefined` no longer need to be wired-in. So we just remove them all.

Updates haddock submodule.

Test Plan: `./validate` and `make slowtest TEST=tc198`

Reviewers: simonpj, goldfire, austin, hvr, bgamari

Reviewed By: simonpj, bgamari

Subscribers: goldfire, thomie

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D1739

GHC Trac Issues: #11331
parent 2fd407cd
......@@ -44,8 +44,8 @@ module MkCore (
mkRuntimeErrorApp, mkImpossibleExpr, errorIds,
rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,
uNDEFINED_ID, tYPE_ERROR_ID, undefinedName
pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,
tYPE_ERROR_ID
) where
#include "HsVersions.h"
......@@ -621,16 +621,7 @@ templates, but we don't ever expect to generate code for it.
errorIds :: [Id]
errorIds
= [ eRROR_ID, -- This one isn't used anywhere else in the compiler
-- But we still need it in wiredInIds so that when GHC
-- compiles a program that mentions 'error' we don't
-- import its type from the interface file; we just get
-- the Id defined here. Which has an 'open-tyvar' type.
uNDEFINED_ID, -- Ditto for 'undefined'. The big deal is to give it
-- an 'open-tyvar' type.
rUNTIME_ERROR_ID,
= [ rUNTIME_ERROR_ID,
iRREFUT_PAT_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID,
nO_METHOD_BINDING_ERROR_ID,
......@@ -684,35 +675,6 @@ runtimeErrorTy :: Type
runtimeErrorTy = mkSpecSigmaTy [levity1TyVar, openAlphaTyVar] []
(mkFunTy addrPrimTy openAlphaTy)
errorName :: Name
errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
eRROR_ID :: Id
eRROR_ID = pc_bottoming_Id2 errorName errorTy
errorTy :: Type -- See Note [Error and friends have an "open-tyvar" forall]
errorTy = mkSpecSigmaTy [levity1TyVar, 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_Id1 undefinedName undefinedTy
undefinedTy :: Type -- See Note [Error and friends have an "open-tyvar" forall]
undefinedTy = mkSpecSigmaTy [levity1TyVar, openAlphaTyVar] []
(mkFunTy (mkClassPred
ipClass
[ mkStrLitTy (fsLit "callStack")
, mkTyConTy callStackTyCon ])
openAlphaTy)
{-
Note [Error and friends have an "open-tyvar" forall]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -753,14 +715,4 @@ pc_bottoming_Id1 name ty
-- SRTs.
strict_sig = mkClosedStrictSig [evalDmd] exnRes
-- exnRes: these throw an exception, not just diverge
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
`setArityInfo` 2
strict_sig = mkClosedStrictSig [evalDmd, evalDmd] exnRes
-- exnRes: these throw an exception, not just diverge
-- exnRes: these throw an exception, not just diverge
......@@ -67,7 +67,7 @@ import Var
-- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv )
import TysWiredIn
import TysPrim
import PrelNames( funTyConKey )
import PrelNames( funTyConKey, ipClassKey )
import Name
import BasicTypes
import Binary
......@@ -776,7 +776,7 @@ pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args)
pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc
pprTyTcApp ctxt_prec tc tys dflags
| ifaceTyConName tc == getName ipTyCon
| ifaceTyConName tc `hasKey` ipClassKey
, ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys
= char '?' <> ftext n <> ptext (sLit "::") <> ppr_ty TopPrec ty
......
......@@ -1626,7 +1626,7 @@ mkPrintUnqualified dflags env = QueryQualify qual_name
forceUnqualNames :: [Name]
forceUnqualNames =
map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon
, starKindTyCon, unicodeStarKindTyCon, ipTyCon ]
, starKindTyCon, unicodeStarKindTyCon ]
++ [ eqTyConName ]
right_name gre = nameModule_maybe (gre_name gre) == Just mod
......
......@@ -326,9 +326,14 @@ basicKnownKeyNames
-- Overloaded labels
isLabelClassName,
-- Source locations
callStackDataConName, callStackTyConName,
-- Implicit Parameters
ipClassName,
-- Call Stacks
callStackTyConName,
emptyCallStackName, pushCallStackName,
-- Source Locations
srcLocDataConName,
-- Annotation type checking
......@@ -1327,11 +1332,14 @@ isLabelClassName :: Name
isLabelClassName
= clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey
-- Implicit Parameters
ipClassName :: Name
ipClassName
= clsQual gHC_CLASSES (fsLit "IP") ipClassKey
-- Source Locations
callStackDataConName, callStackTyConName, emptyCallStackName, pushCallStackName,
callStackTyConName, emptyCallStackName, pushCallStackName,
srcLocDataConName :: Name
callStackDataConName
= dcQual gHC_STACK_TYPES (fsLit "CallStack") callStackDataConKey
callStackTyConName
= tcQual gHC_STACK_TYPES (fsLit "CallStack") callStackTyConKey
emptyCallStackName
......@@ -1484,6 +1492,10 @@ semigroupClassKey, monoidClassKey :: Unique
semigroupClassKey = mkPreludeClassUnique 46
monoidClassKey = mkPreludeClassUnique 47
-- Implicit Parameters
ipClassKey :: Unique
ipClassKey = mkPreludeClassUnique 48
---------------- Template Haskell -------------------
-- THNames.hs: USES ClassUniques 200-299
-----------------------------------------------------
......@@ -1711,13 +1723,6 @@ callStackTyConKey = mkPreludeTyConUnique 182
typeRepTyConKey :: Unique
typeRepTyConKey = mkPreludeTyConUnique 183
-- Implicit Parameters
ipTyConKey :: Unique
ipTyConKey = mkPreludeTyConUnique 184
ipCoNameKey :: Unique
ipCoNameKey = mkPreludeTyConUnique 185
---------------- Template Haskell -------------------
-- THNames.hs: USES TyConUniques 200-299
-----------------------------------------------------
......@@ -1792,13 +1797,9 @@ staticPtrInfoDataConKey = mkPreludeDataConUnique 34
fingerprintDataConKey :: Unique
fingerprintDataConKey = mkPreludeDataConUnique 35
callStackDataConKey, srcLocDataConKey :: Unique
callStackDataConKey = mkPreludeDataConUnique 36
srcLocDataConKey :: Unique
srcLocDataConKey = mkPreludeDataConUnique 37
ipDataConKey :: Unique
ipDataConKey = mkPreludeDataConUnique 38
-- Levity
liftedDataConKey, unliftedDataConKey :: Unique
liftedDataConKey = mkPreludeDataConUnique 39
......
......@@ -83,11 +83,6 @@ module TysWiredIn (
heqTyCon, heqClass, heqDataCon,
coercibleTyCon, coercibleDataCon, coercibleClass,
-- * Implicit Parameters
ipTyCon, ipDataCon, ipClass,
callStackTyCon,
mkWiredInTyConName, -- This is used in TcTypeNats to define the
-- built-in functions for evaluation.
......@@ -112,7 +107,6 @@ import PrelNames
import TysPrim
-- others:
import FamInstEnv( mkNewTypeCoAxiom )
import CoAxiom
import Id
import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
......@@ -233,7 +227,6 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
, liftedTypeKindTyCon
, starKindTyCon
, unicodeStarKindTyCon
, ipTyCon
]
mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
......@@ -248,13 +241,6 @@ 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
mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName mod fs uniq id
= mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax
......@@ -1113,55 +1099,3 @@ promotedGTDataCon = promoteDataCon gtDataCon
promotedConsDataCon, promotedNilDataCon :: TyCon
promotedConsDataCon = promoteDataCon consDataCon
promotedNilDataCon = promoteDataCon nilDataCon
{-
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
(mkPrelTyConRepName ipTyConName)
where
kind = mkFunTys [typeSymbolKind, liftedTypeKind] constraintKind
[ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind]
rhs = NewTyCon ipDataCon (mkTyVarTy a) ([], mkTyVarTy a) ipCoAxiom
ipCoAxiom :: CoAxiom Unbranched
ipCoAxiom = mkNewTypeCoAxiom 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 [] []
......@@ -38,7 +38,6 @@ import FamInst( tcGetFamInstEnvs )
import TyCon
import TcType
import TysPrim
import TysWiredIn
import Id
import Var
import VarSet
......@@ -58,7 +57,7 @@ import BasicTypes
import Outputable
import FastString
import Type(mkStrLitTy, tidyOpenType)
import PrelNames( mkUnboundName, gHC_PRIM )
import PrelNames( mkUnboundName, gHC_PRIM, ipClassName )
import TcValidity (checkValidType)
import qualified GHC.LanguageExtensions as LangExt
......@@ -233,7 +232,8 @@ tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
= do { (given_ips, ip_binds') <-
= do { ipClass <- tcLookupClass ipClassName
; (given_ips, ip_binds') <-
mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
-- If the binding binds ?x = E, we must now
......
......@@ -199,6 +199,7 @@ tcExpr e@(HsIPVar x) res_ty
be a tau-type.) -}
ip_ty <- newOpenFlexiTyVarTy
; let ip_name = mkStrLitTy (hsIPNameFS x)
; ipClass <- tcLookupClass ipClassName
; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var)))
ip_ty res_ty }
......
......@@ -41,8 +41,7 @@ import Encoding
import DynFlags
import PrelInfo
import FamInstEnv( FamInst )
import MkCore ( eRROR_ID )
import PrelNames hiding (error_RDR)
import PrelNames
import THNames
import Module ( moduleName, moduleNameString
, moduleUnitId, unitIdString )
......@@ -2384,10 +2383,9 @@ f_Pat = nlVarPat f_RDR
k_Pat = nlVarPat k_RDR
z_Pat = nlVarPat z_RDR
minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName
minusInt_RDR, tagToEnum_RDR :: RdrName
minusInt_RDR = getRdrName (primOpId IntSubOp )
tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
error_RDR = getRdrName eRROR_ID
con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
-- Generates Orig s RdrName, for the binding positions
......
......@@ -616,6 +616,7 @@ tc_hs_type mode (HsIParamTy n ty) exp_kind
= do { MASSERT( isTypeLevel (mode_level mode) )
; ty' <- tc_lhs_type mode ty liftedTypeKind
; let n' = mkStrLitTy $ hsIPNameFS n
; ipClass <- tcLookupClass ipClassName
; checkExpectedKind (mkClassPred ipClass [n',ty'])
constraintKind exp_kind }
......
......@@ -24,8 +24,8 @@ import TcType
import Name
import PrelNames ( knownNatClassName, knownSymbolClassName,
typeableClassName, coercibleTyConKey,
heqTyConKey )
import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind, heqDataCon,
heqTyConKey, ipClassKey )
import TysWiredIn ( typeNatKind, typeSymbolKind, heqDataCon,
coercibleDataCon )
import TysPrim ( eqPrimTyCon, eqReprPrimTyCon )
import Id( idType )
......@@ -716,7 +716,7 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs
else
continueWith workItem }
| cls == ipClass
| cls `hasKey` ipClassKey
, isGiven ev_w
= interactGivenIP inerts workItem
......
......@@ -130,7 +130,6 @@ import HsSyn
import CoreSyn
import HscTypes
import TcEvidence
import TysWiredIn ( callStackTyCon, ipClass )
import Type
import Class ( Class )
import TyCon ( TyCon )
......@@ -139,6 +138,8 @@ import ConLike ( ConLike(..) )
import DataCon ( DataCon, dataConUserType, dataConOrigArgTys )
import PatSyn ( PatSyn, patSynType )
import Id ( idName )
import PrelNames ( callStackTyConKey, ipClassKey )
import Unique ( hasKey )
import FieldLabel ( FieldLabel )
import TcType
import Annotations
......@@ -1757,10 +1758,10 @@ isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of
-- If so, returns @Just "name"@.
isCallStackCt :: Ct -> Maybe FastString
isCallStackCt CDictCan { cc_class = cls, cc_tyargs = tys }
| cls == ipClass
| cls `hasKey` ipClassKey
, [ip_name_ty, ty] <- tys
, Just (tc, _) <- splitTyConApp_maybe ty
, tc == callStackTyCon
, tc `hasKey` callStackTyConKey
= isStrLitTy ip_name_ty
isCallStackCt _
= Nothing
......
......@@ -2367,7 +2367,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` ipTyConKey
| tc `hasKey` ipClassKey
, [LitTy (StrTyLit n),ty] <- tys
= maybeParen p FunPrec $
char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty
......
......@@ -1554,11 +1554,11 @@ isIPPred ty = case tyConAppTyCon_maybe ty of
_ -> False
isIPTyCon :: TyCon -> Bool
isIPTyCon tc = tc `hasKey` ipTyConKey
isIPTyCon tc = tc `hasKey` ipClassKey
-- Class and its corresponding TyCon have the same Unique
isIPClass :: Class -> Bool
isIPClass cls = cls `hasKey` ipTyConKey
-- Class and it corresponding TyCon have the same Unique
isIPClass cls = cls `hasKey` ipClassKey
isCTupleClass :: Class -> Bool
isCTupleClass cls = isTupleTyCon (classTyCon cls)
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-}
{-# LANGUAGE RankNTypes, TypeInType #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
......@@ -23,7 +24,7 @@
module GHC.Err( absentErr, error, errorWithoutStackTrace, undefined ) where
import GHC.CString ()
import GHC.Types (Char)
import GHC.Types (Char, Levity)
import GHC.Stack.Types
import GHC.Prim
import GHC.Integer () -- Make sure Integer is compiled first
......@@ -32,13 +33,15 @@ import GHC.Integer () -- Make sure Integer is compiled first
import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException )
-- | 'error' stops execution and displays an error message.
error :: (?callStack :: CallStack) => [Char] -> a
error :: forall (v :: Levity). forall (a :: TYPE v).
(?callStack :: CallStack) => [Char] -> a
error s = raise# (errorCallWithCallStackException s ?callStack)
-- | A variant of 'error' that does not produce a stack trace.
--
-- @since 4.9.0.0
errorWithoutStackTrace :: [Char] -> a
errorWithoutStackTrace :: forall (v :: Levity). forall (a :: TYPE v).
[Char] -> a
errorWithoutStackTrace s
= let ?callStack = freezeCallStack ?callStack
in error s
......@@ -59,14 +62,15 @@ errorWithoutStackTrace s
-- name of the offending partial function, so the partial stack-trace
-- does not provide any extra information, just noise. Thus, we export
-- the callstack-aware error, but within base we use the
-- errorWithoutStackTrace variant for more hygienic erorr messages.
-- errorWithoutStackTrace variant for more hygienic error messages.
-- | 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 :: (?callStack :: CallStack) => a
undefined :: forall (v :: Levity). forall (a :: TYPE v).
(?callStack :: CallStack) => a
undefined = error "Prelude.undefined"
-- | Used for compiler-generated error message;
......
Subproject commit c2e89153c0aaf2dc4e3908701f19d739eb0d8b93
Subproject commit 8269b349dd04f7561f9fe6c9e4ba514d3a7d21ab
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment