X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=3fec58dd0a402b6d98daa0bc0e4f6b5518ca10e8;hb=1cdafe99abae1628f34ca8c064e3a8c0fcdbd079;hp=929797a651729789a1ce982f6e4562a2986dea2d;hpb=0ee11df0098509d06cf6fc03d1a18429985b6081;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 929797a..3fec58d 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -9,38 +9,39 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where #include "HsVersions.h" import HsSyn -import TcBinds ( tcSpecSigs ) +import TcBinds ( mkPragFun, tcPrags, badBootDeclErr ) import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr, tcClassDecl2, getGenericInstances ) import TcRnMonad -import TcMType ( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeErr, +import TcMType ( tcSkolSigType, checkValidTheta, checkValidInstHead, + checkInstTermination, instTypeErr, checkAmbiguity, SourceTyCtxt(..) ) import TcType ( mkClassPred, tyVarsOfType, tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys, SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred ) -import Inst ( tcInstClassOp, newDicts, instToId, showLIE, tcExtendLocalInstEnv ) +import Inst ( tcInstClassOp, newDicts, instToId, showLIE, + getOverlapFlag, tcExtendLocalInstEnv ) +import InstEnv ( mkLocalInstance, instanceDFunId ) import TcDeriv ( tcDeriving ) -import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv, - InstInfo(..), InstBindings(..), +import TcEnv ( InstInfo(..), InstBindings(..), newDFunName, tcExtendIdEnv ) import TcHsType ( kcHsSigType, tcHsKindedType ) import TcUnify ( checkSigTyVars ) -import TcSimplify ( tcSimplifyCheck, tcSimplifyTop ) -import Type ( zipTvSubst, substTheta, substTys ) +import TcSimplify ( tcSimplifyCheck, tcSimplifySuperClasses ) +import Type ( zipOpenTvSubst, substTheta, substTys ) import DataCon ( classDataCon ) import Class ( classBigSig ) import Var ( Id, idName, idType ) import MkId ( mkDictFunId, rUNTIME_ERROR_ID ) import FunDeps ( checkInstFDs ) import Name ( Name, getSrcLoc ) -import NameSet ( unitNameSet, emptyNameSet ) -import UnicodeUtil ( stringToUtf8 ) import Maybe ( catMaybes ) import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart ) import ListSetOps ( minusList ) import Outputable import Bag +import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) ) import FastString \end{code} @@ -133,7 +134,7 @@ tcInstDecls1 -- Deal with both source-code and imported instance decls -> TcM (TcGblEnv, -- The full inst env [InstInfo], -- Source-code instance decls to process; -- contains all dfuns for this module - [HsBindGroup Name]) -- Supporting bindings for derived instances + HsValBinds Name) -- Supporting bindings for derived instances tcInstDecls1 tycl_decls inst_decls = checkNoErrs $ @@ -148,7 +149,7 @@ tcInstDecls1 tycl_decls inst_decls clas_decls = filter (isClassDecl.unLoc) tycl_decls in -- (2) Instances from generic class declarations - getGenericInstances clas_decls `thenM` \ generic_inst_info -> + getGenericInstances clas_decls `thenM` \ generic_inst_info -> -- Next, construct the instance environment so far, consisting of -- a) local instance decls @@ -169,7 +170,7 @@ tcInstDecls1 tycl_decls inst_decls addInsts :: [InstInfo] -> TcM a -> TcM a addInsts infos thing_inside - = tcExtendLocalInstEnv (map iDFunId infos) thing_inside + = tcExtendLocalInstEnv (map iSpec infos) thing_inside \end{code} \begin{code} @@ -179,10 +180,6 @@ tcLocalInstDecl1 :: LInstDecl Name -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context - -- but only do this for non-imported instance decls. - -- Imported ones should have been checked already, and may indeed - -- contain something illegal in normal Haskell, notably - -- instance CCallable [Char] tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags)) = -- Prime error recovery, set source location recoverM (returnM Nothing) $ @@ -199,11 +196,20 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags)) checkValidTheta InstThetaCtxt theta `thenM_` checkAmbiguity tyvars theta (tyVarsOfType tau) `thenM_` checkValidInstHead tau `thenM` \ (clas,inst_tys) -> + checkInstTermination theta inst_tys `thenM_` checkTc (checkInstFDs theta clas inst_tys) (instTypeErr (pprClassPred clas inst_tys) msg) `thenM_` newDFunName clas inst_tys (srcSpanStart loc) `thenM` \ dfun_name -> - returnM (Just (InstInfo { iDFunId = mkDictFunId dfun_name tyvars theta clas inst_tys, - iBinds = VanillaInst binds uprags })) + getOverlapFlag `thenM` \ overlap_flag -> + let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys + ispec = mkLocalInstance dfun overlap_flag + in + + tcIsHsBoot `thenM` \ is_boot -> + checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags)) + badBootDeclErr `thenM_` + + returnM (Just (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags })) where msg = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class")) \end{code} @@ -217,7 +223,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags)) \begin{code} tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo] - -> TcM (TcLclEnv, LHsBinds Id) + -> TcM (LHsBinds Id, TcLclEnv) -- (a) From each class declaration, -- generate any default-method bindings -- (b) From each instance decl @@ -233,9 +239,10 @@ tcInstDecls2 tycl_decls inst_decls ; inst_binds_s <- mappM tcInstDecl2 inst_decls -- Done - ; tcl_env <- getLclEnv - ; returnM (tcl_env, unionManyBags dm_binds_s `unionBags` - unionManyBags inst_binds_s) } + ; let binds = unionManyBags dm_binds_s `unionBags` + unionManyBags inst_binds_s + ; tcl_env <- getLclEnv -- Default method Ids in here + ; returnM (binds, tcl_env) } \end{code} ======= New documentation starts here (Sept 92) ============== @@ -308,17 +315,18 @@ First comes the easy case of a non-local instance decl. \begin{code} tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) -tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) - = -- Prime error recovery +tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds }) + = let + dfun_id = instanceDFunId ispec + rigid_info = InstSkol dfun_id + inst_ty = idType dfun_id + in + -- Prime error recovery recoverM (returnM emptyLHsBinds) $ setSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ -- Instantiate the instance decl with skolem constants - let - rigid_info = InstSkol dfun_id - inst_ty = idType dfun_id - in tcSkolSigType rigid_info inst_ty `thenM` \ (inst_tyvars', dfun_theta', inst_head') -> -- These inst_tyvars' scope over the 'where' part -- Those tyvars are inside the dfun_id's type, which is a bit @@ -328,7 +336,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) (class_tyvars, sc_theta, _, op_items) = classBigSig clas -- Instantiate the super-class context with inst_tys - sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys') sc_theta + sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta origin = SigOrigin rigid_info in -- Create dictionary Ids from the specified instance contexts. @@ -338,7 +346,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) -- Default-method Ids may be mentioned in synthesised RHSs, -- but they'll already be in the environment. - ------------------ -- Typecheck the methods let -- These insts are in scope; quite a few, eh? avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts @@ -348,33 +355,32 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) op_items binds `thenM` \ (meth_ids, meth_binds) -> -- Figure out bindings for the superclass context - tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts - `thenM` \ (sc_binds_inner, sc_binds_outer) -> - - -- It's possible that the superclass stuff might have done unification + -- Don't include this_dict in the 'givens', else + -- sc_dicts get bound by just selecting from this_dict!! + addErrCtxt superClassCtxt + (tcSimplifySuperClasses inst_tyvars' + dfun_arg_dicts + sc_dicts) `thenM` \ sc_binds -> + + -- It's possible that the superclass stuff might unified one + -- of the inst_tyavars' with something in the envt checkSigTyVars inst_tyvars' `thenM_` - -- Deal with 'SPECIALISE instance' pragmas by making them - -- look like SPECIALISE pragmas for the dfun + -- Deal with 'SPECIALISE instance' pragmas let - uprags = case binds of - VanillaInst _ uprags -> uprags - other -> [] - spec_prags = [ L loc (SpecSig (L loc (idName dfun_id)) ty) - | L loc (SpecInstSig ty) <- uprags ] + specs = case binds of + VanillaInst _ prags -> filter isSpecInstLSig prags + other -> [] in - tcExtendGlobalValEnv [dfun_id] ( - tcExtendTyVarEnv inst_tyvars' $ - tcSpecSigs spec_prags - ) `thenM` \ prag_binds -> - + tcPrags dfun_id specs `thenM` \ prags -> + -- Create the result bindings let dict_constr = classDataCon clas 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) + inline_prag | null dfun_arg_dicts = [] + | otherwise = [InlinePrag (Inline AlwaysActive True)] -- 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 @@ -387,18 +393,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) -- See Note [Inline dfuns] below dict_rhs - | null scs_and_meths - = -- Blatant special case for CCallable, CReturnable - -- If the dictionary is empty then we should never - -- select anything from it, so we make its RHS just - -- emit an error message. This in turn means that we don't - -- mention the constructor, which doesn't exist for CCallable, CReturnable - -- Hardly beautiful, but only three extra lines. - nlHsApp (noLoc $ TyApp (nlHsVar rUNTIME_ERROR_ID) - [idType this_dict_id]) - (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 msg)))) - - | otherwise -- The common case = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths) -- We don't produce a binding for the dict_constr; instead we -- rely on the simplifier to unfold this saturated application @@ -411,18 +405,17 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas) dict_bind = noLoc (VarBind this_dict_id dict_rhs) - all_binds = dict_bind `consBag` (sc_binds_inner `unionBags` meth_binds) + all_binds = dict_bind `consBag` (sc_binds `unionBags` meth_binds) main_bind = noLoc $ AbsBinds inst_tyvars' (map instToId dfun_arg_dicts) - [(inst_tyvars', dfun_id, this_dict_id)] - inlines all_binds + [(inst_tyvars', dfun_id, this_dict_id, + inline_prag ++ prags)] + all_binds in showLIE (text "instance") `thenM_` - returnM (unitBag main_bind `unionBags` - prag_binds `unionBags` - sc_binds_outer) + returnM (unitBag main_bind) tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' @@ -470,8 +463,9 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' -- 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 + prag_fn = mkPragFun uprags all_insts = avail_insts ++ catMaybes meth_insts - tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts uprags + tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts prag_fn meth_ids = [meth_id | (_,meth_id,_) <- meth_infos] in @@ -512,66 +506,7 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' -- of the type variables in the instance declaration; but rep_tys doesn't -- have the skolemised version, so we substitute them in here rep_tys' = substTys subst rep_tys - subst = zipTvSubst inst_tyvars' (mkTyVarTys inst_tyvars') -\end{code} - -Note: [Superclass loops] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We have to be very, very careful when generating superclasses, lest we -accidentally build a loop. Here's an example: - - class S a - - class S a => C a where { opc :: a -> a } - class S b => D b where { opd :: b -> b } - - instance C Int where - opc = opd - - instance D Int where - opd = opc - -From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int} -Simplifying, we may well get: - $dfCInt = :C ds1 (opd dd) - dd = $dfDInt - ds1 = $p1 dd -Notice that we spot that we can extract ds1 from dd. - -Alas! Alack! We can do the same for (instance D Int): - - $dfDInt = :D ds2 (opc dc) - dc = $dfCInt - ds2 = $p1 dc - -And now we've defined the superclass in terms of itself. - - -Solution: treat the superclass context separately, and simplify it -all the way down to nothing on its own. Don't toss any 'free' parts -out to be simplified together with other bits of context. -Hence the tcSimplifyTop below. - -At a more basic level, don't include this_dict in the context wrt -which we simplify sc_dicts, else sc_dicts get bound by just selecting -from this_dict!! - -\begin{code} -tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts - = addErrCtxt superClassCtxt $ - getLIE (tcSimplifyCheck doc inst_tyvars' - dfun_arg_dicts - sc_dicts) `thenM` \ (sc_binds1, sc_lie) -> - - -- We must simplify this all the way down - -- lest we build superclass loops - -- See Note [Superclass loops] above - tcSimplifyTop sc_lie `thenM` \ sc_binds2 -> - - returnM (sc_binds1, sc_binds2) - - where - doc = ptext SLIT("instance declaration superclass context") + subst = zipOpenTvSubst inst_tyvars' (mkTyVarTys inst_tyvars') \end{code}