X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=b30e4fcf7edc33382c67887a43bcddfb5cf2e673;hb=d069cec2bd92d4156aeab80f7eb1f222a82e4103;hp=53e30cc2b8bee50b40cd590d6da093dd7a2fc8ce;hpb=ecb2ccfb36c2b2b9605082eb6a0b0349ecb7dcfb;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 53e30cc..b30e4fc 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -12,8 +12,8 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where import CmdLineOpts ( DynFlag(..), dopt ) import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..), - MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), - andMonoBindList, collectMonoBinders, isClassDecl + MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), HsTyVarBndr(..), + andMonoBindList, collectMonoBinders, isClassDecl, toHsType ) import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds, RenamedTyClDecl, RenamedHsType, @@ -23,25 +23,30 @@ import TcHsSyn ( TcMonoBinds, mkHsConApp ) import TcBinds ( tcSpecSigs ) import TcClassDcl ( tcMethodBind, badMethodErr ) import TcMonad -import TcType ( tcInstType ) +import TcMType ( tcInstType, tcInstTyVars ) +import TcType ( tcSplitDFunTy, tcIsTyVarTy, tcSplitTyConApp_maybe, + tyVarsOfTypes, mkClassPred, mkTyVarTy, + isTyVarClassPred, inheritablePred + ) 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, + simpleInstInfoTy, newDFunName, isLocalThing, ) import InstEnv ( InstEnv, extendInstEnv ) -import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType, checkSigTyVars ) +import TcMonoType ( tcHsTyVars, tcHsSigType, kcHsSigType, checkSigTyVars ) import TcSimplify ( tcSimplifyCheck ) import HscTypes ( HomeSymbolTable, DFunId, ModDetails(..), PackageInstEnv, PersistentRenamerState ) +import Subst ( substTy, substTheta ) import DataCon ( classDataCon ) import Class ( Class, DefMeth(..), classBigSig ) import Var ( idName, idType ) @@ -52,19 +57,14 @@ import FunDeps ( checkInstFDs ) import Generics ( validGenericInstanceType ) import Module ( Module, foldModuleEnv ) import Name ( getSrcLoc ) -import NameSet ( emptyNameSet, nameSetToList ) +import NameSet ( unitNameSet, nameSetToList ) import PrelInfo ( eRROR_ID ) import PprType ( pprClassPred, pprPred ) import TyCon ( TyCon, isSynTyCon ) -import Type ( splitDFunTy, isTyVarTy, - splitTyConApp_maybe, splitDictTy, - splitForAllTys, - tyVarsOfTypes, mkClassPred, mkTyVarTy, - getClassTys_maybe - ) -import Subst ( mkTopTyVarSubst, substClasses ) +import Subst ( mkTopTyVarSubst, substTheta ) import VarSet ( varSetElems ) import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy ) +import ForeignCall ( Safety(..) ) import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey ) import Name ( Name ) import SrcLoc ( SrcLoc ) @@ -222,13 +222,16 @@ addInstInfos :: InstEnv -> [InstInfo] -> NF_TcM InstEnv addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos) addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv -addInstDFuns dfuns infos +addInstDFuns inst_env dfuns = getDOptsTc `thenTc` \ dflags -> let - (inst_env', errs) = extendInstEnv dflags dfuns infos + (inst_env', errs) = extendInstEnv dflags inst_env dfuns in addErrsTc errs `thenNF_Tc_` + traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) `thenTc_` returnTc inst_env' + where + pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun) \end{code} \begin{code} @@ -240,13 +243,15 @@ tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc) tcAddSrcLoc src_loc $ -- Type-check all the stuff before the "where" + traceTc (text "Starting inst" <+> ppr poly_ty) `thenTc_` tcAddErrCtxt (instDeclCtxt poly_ty) ( tcHsSigType poly_ty ) `thenTc` \ poly_ty' -> let - (tyvars, theta, clas, inst_tys) = splitDFunTy poly_ty' + (tyvars, theta, clas, inst_tys) = tcSplitDFunTy poly_ty' in + traceTc (text "Check validity") `thenTc_` (case maybe_dfun_name of Nothing -> -- A source-file instance declaration @@ -259,6 +264,7 @@ tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc) checkInstValidity dflags theta clas inst_tys `thenTc_` -- Make the dfun id and return it + traceTc (text "new name") `thenTc_` newDFunName clas inst_tys src_loc `thenNF_Tc` \ dfun_name -> returnNF_Tc (True, dfun_name) @@ -267,6 +273,7 @@ tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc) returnNF_Tc (False, dfun_name) ) `thenNF_Tc` \ (is_local, dfun_name) -> + traceTc (text "Name" <+> ppr dfun_name) `thenTc_` let dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta in @@ -395,9 +402,10 @@ mkGenericInstance clas loc (hs_ty, binds) -- For example: instance (C a, C b) => C (a+b) where { binds } = -- Extract the universally quantified type variables - tcTyVars (nameSetToList (extractHsTyVars hs_ty)) - (kcHsSigType hs_ty) `thenTc` \ tyvars -> - tcExtendTyVarEnv tyvars $ + let + sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty)) + in + tcHsTyVars sig_tvs (kcHsSigType hs_ty) $ \ tyvars -> -- Type-check the instance type, and check its form tcHsSigType hs_ty `thenTc` \ inst_ty -> @@ -512,14 +520,19 @@ tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds) tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags }) = -- 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') -> let - (clas, inst_tys') = splitDictTy dict_ty' - origin = InstanceDeclOrigin + (inst_tyvars, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id) + in + tcInstTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) -> + let + inst_tys' = map (substTy tenv) inst_tys + dfun_theta' = substTheta tenv dfun_theta + origin = InstanceDeclOrigin (class_tyvars, sc_theta, _, op_items) = classBigSig clas @@ -527,25 +540,23 @@ tcInstDecl2 (InstInfo { 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 - - -- The type variable from the dict fun actually scope - -- over the bindings. They were gotten from - -- the original instance declaration - (inst_tyvars, _) = splitForAllTys (idType dfun_id) in -- Check that all the method bindings come from this class 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' ( + -- The type variable from the dict fun actually scope + -- over the bindings. They were gotten from + -- the original instance declaration tcExtendGlobalValEnv dm_ids ( -- Default-method Ids may be mentioned in synthesised RHSs @@ -601,6 +612,11 @@ tcInstDecl2 (InstInfo { 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; see comments below. dict_rhs | null scs_and_meths @@ -633,7 +649,7 @@ tcInstDecl2 (InstInfo { 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` @@ -643,6 +659,96 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, main_bind `AndMonoBinds` prag_binds) \end{code} + ------------------------------ + Inlining dfuns unconditionally + ------------------------------ + +The code above unconditionally inlines dict funs. Here's why. +Consider this program: + + test :: Int -> Int -> Bool + test x y = (x,y) == (y,x) || test y x + -- Recursive to avoid making it inline. + +This needs the (Eq (Int,Int)) instance. If we inline that dfun +the code we end up with is good: + + Test.$wtest = + \r -> case ==# [ww ww1] of wild { + PrelBase.False -> Test.$wtest ww1 ww; + PrelBase.True -> + case ==# [ww1 ww] of wild1 { + PrelBase.False -> Test.$wtest ww1 ww; + PrelBase.True -> PrelBase.True []; + }; + }; + Test.test = \r [w w1] + case w of w2 { + PrelBase.I# ww -> + case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; }; + }; + +If we don't inline the dfun, the code is not nearly as good: + + (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl { + PrelBase.:DEq tpl1 tpl2 -> tpl2; + }; + + Test.$wtest = + \r [ww ww1] + let { y = PrelBase.I#! [ww1]; } in + let { x = PrelBase.I#! [ww]; } in + let { sat_slx = PrelTup.(,)! [y x]; } in + let { sat_sly = PrelTup.(,)! [x y]; + } in + case == sat_sly sat_slx of wild { + PrelBase.False -> Test.$wtest ww1 ww; + PrelBase.True -> PrelBase.True []; + }; + + Test.test = + \r [w w1] + case w of w2 { + PrelBase.I# ww -> + case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; }; + }; + +Why doesn't GHC inline $fEq? Because it looks big: + + PrelTup.zdfEqZ1T{-rcX-} + = \ @ a{-reT-} :: * @ b{-reS-} :: * + zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}} + zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} -> + let { + zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-}) + zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in + let { + zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-}) + zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in + let { + zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-}) + zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-}) + ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) -> + case ds{-rf5-} + of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) -> + case ds1{-rf4-} + of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) -> + PrelBase.zaza{-r4e-} + (zeze1{-rf3-} a1{-rf2-} b1{-rf1-}) + (zeze{-rf0-} a2{-reZ-} b2{-reY-}) + } + } } in + let { + a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-}) + a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-}) + b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) -> + PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-}) + } in + PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-}) + +and it's not as bad as it seems, because it's further dramatically +simplified: only zeze2 is extracted and its body is simplified. + %************************************************************************ %* * @@ -668,15 +774,16 @@ checkInstValidity 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 theta clas inst_taus | -- CCALL CHECK @@ -696,9 +803,9 @@ checkInstHead dflags theta clas inst_taus -- WITH HASKELL 1.4, MUST HAVE C (T a b c) | not (length inst_taus == 1 && - maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor + maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor not (isSynTyCon tycon) && -- ...but not a synonym - all isTyVarTy arg_tys && -- Applied to type variables + all tcIsTyVarTy arg_tys && -- Applied to type variables length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys -- This last condition checks that all the type variables are distinct ) @@ -713,21 +820,22 @@ checkInstHead dflags theta clas inst_taus (first_inst_tau : _) = inst_taus -- Stuff for algebraic or -> type - maybe_tycon_app = splitTyConApp_maybe first_inst_tau + maybe_tycon_app = tcSplitTyConApp_maybe first_inst_tau Just (tycon, arg_tys) = maybe_tycon_app - ccallable_type dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty + ccallable_type dflags ty = isFFIArgumentTy dflags PlayRisky ty creturnable_type ty = isFFIImportResultTy dflags ty check_tyvars dflags clas inst_taus -- Check that at least one isn't a type variable -- unless -fallow-undecideable-instances | dopt Opt_AllowUndecidableInstances dflags = [] - | not (all isTyVarTy inst_taus) = [] + | not (all tcIsTyVarTy 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 theta clas inst_taus | checkInstFDs theta clas inst_taus = []