X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=e60bfbc4d671da77afaf992a96b7016c86959907;hb=6c9ea495a3ba994141dd9e00f4c443371a944016;hp=9b478e01e2e526c783ac1b4df4baa025fc653c65;hpb=df65fd0b7646ffa17ed553289a4cd0e806bef8b9;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 9b478e0..e60bfbc 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,7 +23,11 @@ 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, instToId, LIE, mkLIE, emptyLIE, plusLIE, plusLIEs ) @@ -32,16 +36,17 @@ 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, unitNameSet, 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, - isTyVarClassPred, inheritablePred - ) 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 ) @@ -198,7 +198,10 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity this_mod decls imported_dfuns = map (tcAddImportedIdInfo unf_env . iDFunId) imported_inst_info hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst - in + in + +-- pprTrace "tcInstDecls" (vcat [ppr imported_dfuns, ppr hst_dfuns]) $ + addInstDFuns inst_env0 imported_dfuns `thenNF_Tc` \ inst_env1 -> addInstDFuns inst_env1 hst_dfuns `thenNF_Tc` \ inst_env2 -> addInstInfos inst_env2 local_inst_info `thenNF_Tc` \ inst_env3 -> @@ -222,13 +225,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 +246,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 +267,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 +276,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 +405,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 +523,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 @@ -531,11 +547,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, -- 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_` @@ -546,6 +557,9 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, 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 @@ -602,6 +616,10 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, 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 @@ -644,6 +662,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. + %************************************************************************ %* * @@ -698,9 +806,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 ) @@ -715,17 +823,17 @@ 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