X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcClassDcl.lhs;h=820ed749f5a100788c6196d3a06ed98793065266;hb=f078d9bc6719ff7ee489c04797545f7666bcaae6;hp=2149943be5f66818766fd1b8fcdbc9dc4934e718;hpb=dcf829c2a86907a6c2494bae213ce7978151124b;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 2149943..820ed74 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -16,7 +16,7 @@ import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), isClassOpSig, isPragSig, placeHolderType ) -import BasicTypes ( RecFlag(..), StrictnessMark(..) ) +import BasicTypes ( RecFlag(..) ) import RnHsSyn ( RenamedTyClDecl, RenamedSig, RenamedClassOpSig, RenamedMonoBinds, maybeGenericMatch @@ -26,13 +26,13 @@ import TcHsSyn ( TcMonoBinds ) import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod ) import TcEnv ( TyThingDetails(..), - tcLookupClass, tcExtendTyVarEnv2, - tcExtendTyVarEnv + tcLookupClass, tcExtendLocalValEnv2, + tcExtendTyVarEnv2, tcExtendTyVarEnv ) import TcTyDecls ( tcMkDataCon ) -import TcBinds ( tcMonoBinds ) +import TcBinds ( tcMonoBinds, tcSpecSigs ) import TcMonoType ( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig ) -import TcSimplify ( tcSimplifyCheck ) +import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) import TcUnify ( checkSigTyVars, sigCtxt ) import TcMType ( tcInstTyVars ) import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, @@ -48,12 +48,11 @@ import Class ( classTyVars, classBigSig, classTyCon, import TyCon ( tyConGenInfo ) import Subst ( substTyWith ) import MkId ( mkDictSelId, mkDefaultMethodId ) -import Id ( Id, idType, idName, mkUserLocal, setIdLocalExported, setInlinePragma ) +import Id ( Id, idType, idName, mkUserLocal, setInlinePragma ) import Name ( Name, NamedThing(..) ) import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv ) import NameSet ( emptyNameSet, unitNameSet ) -import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, - mkSuperDictSelOcc, reportIfUnused ) +import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, reportIfUnused ) import Outputable import Var ( TyVar ) import CmdLineOpts @@ -122,7 +121,7 @@ tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name, in tcExtendTyVarEnv tyvars $ - checkDefaultBinds clas op_names def_methods `thenM` \ mb_dm_env -> + checkDefaultBinds clas op_names def_methods `thenM` \ mb_dm_env -> -- CHECK THE CONTEXT -- The renamer has already checked that the context mentions @@ -150,9 +149,6 @@ tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name, sc_tys = mkPredTys sc_theta dict_component_tys = sc_tys ++ op_tys sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names] - -- Slightly curiously, the dictionary selectors are treated as RecordSelectorIds, - -- so they are treated as implicit Ids, but we don't give labelled fields to - -- the data constructors in tcMkDataCon datacon_name [{- No strictness -}] @@ -376,14 +372,7 @@ tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnM (EmptyMonoBinds, tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name) = tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) -> let - dm_ty = idType sel_id -- Same as dict selector! - -- The default method's type should really come from the - -- iface file, since it could be usage-generalised, but this - -- requires altering the mess of knots in TcModule and I'm - -- too scared to do that. Instead, I have disabled generalisation - -- of types of default methods (and dict funs) by annotating them - -- TyGenNever (in MkId). Ugh! KSW 1999-09. - + dm_ty = idType sel_id -- Same as dict selector! theta = [mkClassPred clas inst_tys] local_dm_id = mkDefaultMethodId dm_name dm_ty xtve = tyvars `zip` clas_tyvars @@ -456,12 +445,13 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags (sel_id, meth_id, meth_bind) = -- Check the bindings; first adding inst_tyvars to the envt -- so that we don't quantify over them in nested places - mkTcSig meth_id `thenM` \ meth_sig -> + mkTcSig meth_id `thenM` \ meth_sig -> tcExtendTyVarEnv2 xtve ( - addErrCtxt (methodCtxt sel_id) $ - getLIE (tcMonoBinds meth_bind [meth_sig] NonRecursive) - ) `thenM` \ ((meth_bind, _, _), meth_lie) -> + addErrCtxt (methodCtxt sel_id) $ + getLIE $ + tcMonoBinds meth_bind [meth_sig] NonRecursive + ) `thenM` \ ((meth_bind,_), meth_lie) -> -- Now do context reduction. We simplify wrt both the local tyvars -- and the ones of the class/instance decl, so that there is @@ -487,25 +477,42 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags checkSigTyVars all_tyvars `thenM` \ all_tyvars' -> let + sel_name = idName sel_id + inline_prags = [ (is_inl, phase) + | InlineSig is_inl name phase _ <- prags, + name == sel_name ] + spec_prags = [ prag + | prag@(SpecSig name _ _) <- prags, + name == sel_name] + -- Attach inline pragmas as appropriate (final_meth_id, inlines) - | (InlineSig inl _ phase _ : _) <- filter is_inline prags + | ((is_inline, phase) : _) <- inline_prags = (meth_id `setInlinePragma` phase, - if inl then unitNameSet (idName meth_id) else emptyNameSet) + if is_inline then unitNameSet (idName meth_id) else emptyNameSet) | otherwise = (meth_id, emptyNameSet) - is_inline (InlineSig _ name _ _) = name == idName sel_id - is_inline other = False - meth_tvs' = take (length meth_tvs) all_tyvars' poly_meth_bind = AbsBinds meth_tvs' (map instToId meth_dicts) [(meth_tvs', final_meth_id, local_meth_id)] inlines (lie_binds `andMonoBinds` meth_bind) + in - returnM poly_meth_bind + -- Deal with specialisation pragmas + -- The sel_name is what appears in the pragma + tcExtendLocalValEnv2 [(sel_name, final_meth_id)] ( + getLIE (tcSpecSigs spec_prags) `thenM` \ (spec_binds1, prag_lie) -> + + -- The prag_lie for a SPECIALISE pragma will mention the function itself, + -- so we have to simplify them away right now lest they float outwards! + bindInstsOfLocalFuns prag_lie [final_meth_id] `thenM` \ spec_binds2 -> + returnM (spec_binds1 `andMonoBinds` spec_binds2) + ) `thenM` \ spec_binds -> + + returnM (poly_meth_bind `andMonoBinds` spec_binds) mkMethodBind :: InstOrigin @@ -539,7 +546,6 @@ mkMethId :: InstOrigin -> Class -> TcM (Maybe Inst, Id) -- mkMethId instantiates the selector Id at the specified types --- THe mkMethId origin clas sel_id inst_tys = let (tyvars,rho) = tcSplitForAllTys (idType sel_id)