From 0877011afd5886ee06df2e2723d631ff0686324f Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 13 Jan 2003 17:01:29 +0000 Subject: [PATCH] [project @ 2003-01-13 17:01:22 by simonpj] ------------------------------------ (a) Improve reporting of staging errors (b) Tidy up the construction of dict funs and default methods ------------------------------------ --- ghc/compiler/basicTypes/MkId.lhs | 9 +++-- ghc/compiler/main/MkIface.lhs | 6 +-- ghc/compiler/typecheck/Inst.lhs | 32 ++++------------ ghc/compiler/typecheck/TcClassDcl.lhs | 8 ++-- ghc/compiler/typecheck/TcEnv.lhs | 66 +++++++++++++++++++++------------ ghc/compiler/typecheck/TcExpr.lhs | 21 +++-------- ghc/compiler/typecheck/TcInstDcls.lhs | 5 +-- ghc/compiler/typecheck/TcRnDriver.lhs | 3 +- ghc/compiler/typecheck/TcRnTypes.lhs | 2 +- ghc/compiler/typecheck/TcSplice.lhs | 45 +++++++++++----------- ghc/compiler/types/Class.lhs | 1 + 11 files changed, 92 insertions(+), 106 deletions(-) diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index c8b00b7..0b69a4b 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -68,8 +68,8 @@ import DataCon ( DataCon, dataConSig, dataConStrictMarks, dataConWorkId, splitProductType ) -import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, - mkTemplateLocals, mkTemplateLocalsNum, +import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkLocalId, + mkTemplateLocals, mkTemplateLocalsNum, setIdLocalExported, mkTemplateLocal, idNewStrictness, idName ) import IdInfo ( IdInfo, noCafIdInfo, hasCafIdInfo, @@ -755,7 +755,8 @@ BUT make sure they are *exported* LocalIds (setIdLocalExported) so that they aren't discarded by the occurrence analyser. \begin{code} -mkDefaultMethodId dm_name ty = mkVanillaGlobal dm_name ty noCafIdInfo +mkDefaultMethodId dm_name ty + = setIdLocalExported (mkLocalId dm_name ty) mkDictFunId :: Name -- Name to use for the dict fun; -> [TyVar] @@ -765,7 +766,7 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> Id mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys - = mkVanillaGlobal dfun_name dfun_ty noCafIdInfo + = setIdLocalExported (mkLocalId dfun_name dfun_ty) where dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 432b23a..899d0df 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -250,7 +250,7 @@ ifaceTyThing (AClass clas) = cls_decl toClassOpSig (sel_id, def_meth) = ASSERT(sel_tyvars == clas_tyvars) - ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc + ClassOpSig (getName sel_id) def_meth (toHsType op_ty) noSrcLoc where -- Be careful when splitting the type, because of things -- like class Foo a where @@ -259,10 +259,6 @@ ifaceTyThing (AClass clas) = cls_decl -- op :: (Ord a) => a -> a (sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id) op_ty = tcFunResultTy rho_ty - def_meth' = case def_meth of - NoDefMeth -> NoDefMeth - GenDefMeth -> GenDefMeth - DefMeth id -> DefMeth (getName id) ifaceTyThing (ATyCon tycon) = ty_decl where diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 8b045ad..083c364 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -21,7 +21,7 @@ module Inst ( ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, instLoc, getDictClassTys, dictPred, - lookupInst, lookupSimpleInst, LookupInstResult(..), + lookupInst, LookupInstResult(..), isDict, isClassDict, isMethod, isLinearInst, linearInstType, isIPDict, isInheritableInst, @@ -43,7 +43,7 @@ import TcHsSyn ( TcExpr, TcId, TcIdSet, TypecheckedHsExpr, mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId ) import TcRnMonad -import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon ) +import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl ) import InstEnv ( InstLookupResult(..), lookupInstEnv ) import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType, zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars @@ -540,7 +540,7 @@ lookupInst :: Inst -> TcM (LookupInstResult s) -- Dictionaries -lookupInst dict@(Dict _ (ClassP clas tys) loc) +lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) = getDOpts `thenM` \ dflags -> tcGetInstEnv `thenM` \ inst_env -> case lookupInstEnv dflags inst_env clas tys of @@ -551,6 +551,10 @@ lookupInst dict@(Dict _ (ClassP clas tys) loc) -- instance C X a => D X where ... -- (presumably there's a functional dependency in class C) -- Hence the mk_ty_arg to instantiate any un-substituted tyvars. + getStage `thenM` \ use_stage -> + checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred)) + (topIdLvl dfun_id) use_stage `thenM_` + traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_` let (tyvars, rho) = tcSplitForAllTys (idType dfun_id) mk_ty_arg tv = case lookupSubstEnv tenv tv of @@ -616,28 +620,6 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit)) \end{code} -There is a second, simpler interface, when you want an instance of a -class at a given nullary type constructor. It just returns the -appropriate dictionary if it exists. It is used only when resolving -ambiguous dictionaries. - -\begin{code} -lookupSimpleInst :: Class - -> [Type] -- Look up (c,t) - -> TcM (Maybe ThetaType) -- Here are the needed (c,t)s - -lookupSimpleInst clas tys - = getDOpts `thenM` \ dflags -> - tcGetInstEnv `thenM` \ inst_env -> - case lookupInstEnv dflags inst_env clas tys of - FoundInst tenv dfun - -> returnM (Just (substTheta (mkSubst emptyInScopeSet tenv) theta)) - where - (_, rho) = tcSplitForAllTys (idType dfun) - (theta,_) = tcSplitPhiTy rho - - other -> returnM Nothing -\end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 191ff05..c37ff49 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -385,10 +385,8 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name) -- TyGenNever (in MkId). Ugh! KSW 1999-09. theta = [mkClassPred clas inst_tys] - dm_id = mkDefaultMethodId dm_name dm_ty - local_dm_id = setIdLocalExported dm_id - -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId - xtve = tyvars `zip` clas_tyvars + local_dm_id = mkDefaultMethodId dm_name dm_ty + xtve = tyvars `zip` clas_tyvars in newDicts origin theta `thenM` \ [this_dict] -> @@ -416,7 +414,7 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name) emptyNameSet -- No inlines (yet) (dict_binds `andMonoBinds` defm_bind) in - returnM (full_bind, [dm_id]) + returnM (full_bind, [local_dm_id]) where origin = ClassDeclOrigin \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 23eba50..84de731 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -37,7 +37,8 @@ module TcEnv( RecTcGblEnv, tcLookupRecId_maybe, -- Template Haskell stuff - wellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel, + checkWellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel, + topIdLvl, -- New Ids newLocalName, newDFunName, @@ -104,11 +105,41 @@ metaLevel Comp = topLevel metaLevel (Splice l) = l metaLevel (Brack l _ _) = l -wellStaged :: Level -- Binding level - -> Level -- Use level - -> Bool -wellStaged bind_stage use_stage - = bind_stage <= use_stage + +checkWellStaged :: SDoc -- What the stage check is for + -> Level -- Binding level + -> Stage -- Use stage + -> TcM () -- Fail if badly staged, adding an error +checkWellStaged pp_thing bind_lvl use_stage + | bind_lvl <= use_lvl -- OK! + = returnM () + + | bind_lvl == topLevel -- GHC restriction on top level splices + = failWithTc $ + sep [ptext SLIT("GHC stage restriction:") <+> pp_thing, + nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))] + + | otherwise -- Badly staged + = failWithTc $ + ptext SLIT("Stage error:") <+> pp_thing <+> + hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl, + ptext SLIT("but used at stage") <+> ppr use_lvl] + where + use_lvl = metaLevel use_stage + + +topIdLvl :: Id -> Level +-- Globals may either be imported, or may be from an earlier "chunk" +-- (separated by declaration splices) of this module. The former +-- *can* be used inside a top-level splice, but the latter cannot. +-- Hence we give the former impLevel, but the latter topLevel +-- E.g. this is bad: +-- x = [| foo |] +-- $( f x ) +-- By the time we are prcessing the $(f x), the binding for "x" +-- will be in the global env, not the local one. +topIdLvl id | isLocalId id = topLevel + | otherwise = impLevel -- Indicates the legal transitions on bracket( [| |] ). bracketOK :: Stage -> Maybe Level @@ -182,9 +213,11 @@ newLocalName name -- Make a clone returnM (mkInternalName uniq (getOccName name) (getSrcLoc name)) \end{code} -Make a name for the dict fun for an instance decl. -It's a *local* name for the moment. The CoreTidy pass -will externalise it. +Make a name for the dict fun for an instance decl. It's a *local* +name for the moment. The CoreTidy pass will externalise it. Even in +--make and ghci stuff, we rebuild the instance environment each time, +so the dfun id is internal to begin with, and external when compiling +other modules \begin{code} newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name @@ -339,22 +372,9 @@ tcLookupIdLvl name = tcLookup name `thenM` \ thing -> case thing of ATcId tc_id lvl -> returnM (tc_id, lvl) - AGlobal (AnId id) -- See [Note: Levels] - | isLocalId id -> returnM (id, topLevel) - | otherwise -> returnM (id, impLevel) + AGlobal (AnId id) -> returnM (id, topIdLvl id) other -> pprPanic "tcLookupIdLvl" (ppr name) --- [Note: Levels] --- Globals may either be imported, or may be from an earlier "chunk" --- (separated by declaration splices) of this module. The former --- *can* be used inside a top-level splice, but the latter cannot. --- Hence we give the former impLevel, but the latter topLevel --- E.g. this is bad: --- x = [| foo |] --- $( f x ) --- By the time we are prcessing the $(f x), the binding for "x" --- will be in the global env, not the local one. - tcLookupLocalIds :: [Name] -> TcM [TcId] -- We expect the variables to all be bound, and all at -- the same level as the lookup. Only used in one place... diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 5827426..025c7dc 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -13,7 +13,7 @@ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) import HsSyn ( HsReify(..), ReifyFlavour(..) ) import TcType ( isTauTy ) import TcEnv ( bracketOK, tcMetaTy, tcLookupGlobal, - wellStaged, metaLevel ) + checkWellStaged, metaLevel ) import TcSimplify ( tcSimplifyBracket ) import Name ( isExternalName ) import qualified DsMeta @@ -805,8 +805,10 @@ tcId name -- Look up the Id and instantiate its type -- If 'x' occurs many times we may get many identical -- bindings of the same splice proxy, but that doesn't -- matter, although it's a mite untidy. - -- NB: isExernalName is true of top level things, - -- and false of nested bindings + -- + -- NB: During type-checking, isExernalName is true of + -- top level things, and false of nested bindings + -- Top-level things don't need lifting. let id_ty = idType id @@ -829,11 +831,7 @@ tcId name -- Look up the Id and instantiate its type returnM (HsVar id, id_ty)) other -> - let - use_lvl = metaLevel use_stage - in - checkTc (wellStaged bind_lvl use_lvl) - (badStageErr id bind_lvl use_lvl) `thenM_` + checkWellStaged (quotes (ppr id)) bind_lvl use_stage `thenM_` #endif -- This is the bit that handles the no-Template-Haskell case case isDataConWrapId_maybe id of @@ -1050,12 +1048,6 @@ Boring and alphabetical: arithSeqCtxt expr = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr) - -badStageErr id bind_lvl use_lvl - = ptext SLIT("Stage error:") <+> quotes (ppr id) <+> - hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl, - ptext SLIT("but used at stage") <+> ppr use_lvl] - parrSeqCtxt expr = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr) @@ -1123,7 +1115,6 @@ missingStrictFields con fields header = ptext SLIT("Constructor") <+> quotes (ppr con) <+> ptext SLIT("does not have the required strict field(s)") - missingFields :: DataCon -> [FieldLabel] -> SDoc missingFields con fields = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:") diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 866741e..b30af59 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -545,9 +545,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) -- Create the result bindings let - local_dfun_id = setIdLocalExported dfun_id - -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId - dict_constr = classDataCon clas scs_and_meths = map instToId sc_dicts ++ meth_ids this_dict_id = instToId this_dict @@ -593,7 +590,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) main_bind = AbsBinds zonked_inst_tyvars (map instToId dfun_arg_dicts) - [(inst_tyvars', local_dfun_id, this_dict_id)] + [(inst_tyvars', dfun_id, this_dict_id)] inlines all_binds in showLIE "instance" `thenM_` diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 8028df4..2aec006 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -57,8 +57,7 @@ import Inst ( showLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) -import TcEnv ( RecTcGblEnv, - tcExtendGlobalValEnv, +import TcEnv ( tcExtendGlobalValEnv, tcExtendGlobalEnv, tcExtendInstEnv, tcExtendRules, tcLookupTyCon, tcLookupGlobal, diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 3cae143..d7bfd17 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -355,7 +355,7 @@ topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level spli impLevel, topLevel :: Level -topLevel = 1 -- Things dedined at top level of this module +topLevel = 1 -- Things defined at top level of this module impLevel = 0 -- Imported things; they can be used inside a top level splice -- -- For example: diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index a5ebd6e..ba6891d 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -129,21 +129,10 @@ tcSpliceExpr name expr res_ty -- inner escape before dealing with the outer one tcTopSplice expr res_ty - = checkNoErrs ( - -- checkNoErrs: must not try to run the thing - -- if the type checker fails! + = tcMetaTy exprTyConName `thenM` \ meta_exp_ty -> - tcMetaTy exprTyConName `thenM` \ meta_exp_ty -> - setStage topSpliceStage ( - getLIE (tcMonoExpr expr meta_exp_ty) - ) `thenM` \ (expr', lie) -> - - -- Solve the constraints - tcSimplifyTop lie `thenM` \ const_binds -> - - -- Wrap the bindings around it and zonk - zonkTopExpr (mkHsLet const_binds expr') - ) `thenM` \ zonked_q_expr -> + -- Typecheck the expression + tcTopSpliceExpr expr meta_exp_ty `thenM` \ zonked_q_expr -> -- Run the expression traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_` @@ -163,6 +152,23 @@ tcTopSplice expr res_ty importSupportingDecls fvs `thenM` \ env -> setGblEnv env (tcMonoExpr exp3 res_ty) + + +tcTopSpliceExpr :: RenamedHsExpr -> TcType -> TcM TypecheckedHsExpr +tcTopSpliceExpr expr meta_ty + = checkNoErrs $ -- checkNoErrs: must not try to run the thing + -- if the type checker fails! + + setStage topSpliceStage $ + + -- Typecheck the expression + getLIE (tcMonoExpr expr meta_ty) `thenM` \ (expr', lie) -> + + -- Solve the constraints + tcSimplifyTop lie `thenM` \ const_binds -> + + -- And zonk it + zonkTopExpr (mkHsLet const_binds expr') \end{code} @@ -177,15 +183,10 @@ tcTopSplice expr res_ty tcSpliceDecls expr = tcMetaTy decTyConName `thenM` \ meta_dec_ty -> tcMetaTy qTyConName `thenM` \ meta_q_ty -> - setStage topSpliceStage ( - getLIE (tcMonoExpr expr (mkAppTy meta_q_ty (mkListTy meta_dec_ty))) - ) `thenM` \ (expr', lie) -> - -- Solve the constraints - tcSimplifyTop lie `thenM` \ const_binds -> - let - q_expr = mkHsLet const_binds expr' + let + list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty) in - zonkTopExpr q_expr `thenM` \ zonked_q_expr -> + tcTopSpliceExpr expr list_q `thenM` \ zonked_q_expr -> -- Run the expression traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_` diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 6aced85..3a37d16 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -63,6 +63,7 @@ type ClassOpItem = (Id, DefMeth Name) data DefMeth id = NoDefMeth -- No default method | DefMeth id -- A polymorphic default method (named id) + -- (Only instantiated to RdrName and Name, never Id) | GenDefMeth -- A generic default method deriving Eq \end{code} -- 1.7.10.4