X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=d35c0de5aaae2d643c984f4e972feb4e0f313da4;hb=7dc97354e24071c4ece647b918cd5eb1d0cd85ed;hp=6d9f99fa147fb3f36c5e4eae011b9c2c6ce92f78;hpb=64ac3c5fc190617c81c8db8c8050c00794ac026d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 6d9f99f..d35c0de 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -31,8 +31,7 @@ import TcType ( mkClassPred, mkTyVarTy, tcSplitForAllTys, tyVarsOfType, tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys, TyVarDetails(..) ) -import Inst ( InstOrigin(..), newMethod, newMethodAtLoc, - newDicts, instToId, showLIE ) +import Inst ( InstOrigin(..), tcInstClassOp, newDicts, instToId, showLIE ) import TcDeriv ( tcDeriving ) import TcEnv ( tcExtendGlobalValEnv, tcLookupClass, tcExtendTyVarEnv2, @@ -50,7 +49,6 @@ import DataCon ( classDataCon ) import Class ( Class, classBigSig ) import Var ( idName, idType ) import NameSet -import Id ( setIdLocalExported ) import MkId ( mkDictFunId, rUNTIME_ERROR_ID ) import FunDeps ( checkInstFDs ) import Generics ( validGenericInstanceType ) @@ -491,7 +489,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) 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 @@ -546,9 +544,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = 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_ids this_dict_id = instToId this_dict @@ -594,10 +589,10 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) 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) @@ -611,29 +606,60 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' mappM (addErrTc . badMethodErr clas) bad_bndrs `thenM_` -- Make the method bindings - mapAndUnzipM do_one op_items `thenM` \ (meth_ids, meth_binds_s) -> + 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_ids, andMonoBindList meth_binds_s) + returnM ([meth_id | (_,meth_id,_) <- meth_infos], + andMonoBindList meth_binds_s) - where - xtve = inst_tyvars `zip` inst_tyvars' - do_one op_item - = mkMethodBind InstanceDeclOrigin clas - inst_tys' monobinds op_item `thenM` \ (meth_inst, meth_info) -> - tcMethodBind xtve inst_tyvars' dfun_theta' - avail_insts uprags meth_info `thenM` \ meth_bind -> - -- Could add meth_insts to avail_insts, but not worth the bother - returnM (instToId meth_inst, meth_bind) -- 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 -> - getLIE (mapAndUnzipM (do_one inst_loc) op_items) `thenM` \ ((meth_ids, meth_binds), lie) -> + = 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 lie `thenM` \ lie_binds -> + inst_tyvars' avail_insts rhs_insts `thenM` \ lie_binds -> -- I don't think we have to do the checkSigTyVars thing @@ -641,14 +667,16 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' where do_one inst_loc (sel_id, _) - = newMethodAtLoc inst_loc sel_id inst_tys' `thenM` \ meth_inst -> - -- Like in mkMethodBind - newMethod InstanceDeclOrigin sel_id rep_tys' `thenM` \ rhs_id -> - -- The binding is like "op @ NewTy = op @ RepTy" + = -- 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 rhs_id)) + 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