X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=8d6c8698a919c6c4bd3e7dca5ef01bb62e06f68a;hb=f74e9e28c66072f93150fe026f87549e2f255128;hp=7ccc480eb199ebad4a124ee432a6088a4c01c14a;hpb=e7f04a0da2a711266b58274a1a935d93bb034620;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 7ccc480..8d6c869 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -8,11 +8,9 @@ module Inst ( LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, - Inst, OverloadedLit(..), + Inst, pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts, - InstanceMapper, - newDictFromOld, newDicts, newClassDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit, newIPDict, instOverloadedFun, @@ -39,56 +37,44 @@ module Inst ( #include "HsVersions.h" -import HsSyn ( HsLit(..), HsExpr(..) ) -import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat ) +import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) ) +import RnHsSyn ( RenamedHsOverLit ) import TcHsSyn ( TcExpr, TcId, mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId ) import TcMonad -import TcEnv ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey ) +import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupGlobalId ) +import InstEnv ( InstLookupResult(..), lookupInstEnv ) import TcType ( TcThetaType, TcType, TcTauType, TcTyVarSet, zonkTcTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType ) import Bag -import Class ( classInstEnv, Class, FunDep ) +import Class ( Class, FunDep ) import FunDeps ( instantiateFdClassTys ) import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) -import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc, - getOccName, nameUnique ) +import Name ( mkDictOcc, mkMethodOcc, mkIPOcc, getOccName, nameUnique ) import PprType ( pprPred ) -import InstEnv ( InstEnv, lookupInstEnv ) -import SrcLoc ( SrcLoc ) -import Type ( Type, PredType(..), ThetaType, - mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy, - splitForAllTys, splitSigmaTy, +import Type ( Type, PredType(..), + isTyVarTy, mkDictTy, mkPredTy, + splitForAllTys, splitSigmaTy, funArgTy, splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, - mkSynTy, tidyOpenType, tidyOpenTypes + tidyOpenType, tidyOpenTypes ) -import InstEnv ( InstEnv ) -import Subst ( emptyInScopeSet, mkSubst, +import Subst ( emptyInScopeSet, mkSubst, mkInScopeSet, substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst ) -import TyCon ( TyCon ) import Literal ( inIntRange ) -import Var ( TyVar ) -import VarEnv ( lookupVarEnv, TidyEnv, - lookupSubstEnv, SubstResult(..) - ) +import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet ) -import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy ) -import TysWiredIn ( intDataCon, isIntTy, +import TysWiredIn ( isIntTy, floatDataCon, isFloatTy, doubleDataCon, isDoubleTy, - integerTy, isIntegerTy, - voidTy + isIntegerTy, voidTy ) -import Unique ( fromRationalClassOpKey, rationalTyConKey, - fromIntClassOpKey, fromIntegerClassOpKey, Unique - ) -import Maybes ( expectJust ) +import PrelNames( Unique, hasKey, fromIntName, fromIntegerClassOpKey ) import Maybe ( catMaybes ) import Util ( thenCmp, zipWithEqual, mapAccumL ) import Outputable @@ -113,7 +99,7 @@ plusLIEs lies = unionManyBags lies lieToList = bagToList listToLIE = listToBag -zonkLIE :: LIE -> NF_TcM s LIE +zonkLIE :: LIE -> NF_TcM LIE zonkLIE lie = mapBagNF_Tc zonkInst lie pprInsts :: [Inst] -> SDoc @@ -173,8 +159,8 @@ data Inst | LitInst Unique - OverloadedLit - TcType -- The type at which the literal is used + RenamedHsOverLit -- The literal from the occurrence site + TcType -- The type at which the literal is used InstLoc | FunDep @@ -182,10 +168,6 @@ data Inst Class -- the class from which this arises [FunDep TcType] InstLoc - -data OverloadedLit - = OverloadedIntegral Integer -- The number - | OverloadedFractional Rational -- The number \end{code} Ordering @@ -210,17 +192,14 @@ cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2) cmpInst (Method _ _ _ _ _ _) other = LT -cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2) +cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `compare` ty2) cmpInst (LitInst _ _ _ _) (FunDep _ _ _ _) = LT cmpInst (LitInst _ _ _ _) other = GT cmpInst (FunDep _ clas1 fds1 _) (FunDep _ clas2 fds2 _) = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2) cmpInst (FunDep _ _ _ _) other = GT -cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2 -cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2 -cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT -cmpOverLit (OverloadedFractional _) (OverloadedIntegral _) = GT +-- and they can only have HsInt or HsFracs in them. \end{code} @@ -285,6 +264,7 @@ Predicates isDict :: Inst -> Bool isDict (Dict _ _ _) = True isDict other = False + isClassDict :: Inst -> Bool isClassDict (Dict _ (Class _ _) _) = True isClassDict other = False @@ -294,10 +274,8 @@ isMethod (Method _ _ _ _ _ _) = True isMethod other = False isMethodFor :: TcIdSet -> Inst -> Bool -isMethodFor ids (Method uniq id tys _ _ loc) - = id `elemVarSet` ids -isMethodFor ids inst - = False +isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids +isMethodFor ids inst = False isTyVarDict :: Inst -> Bool isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys @@ -336,7 +314,7 @@ Construction \begin{code} newDicts :: InstOrigin -> TcThetaType - -> NF_TcM s (LIE, [TcId]) + -> NF_TcM (LIE, [TcId]) newDicts orig theta = tcGetInstLoc orig `thenNF_Tc` \ loc -> newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, ids) -> @@ -344,7 +322,7 @@ newDicts orig theta newClassDicts :: InstOrigin -> [(Class,[TcType])] - -> NF_TcM s (LIE, [TcId]) + -> NF_TcM (LIE, [TcId]) newClassDicts orig theta = newDicts orig (map (uncurry Class) theta) @@ -352,7 +330,7 @@ newClassDicts orig theta -- but with slightly different interface newDictsAtLoc :: InstLoc -> TcThetaType - -> NF_TcM s ([Inst], [TcId]) + -> NF_TcM ([Inst], [TcId]) newDictsAtLoc loc theta = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> let @@ -361,7 +339,7 @@ newDictsAtLoc loc theta = in returnNF_Tc (dicts, map instToId dicts) -newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst +newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM Inst newDictFromOld (Dict _ _ loc) clas tys = tcGetUnique `thenNF_Tc` \ uniq -> returnNF_Tc (Dict uniq (Class clas tys) loc) @@ -370,7 +348,7 @@ newDictFromOld (Dict _ _ loc) clas tys newMethod :: InstOrigin -> TcId -> [TcType] - -> NF_TcM s (LIE, TcId) + -> NF_TcM (LIE, TcId) newMethod orig id tys = -- Get the Id type and instantiate it at the specified types let @@ -398,7 +376,7 @@ instFunDeps orig theta instFunDepsOfTheta theta = let ifd (Class clas tys) = instantiateFdClassTys clas tys - ifd _ = [] + ifd (IParam n ty) = [([], [ty])] in concat (map ifd theta) newMethodWithGivenTy orig id tys theta tau @@ -411,7 +389,7 @@ newMethodWith id tys theta tau loc newMethodAtLoc :: InstLoc -> Id -> [TcType] - -> NF_TcM s (Inst, TcId) + -> NF_TcM (Inst, TcId) newMethodAtLoc loc real_id tys -- Local function, similar to newMethod but with -- slightly different interface = -- Get the Id type and instantiate it at the specified types @@ -433,10 +411,10 @@ cases (the rest are caught in lookupInst). \begin{code} newOverloadedLit :: InstOrigin - -> OverloadedLit + -> RenamedHsOverLit -> TcType - -> NF_TcM s (TcExpr, LIE) -newOverloadedLit orig (OverloadedIntegral i) ty + -> NF_TcM (TcExpr, LIE) +newOverloadedLit orig (HsIntegral i _) ty | isIntTy ty && inIntRange i -- Short cut for Int = returnNF_Tc (int_lit, emptyLIE) @@ -444,9 +422,8 @@ newOverloadedLit orig (OverloadedIntegral i) ty = returnNF_Tc (integer_lit, emptyLIE) where - intprim_lit = HsLitOut (HsIntPrim i) intPrimTy - integer_lit = HsLitOut (HsInt i) integerTy - int_lit = mkHsConApp intDataCon [] [intprim_lit] + int_lit = HsLit (HsInt i) + integer_lit = HsLit (HsInteger i) newOverloadedLit orig lit ty -- The general case = tcGetInstLoc orig `thenNF_Tc` \ loc -> @@ -459,12 +436,15 @@ newOverloadedLit orig lit ty -- The general case \begin{code} newFunDepFromDict dict + | isClassDict dict = tcGetUnique `thenNF_Tc` \ uniq -> let (clas, tys) = getDictClassTys dict fds = instantiateFdClassTys clas tys inst = FunDep uniq clas fds (instLoc dict) in if null fds then returnNF_Tc Nothing else returnNF_Tc (Just inst) + | otherwise + = returnNF_Tc Nothing \end{code} \begin{code} @@ -505,7 +485,7 @@ but doesn't do the same for the Id in a Method. There's no need, and it's a lot of extra work. \begin{code} -zonkPred :: TcPredType -> NF_TcM s TcPredType +zonkPred :: TcPredType -> NF_TcM TcPredType zonkPred (Class clas tys) = zonkTcTypes tys `thenNF_Tc` \ new_tys -> returnNF_Tc (Class clas new_tys) @@ -513,7 +493,7 @@ zonkPred (IParam n ty) = zonkTcType ty `thenNF_Tc` \ new_ty -> returnNF_Tc (IParam n new_ty) -zonkInst :: Inst -> NF_TcM s Inst +zonkInst :: Inst -> NF_TcM Inst zonkInst (Dict u pred loc) = zonkPred pred `thenNF_Tc` \ new_pred -> returnNF_Tc (Dict u new_pred loc) @@ -537,7 +517,6 @@ zonkInst (FunDep u clas fds loc) = zonkFunDeps fds `thenNF_Tc` \ fds' -> returnNF_Tc (FunDep u clas fds' loc) -zonkPreds preds = mapNF_Tc zonkPred preds zonkInsts insts = mapNF_Tc zonkInst insts zonkFunDeps fds = mapNF_Tc zonkFd fds @@ -566,12 +545,7 @@ instance Outputable Inst where ppr inst = pprInst inst pprInst (LitInst u lit ty loc) - = hsep [case lit of - OverloadedIntegral i -> integer i - OverloadedFractional f -> rational f, - ptext SLIT("at"), - ppr ty, - show_uniq u] + = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u] pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u @@ -629,45 +603,27 @@ show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}") %************************************************************************ \begin{code} -type InstanceMapper = Class -> InstEnv -\end{code} - -A @ClassInstEnv@ lives inside a class, and identifies all the instances -of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for -that instance. - -There is an important consistency constraint between the @MatchEnv@s -in and the dfun @Id@s inside them: the free type variables of the -@Type@ key in the @MatchEnv@ must be a subset of the universally-quantified -type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might -contain the following entry: -@ - [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] -@ -The "a" in the pattern must be one of the forall'd variables in -the dfun type. - -\begin{code} data LookupInstResult s = NoInstance | SimpleInst TcExpr -- Just a variable, type application, or literal | GenInst [Inst] TcExpr -- The expression and its needed insts lookupInst :: Inst - -> NF_TcM s (LookupInstResult s) + -> NF_TcM (LookupInstResult s) -- Dictionaries lookupInst dict@(Dict _ (Class clas tys) loc) - = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of + = tcGetInstEnv `thenNF_Tc` \ inst_env -> + case lookupInstEnv inst_env clas tys of - Just (tenv, dfun_id) + FoundInst tenv dfun_id -> let - subst = mkSubst (tyVarsOfTypes tys) tenv + subst = mkSubst (mkInScopeSet (tyVarsOfTypes tys)) tenv (tyvars, rho) = splitForAllTys (idType dfun_id) ty_args = map subst_tv tyvars dfun_rho = substTy subst rho - (theta, tau) = splitRhoTy dfun_rho + (theta, _) = splitRhoTy dfun_rho ty_app = mkHsTyApp (HsVar dfun_id) ty_args subst_tv tv = case lookupSubstEnv tenv tv of Just (DoneTy ty) -> ty @@ -682,7 +638,7 @@ lookupInst dict@(Dict _ (Class clas tys) loc) in returnNF_Tc (GenInst dicts rhs) - Nothing -> returnNF_Tc NoInstance + other -> returnNF_Tc NoInstance lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance -- Methods @@ -693,7 +649,7 @@ lookupInst inst@(Method _ id tys theta _ loc) -- Literals -lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc) +lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) | isIntTy ty && in_int_range -- Short cut for Int = returnNF_Tc (GenInst [] int_lit) -- GenInst, not SimpleInst, because int_lit is actually a constructor application @@ -701,45 +657,45 @@ lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc) | isIntegerTy ty -- Short cut for Integer = returnNF_Tc (GenInst [] integer_lit) - | in_int_range -- It's overloaded but small enough to fit into an Int - = tcLookupValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int -> + | in_int_range -- It's overloaded but small enough to fit into an Int + && from_integer_name `hasKey` fromIntegerClassOpKey -- And it's the built-in prelude fromInteger + -- (i.e. no funny business with user-defined + -- packages of numeric classes) + = -- So we can use the Prelude fromInt + tcLookupGlobalId fromIntName `thenNF_Tc` \ from_int -> newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) -> returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit)) | otherwise -- Alas, it is overloaded and a big literal! - = tcLookupValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer -> + = tcLookupGlobalId from_integer_name `thenNF_Tc` \ from_integer -> newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) -> returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit)) where in_int_range = inIntRange i - intprim_lit = HsLitOut (HsIntPrim i) intPrimTy - integer_lit = HsLitOut (HsInt i) integerTy - int_lit = mkHsConApp intDataCon [] [intprim_lit] + integer_lit = HsLit (HsInteger i) + int_lit = HsLit (HsInt i) -- similar idea for overloaded floating point literals: if the literal is -- *definitely* a float or a double, generate the real thing here. -- This is essential (see nofib/spectral/nucleic). -lookupInst inst@(LitInst u (OverloadedFractional f) ty loc) +lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) | isFloatTy ty = returnNF_Tc (GenInst [] float_lit) | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit) | otherwise - = tcLookupValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational -> - - -- The type Rational isn't wired in so we have to conjure it up - tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon -> + = tcLookupGlobalId from_rat_name `thenNF_Tc` \ from_rational -> + newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> let - rational_ty = mkSynTy rational_tycon [] - rational_lit = HsLitOut (HsFrac f) rational_ty + rational_ty = funArgTy (idType method_id) + rational_lit = HsLit (HsRat f rational_ty) in - newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit)) where - floatprim_lit = HsLitOut (HsFloatPrim f) floatPrimTy + floatprim_lit = HsLit (HsFloatPrim f) float_lit = mkHsConApp floatDataCon [] [floatprim_lit] - doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy + doubleprim_lit = HsLit (HsDoublePrim f) double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit] -- there are no `instances' of functional dependencies or implicit params @@ -754,18 +710,20 @@ appropriate dictionary if it exists. It is used only when resolving ambiguous dictionaries. \begin{code} -lookupSimpleInst :: InstEnv - -> Class +lookupSimpleInst :: Class -> [Type] -- Look up (c,t) - -> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s - -lookupSimpleInst class_inst_env clas tys - = case lookupInstEnv (ppr clas) class_inst_env tys of - Nothing -> returnNF_Tc Nothing + -> NF_TcM (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s - Just (tenv, dfun) +lookupSimpleInst clas tys + = tcGetInstEnv `thenNF_Tc` \ inst_env -> + case lookupInstEnv inst_env clas tys of + FoundInst tenv dfun -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta')) where (_, theta, _) = splitSigmaTy (idType dfun) theta' = map (\(Class clas tys) -> (clas,tys)) theta + + other -> returnNF_Tc Nothing \end{code} + +