X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=45338d0a1eced7142a06bad9fe3735ddb7d1f1e2;hb=59c9c122f942f348008d4ed8ba088286343d63d3;hp=c3772615a301a86b3ad9eb970d5f4446cb9f41d9;hpb=aca101dd54968a1da6decc86716f5d0fdb2fd989;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index c377261..45338d0 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -9,19 +9,18 @@ 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, - checkAmbiguity, SourceTyCtxt(..) ) -import TcType ( mkClassPred, tyVarsOfType, - tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys, - SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred ) -import Inst ( tcInstClassOp, newDicts, instToId, showLIE, tcExtendLocalInstEnv ) +import TcMType ( tcSkolSigType, checkValidInstance, checkValidInstHead ) +import TcType ( mkClassPred, tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys, + SkolemInfo(InstSkol), tcSplitDFunTy ) +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 ) @@ -31,16 +30,14 @@ 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 MkId ( mkDictFunId ) 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 +130,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 +145,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 +166,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,33 +176,31 @@ 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) $ setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ + do { is_boot <- tcIsHsBoot + ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags)) + badBootDeclErr + -- Typecheck the instance type itself. We can't use -- tcHsSigType, because it's not a valid user type. - kcHsSigType poly_ty `thenM` \ kinded_ty -> - tcHsKindedType kinded_ty `thenM` \ poly_ty' -> - let - (tyvars, theta, tau) = tcSplitSigmaTy poly_ty' - in - checkValidTheta InstThetaCtxt theta `thenM_` - checkAmbiguity tyvars theta (tyVarsOfType tau) `thenM_` - checkValidInstHead tau `thenM` \ (clas,inst_tys) -> - 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 })) - where - msg = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class")) + ; kinded_ty <- kcHsSigType poly_ty + ; poly_ty' <- tcHsKindedType kinded_ty + ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty' + + ; (clas, inst_tys) <- checkValidInstHead tau + ; checkValidInstance tyvars theta clas inst_tys + + ; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc) + ; overlap_flag <- getOverlapFlag + ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys + ispec = mkLocalInstance dfun overlap_flag + + ; return (Just (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags })) } \end{code} @@ -217,7 +212,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 +228,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 +304,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 @@ -358,27 +355,21 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) -- 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 @@ -391,18 +382,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,21 +390,18 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) -- member) are dealt with by the common MkId.mkDataConWrapId code rather -- than needing to be repeated here. - where - msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas) - dict_bind = noLoc (VarBind this_dict_id dict_rhs) 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 ) + returnM (unitBag main_bind) tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' @@ -473,8 +449,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