X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=324ee715a2cb6f5404942c896d829df1e255f49a;hb=cf158e40f528a008226e730f1e47ca6efa9ea8ad;hp=ed4aa9f359e8b793e59226207a93d00589424191;hpb=4e342297f796001e7107d8c348bb023168954bc7;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index ed4aa9f..324ee71 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -13,10 +13,10 @@ import CmdLineOpts ( DynFlag(..), dopt ) import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..), MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), - andMonoBindList, collectMonoBinders, isClassDecl + andMonoBindList, collectMonoBinders, isClassDecl, toHsType ) -import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds, - RenamedTyClDecl, RenamedHsType, +import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, + RenamedMonoBinds, RenamedTyClDecl, RenamedHsType, extractHsTyVars, maybeGenericMatch ) import TcHsSyn ( TcMonoBinds, mkHsConApp ) @@ -25,14 +25,15 @@ import TcClassDcl ( tcMethodBind, badMethodErr ) import TcMonad import TcType ( tcInstType ) import Inst ( InstOrigin(..), - newDicts, newClassDicts, instToId, + newDicts, instToId, LIE, mkLIE, emptyLIE, plusLIE, plusLIEs ) import TcDeriv ( tcDeriving ) import TcEnv ( TcEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, tcAddImportedIdInfo, tcLookupClass, - InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, - newDFunName, tcExtendTyVarEnv + InstInfo(..), pprInstInfo, simpleInstInfoTyCon, + simpleInstInfoTy, newDFunName, tcExtendTyVarEnv, + isLocalThing, ) import InstEnv ( InstEnv, extendInstEnv ) import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType, checkSigTyVars ) @@ -51,7 +52,7 @@ import FunDeps ( checkInstFDs ) import Generics ( validGenericInstanceType ) import Module ( Module, foldModuleEnv ) import Name ( getSrcLoc ) -import NameSet ( emptyNameSet, nameSetToList ) +import NameSet ( emptyNameSet, unitNameSet, nameSetToList ) import PrelInfo ( eRROR_ID ) import PprType ( pprClassPred, pprPred ) import TyCon ( TyCon, isSynTyCon ) @@ -59,9 +60,9 @@ import Type ( splitDFunTy, isTyVarTy, splitTyConApp_maybe, splitDictTy, splitForAllTys, tyVarsOfTypes, mkClassPred, mkTyVarTy, - getClassTys_maybe + isTyVarClassPred, inheritablePred ) -import Subst ( mkTopTyVarSubst, substClasses ) +import Subst ( mkTopTyVarSubst, substTheta ) import VarSet ( varSetElems ) import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy ) import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey ) @@ -171,14 +172,14 @@ tcInstDecls1 :: PackageInstEnv -> [RenamedHsDecl] -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds) -tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls +tcInstDecls1 inst_env0 prs hst unf_env get_fixity this_mod decls = let inst_decls = [inst_decl | InstD inst_decl <- decls] tycl_decls = [decl | TyClD decl <- decls] clas_decls = filter isClassDecl tycl_decls in -- (1) Do the ordinary instance declarations - mapNF_Tc (tcInstDecl1 unf_env) inst_decls `thenNF_Tc` \ inst_infos -> + mapNF_Tc tcInstDecl1 inst_decls `thenNF_Tc` \ inst_infos -> -- (2) Instances from generic class declarations getGenericInstances clas_decls `thenTc` \ generic_inst_info -> @@ -191,7 +192,8 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls -- e) generic instances inst_env4 -- The result of (b) replaces the cached InstEnv in the PCS let - (local_inst_info, imported_inst_info) = partition iLocal (concat inst_infos) + (local_inst_info, imported_inst_info) + = partition (isLocalThing this_mod . iDFunId) (concat inst_infos) imported_dfuns = map (tcAddImportedIdInfo unf_env . iDFunId) imported_inst_info @@ -207,7 +209,8 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls -- we ignore deriving decls from interfaces! -- This stuff computes a context for the derived instance decl, so it -- needs to know about all the instances possible; hecne inst_env4 - tcDeriving prs mod inst_env4 get_fixity tycl_decls `thenTc` \ (deriv_inst_info, deriv_binds) -> + tcDeriving prs this_mod inst_env4 get_fixity tycl_decls + `thenTc` \ (deriv_inst_info, deriv_binds) -> addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env -> returnTc (inst_env1, @@ -229,9 +232,9 @@ addInstDFuns dfuns infos \end{code} \begin{code} -tcInstDecl1 :: TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo] +tcInstDecl1 :: RenamedInstDecl -> NF_TcM [InstInfo] -- Deal with a single instance declaration -tcInstDecl1 unf_env decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc) +tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc) = -- Prime error recovery, set source location recoverNF_Tc (returnNF_Tc []) $ tcAddSrcLoc src_loc $ @@ -267,7 +270,7 @@ tcInstDecl1 unf_env decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc) let dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta in - returnTc [InstInfo { iLocal = is_local, iDFunId = dfun_id, + returnTc [InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = uprags }] \end{code} @@ -309,6 +312,9 @@ getGenericInstances class_decls let gen_inst_info = concat gen_inst_infos in + if null gen_inst_info then + returnTc [] + else getDOptsTc `thenTc` \ dflags -> ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" (vcat (map pprInstInfo gen_inst_info))) @@ -406,7 +412,7 @@ mkGenericInstance clas loc (hs_ty, binds) dfun_id = mkDictFunId dfun_name clas tyvars inst_tys inst_theta in - returnTc (InstInfo { iLocal = True, iDFunId = dfun_id, + returnTc (InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = [] }) \end{code} @@ -498,18 +504,17 @@ is the @dfun_theta@ below. First comes the easy case of a non-local instance decl. + \begin{code} tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds) +-- tcInstDecl2 is called *only* on InstInfos -tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id, +tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags }) - | not is_local - = returnNF_Tc (emptyLIE, EmptyMonoBinds) - - | otherwise = -- Prime error recovery - recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ - tcAddSrcLoc (getSrcLoc dfun_id) $ + recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ + tcAddSrcLoc (getSrcLoc dfun_id) $ + tcAddErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $ -- Instantiate the instance decl with tc-style type variables tcInstType (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') -> @@ -523,7 +528,7 @@ tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id, sel_names = [idName sel_id | (sel_id, _) <- op_items] -- Instantiate the super-class context with inst_tys - sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta + sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta -- Find any definitions in monobinds that aren't from the class bad_bndrs = collectMonoBinders monobinds `minusList` sel_names @@ -537,9 +542,9 @@ tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id, mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_` -- Create dictionary Ids from the specified instance contexts. - newClassDicts origin sc_theta' `thenNF_Tc` \ sc_dicts -> - newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts -> - newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ [this_dict] -> + newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts -> + newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts -> + newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] -> tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' ( tcExtendGlobalValEnv dm_ids ( @@ -597,6 +602,11 @@ tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id, dict_constr = classDataCon clas scs_and_meths = map instToId (sc_dicts ++ meth_insts) this_dict_id = instToId this_dict + inlines = unitNameSet (idName dfun_id) + -- Always inline the dfun; this is an experimental decision + -- because it makes a big performance difference sometimes. + -- Often it means we can do the method selection, and then + -- inline the method as well. Marcin's idea. dict_rhs | null scs_and_meths @@ -629,7 +639,7 @@ tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id, zonked_inst_tyvars (map instToId dfun_arg_dicts) [(inst_tyvars', dfun_id, this_dict_id)] - emptyNameSet -- No inlines (yet) + inlines (lie_binds1 `AndMonoBinds` lie_binds2 `AndMonoBinds` method_binds `AndMonoBinds` @@ -660,21 +670,22 @@ checkInstValidity dflags theta clas inst_tys | null errs = returnTc () | otherwise = addErrsTc errs `thenNF_Tc_` failTc where - errs = checkInstHead dflags clas inst_tys ++ + errs = checkInstHead dflags theta clas inst_tys ++ [err | pred <- theta, err <- checkInstConstraint dflags pred] checkInstConstraint dflags pred - | dopt Opt_AllowUndecidableInstances dflags - = [] + -- Checks whether a predicate is legal in the + -- context of an instance declaration + | ok = [] + | otherwise = [instConstraintErr pred] + where + ok = inheritablePred pred && + (isTyVarClassPred pred || arbitrary_preds_ok) - | Just (clas,tys) <- getClassTys_maybe pred, - all isTyVarTy tys - = [] + arbitrary_preds_ok = dopt Opt_AllowUndecidableInstances dflags - | otherwise - = [instConstraintErr pred] -checkInstHead dflags clas inst_taus +checkInstHead dflags theta clas inst_taus | -- CCALL CHECK -- A user declaration of a CCallable/CReturnable instance -- must be for a "boxed primitive" type. @@ -688,7 +699,7 @@ checkInstHead dflags clas inst_taus -- If GlasgowExts then check at least one isn't a type variable | dopt Opt_GlasgowExts dflags = -- GlasgowExts case - check_tyvars dflags clas inst_taus ++ check_fundeps dflags clas inst_taus + check_tyvars dflags clas inst_taus ++ check_fundeps dflags theta clas inst_taus -- WITH HASKELL 1.4, MUST HAVE C (T a b c) | not (length inst_taus == 1 && @@ -723,11 +734,12 @@ check_tyvars dflags clas inst_taus | otherwise = [the_err] where the_err = instTypeErr clas inst_taus msg - msg = ptext SLIT("There must be at least one non-type-variable in the instance head") + msg = ptext SLIT("There must be at least one non-type-variable in the instance head") + $$ ptext SLIT("Use -fallow-undecidable-instances to lift this restriction") -check_fundeps dflags clas inst_taus - | checkInstFDs clas inst_taus = [] - | otherwise = [the_err] +check_fundeps dflags theta clas inst_taus + | checkInstFDs theta clas inst_taus = [] + | otherwise = [the_err] where the_err = instTypeErr clas inst_taus msg msg = ptext SLIT("the instance types do not agree with the functional dependencies of the class")