X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=d35c0de5aaae2d643c984f4e972feb4e0f313da4;hb=f0192b817c0ed2e0558df2b5d129f9dd0a710f81;hp=99dba4c262da7d3b552c062757a76aecd7af8c6b;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 99dba4c..d35c0de 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -28,29 +28,28 @@ import TcRnMonad import TcMType ( tcInstType, checkValidTheta, checkValidInstHead, instTypeErr, checkAmbiguity, UserTypeCtxt(..), SourceTyCtxt(..) ) import TcType ( mkClassPred, mkTyVarTy, tcSplitForAllTys, tyVarsOfType, - tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, + tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys, TyVarDetails(..) ) -import Inst ( InstOrigin(..), newDicts, instToId, showLIE ) +import Inst ( InstOrigin(..), tcInstClassOp, newDicts, instToId, showLIE ) import TcDeriv ( tcDeriving ) -import TcEnv ( tcExtendGlobalValEnv, tcExtendLocalValEnv2, +import TcEnv ( tcExtendGlobalValEnv, tcLookupClass, tcExtendTyVarEnv2, tcExtendInstEnv, tcExtendLocalInstEnv, tcLookupGlobalId, - InstInfo(..), pprInstInfo, simpleInstInfoTyCon, + InstInfo(..), InstBindings(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, newDFunName ) import PprType ( pprClassPred ) -import TcMonoType ( tcSigPolyId, tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType ) +import TcMonoType ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType ) import TcUnify ( checkSigTyVars ) import TcSimplify ( tcSimplifyCheck, tcSimplifyTop ) import HscTypes ( DFunId ) -import Subst ( mkTyVarSubst, substTheta ) +import Subst ( mkTyVarSubst, substTheta, substTy ) import DataCon ( classDataCon ) import Class ( Class, classBigSig ) import Var ( idName, idType ) import NameSet -import Id ( setIdLocalExported ) -import MkId ( mkDictFunId, unsafeCoerceId, rUNTIME_ERROR_ID ) +import MkId ( mkDictFunId, rUNTIME_ERROR_ID ) import FunDeps ( checkInstFDs ) import Generics ( validGenericInstanceType ) import Name ( getSrcLoc ) @@ -59,7 +58,7 @@ import TyCon ( TyCon ) import TysWiredIn ( genericTyCons ) import SrcLoc ( SrcLoc ) import Unique ( Uniquable(..) ) -import Util ( lengthExceeds, isSingleton ) +import Util ( lengthExceeds ) import BasicTypes ( NewOrData(..) ) import UnicodeUtil ( stringToUtf8 ) import ErrUtils ( dumpIfSet_dyn ) @@ -233,12 +232,12 @@ tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags Nothing src_loc) in checkValidTheta InstThetaCtxt theta `thenM_` checkAmbiguity tyvars theta (tyVarsOfType tau) `thenM_` - checkValidInstHead tau `thenM` \ (clas,inst_tys) -> + checkValidInstHead tau `thenM` \ (clas,inst_tys) -> checkTc (checkInstFDs theta clas inst_tys) (instTypeErr (pprClassPred clas inst_tys) msg) `thenM_` newDFunName clas inst_tys src_loc `thenM` \ dfun_name -> - returnM (Just (InstInfo { iDFunId = mkDictFunId dfun_name clas tyvars inst_tys theta, - iBinds = binds, iPrags = uprags })) + returnM (Just (InstInfo { iDFunId = mkDictFunId dfun_name tyvars theta clas inst_tys, + iBinds = VanillaInst binds uprags })) where msg = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class")) \end{code} @@ -394,10 +393,10 @@ mkGenericInstance clas loc (hs_ty, binds) newDFunName clas [inst_ty] loc `thenM` \ dfun_name -> let inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] - dfun_id = mkDictFunId dfun_name clas tyvars [inst_ty] inst_theta + dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty] in - returnM (InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = [] }) + returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] }) \end{code} @@ -484,31 +483,13 @@ First comes the easy case of a non-local instance decl. \begin{code} tcInstDecl2 :: InstInfo -> TcM TcMonoBinds -tcInstDecl2 (NewTypeDerived { iDFunId = dfun_id }) - = tcInstType InstTv (idType dfun_id) `thenM` \ (inst_tyvars', dfun_theta', inst_head') -> - newDicts InstanceDeclOrigin dfun_theta' `thenM` \ rep_dicts -> - let - rep_dict_id = ASSERT( isSingleton rep_dicts ) - instToId (head rep_dicts) -- Derived newtypes have just one dict arg - - body = TyLam inst_tyvars' $ - DictLam [rep_dict_id] $ - (HsVar unsafeCoerceId `TyApp` [idType rep_dict_id, inst_head']) - `HsApp` - (HsVar rep_dict_id) - -- You might wonder why we have the 'coerce'. It's because the - -- type equality mechanism isn't clever enough; see comments with Type.eqType. - -- So Lint complains if we don't have this. - in - returnM (VarMonoBind dfun_id body) - -tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags }) +tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) = -- Prime error recovery recoverM (returnM EmptyMonoBinds) $ addSrcLoc (getSrcLoc dfun_id) $ addErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $ let - inst_ty = idType dfun_id + inst_ty = idType dfun_id (inst_tyvars, _) = tcSplitForAllTys inst_ty -- The tyvars of the instance decl scope over the 'where' part -- Those tyvars are inside the dfun_id's type, which is a bit @@ -533,44 +514,38 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags } -- Default-method Ids may be mentioned in synthesised RHSs, -- but they'll already be in the environment. - -- Check that all the method bindings come from this class - mkMethodBinds clas inst_tys' op_items monobinds `thenM` \ (meth_insts, meth_infos) -> - - let -- These insts are in scope; quite a few, eh? - avail_insts = [this_dict] ++ dfun_arg_dicts ++ - sc_dicts ++ meth_insts - - xtve = inst_tyvars `zip` inst_tyvars' - tc_meth = tcMethodBind xtve inst_tyvars' dfun_theta' avail_insts uprags + ------------------ + -- Typecheck the methods + let -- These insts are in scope; quite a few, eh? + avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts in - mappM tc_meth meth_infos `thenM` \ meth_binds_s -> + tcMethods clas inst_tyvars inst_tyvars' + dfun_theta' inst_tys' avail_insts + op_items binds `thenM` \ (meth_ids, meth_binds) -> -- Figure out bindings for the superclass context tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts `thenM` \ (zonked_inst_tyvars, sc_binds_inner, sc_binds_outer) -> - -- Deal with SPECIALISE instance pragmas by making them + -- Deal with 'SPECIALISE instance' pragmas by making them -- look like SPECIALISE pragmas for the dfun let + uprags = case binds of + VanillaInst _ uprags -> uprags + other -> [] spec_prags = [ SpecSig (idName dfun_id) ty loc - | SpecInstSig ty loc <- uprags] + | SpecInstSig ty loc <- uprags ] + xtve = inst_tyvars `zip` inst_tyvars' in - tcExtendGlobalValEnv [dfun_id] ( - tcExtendTyVarEnv2 xtve $ - tcExtendLocalValEnv2 [(idName sel_id, tcSigPolyId sig) - | (sel_id, sig, _) <- meth_infos] $ - -- Map sel_id to the local method name we are using + tcExtendTyVarEnv2 xtve $ tcSpecSigs spec_prags ) `thenM` \ prag_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_insts) + scs_and_meths = map instToId sc_dicts ++ meth_ids this_dict_id = instToId this_dict inlines | null dfun_arg_dicts = emptyNameSet | otherwise = unitNameSet (idName dfun_id) @@ -582,6 +557,8 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags } -- BUT: don't inline it if it's a constant dictionary; -- we'll get all the benefit without inlining, and we get -- a **lot** of code duplication if we inline it + -- + -- See Note [Inline dfuns] below dict_rhs | null scs_and_meths @@ -607,21 +584,107 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags } msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas) dict_bind = VarMonoBind this_dict_id dict_rhs - meth_binds = andMonoBindList meth_binds_s all_binds = sc_binds_inner `AndMonoBinds` meth_binds `AndMonoBinds` dict_bind 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_` + showLIE (text "instance") `thenM_` returnM (main_bind `AndMonoBinds` prag_binds `AndMonoBinds` sc_binds_outer) + + +tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' + avail_insts op_items (VanillaInst monobinds uprags) + = -- Check that all the method bindings come from this class + let + sel_names = [idName sel_id | (sel_id, _) <- op_items] + bad_bndrs = collectMonoBinders monobinds `minusList` sel_names + in + mappM (addErrTc . badMethodErr clas) bad_bndrs `thenM_` + + -- Make the method bindings + let + mk_method_bind = mkMethodBind InstanceDeclOrigin clas inst_tys' monobinds + in + mapAndUnzipM mk_method_bind op_items `thenM` \ (meth_insts, meth_infos) -> + + -- And type check them + -- It's really worth making meth_insts available to the tcMethodBind + -- Consider instance Monad (ST s) where + -- {-# INLINE (>>) #-} + -- (>>) = ...(>>=)... + -- If we don't include meth_insts, we end up with bindings like this: + -- rec { dict = MkD then bind ... + -- then = inline_me (... (GHC.Base.>>= dict) ...) + -- bind = ... } + -- The trouble is that (a) 'then' and 'dict' are mutually recursive, + -- and (b) the inline_me prevents us inlining the >>= selector, which + -- would unravel the loop. Result: (>>) ends up as a loop breaker, and + -- is not inlined across modules. Rather ironic since this does not + -- happen without the INLINE pragma! + -- + -- Solution: make meth_insts available, so that 'then' refers directly + -- to the local 'bind' rather than going via the dictionary. + -- + -- BUT WATCH OUT! If the method type mentions the class variable, then + -- this optimisation is not right. Consider + -- class C a where + -- op :: Eq a => a + -- + -- instance C Int where + -- op = op + -- The occurrence of 'op' on the rhs gives rise to a constraint + -- op at Int + -- The trouble is that the 'meth_inst' for op, which is 'available', also + -- looks like 'op at Int'. But they are not the same. + let + all_insts = avail_insts ++ catMaybes meth_insts + xtve = inst_tyvars `zip` inst_tyvars' + tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags + in + mapM tc_method_bind meth_infos `thenM` \ meth_binds_s -> + + returnM ([meth_id | (_,meth_id,_) <- meth_infos], + andMonoBindList meth_binds_s) + + +-- Derived newtype instances +tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' + avail_insts op_items (NewTypeDerived rep_tys) + = getInstLoc InstanceDeclOrigin `thenM` \ inst_loc -> + mapAndUnzip3M (do_one inst_loc) op_items `thenM` \ (meth_ids, meth_binds, rhs_insts) -> + + tcSimplifyCheck + (ptext SLIT("newtype derived instance")) + inst_tyvars' avail_insts rhs_insts `thenM` \ lie_binds -> + + -- I don't think we have to do the checkSigTyVars thing + + returnM (meth_ids, lie_binds `AndMonoBinds` andMonoBindList meth_binds) + + where + do_one inst_loc (sel_id, _) + = -- The binding is like "op @ NewTy = op @ RepTy" + -- Make the *binder*, like in mkMethodBind + tcInstClassOp inst_loc sel_id inst_tys' `thenM` \ meth_inst -> + + -- Make the *occurrence on the rhs* + tcInstClassOp inst_loc sel_id rep_tys' `thenM` \ rhs_inst -> + let + meth_id = instToId meth_inst + in + return (meth_id, VarMonoBind meth_id (HsVar (instToId rhs_inst)), rhs_inst) + + -- Instantiate rep_tys with the relevant type variables + rep_tys' = map (substTy subst) rep_tys + subst = mkTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars') \end{code} -Superclass loops -~~~~~~~~~~~~~~~~ +Note: [Superclass loops] +~~~~~~~~~~~~~~~~~~~~~~~~~ We have to be very, very careful when generating superclasses, lest we accidentally build a loop. Here's an example: @@ -673,7 +736,7 @@ tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts -- We must simplify this all the way down -- lest we build superclass loops - -- See notes about superclass loops above + -- See Note [Superclass loops] above tcSimplifyTop sc_lie `thenM` \ sc_binds2 -> returnM (zonked_inst_tyvars, sc_binds1, sc_binds2) @@ -682,26 +745,9 @@ tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts doc = ptext SLIT("instance declaration superclass context") \end{code} -\begin{code} -mkMethodBinds clas inst_tys' op_items monobinds - = -- Check that all the method bindings come from this class - mappM (addErrTc . badMethodErr clas) bad_bndrs `thenM_` - - -- Make the method bindings - mapAndUnzipM mk_method_bind op_items - - where - mk_method_bind op_item = mkMethodBind InstanceDeclOrigin clas - inst_tys' monobinds op_item - - -- Find any definitions in monobinds that aren't from the class - sel_names = [idName sel_id | (sel_id, _) <- op_items] - bad_bndrs = collectMonoBinders monobinds `minusList` sel_names -\end{code} - ------------------------------ - Inlining dfuns unconditionally + [Inline dfuns] Inlining dfuns unconditionally ------------------------------ The code above unconditionally inlines dict funs. Here's why.