X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=59d04ebb86fb93b20cd6867bc50580c1d55d42f4;hb=f16228e47dbaf4c5eb710bf507b3b61bc5ad7122;hp=1a38a133db4253914953acb490f9848caa094513;hpb=d455d8a0f37aba8b7da6250519368a48a9386cca;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 1a38a13..59d04eb 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, @@ -36,7 +36,7 @@ import TcEnv ( TcEnv, tcExtendGlobalValEnv, 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 @@ -52,7 +52,7 @@ import FunDeps ( checkInstFDs ) import Generics ( validGenericInstanceType ) import Module ( Module, foldModuleEnv ) import Name ( getSrcLoc ) -import NameSet ( emptyNameSet, mkNameSet, nameSetToList ) +import NameSet ( unitNameSet, nameSetToList ) import PrelInfo ( eRROR_ID ) import PprType ( pprClassPred, pprPred ) import TyCon ( TyCon, isSynTyCon ) @@ -65,6 +65,7 @@ import Type ( splitDFunTy, isTyVarTy, 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 ) @@ -395,9 +396,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,8 +514,9 @@ 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') -> @@ -601,7 +604,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 = mkNameSet [idName dfun_id | InlineInstSig _ _ <- uprags] + 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 @@ -644,6 +651,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. + %************************************************************************ %* * @@ -718,7 +815,7 @@ checkInstHead dflags theta clas inst_taus maybe_tycon_app = splitTyConApp_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 @@ -729,7 +826,8 @@ 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 theta clas inst_taus | checkInstFDs theta clas inst_taus = []