X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=3fec58dd0a402b6d98daa0bc0e4f6b5518ca10e8;hb=1cdafe99abae1628f34ca8c064e3a8c0fcdbd079;hp=c3772615a301a86b3ad9eb970d5f4446cb9f41d9;hpb=aca101dd54968a1da6decc86716f5d0fdb2fd989;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index c377261..3fec58d 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -9,19 +9,21 @@ 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 ) @@ -34,13 +36,12 @@ 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 @@ -358,27 +366,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 +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 @@ -420,12 +410,12 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = 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 +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