X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=d0d44cfe907b7dde41bd2f727be7c43c672eaad0;hb=a7568f61b7b3dd1af469b16eca81d068bf0f1eb8;hp=1e99572c5e8b809c5cf3a70a23c463d3b3fc4443;hpb=7bb069508f094825ca136ed97606651f3e093123;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 1e99572..d0d44cf 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -8,7 +8,7 @@ module Inst ( LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, - Inst, OverloadedLit(..), + Inst, pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts, newDictFromOld, newDicts, newClassDicts, newDictsAtLoc, @@ -37,58 +37,48 @@ 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, InstEnv, tcGetInstEnv, lookupInstEnv, InstLookupResult(..), - tcLookupValueByKey, tcLookupTyConByKey - ) +import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupGlobalId ) +import InstEnv ( InstLookupResult(..), lookupInstEnv ) import TcType ( TcThetaType, TcType, TcTauType, TcTyVarSet, zonkTcTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType ) -import Bag +import CoreFVs ( idFreeTyVars ) import Class ( Class, FunDep ) import FunDeps ( instantiateFdClassTys ) -import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal ) +import Id ( Id, 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 SrcLoc ( SrcLoc ) -import Type ( Type, PredType(..), ThetaType, - mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy, - splitForAllTys, splitSigmaTy, - splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, - mkSynTy, tidyOpenType, tidyOpenTypes +import Type ( Type, PredType(..), + isTyVarTy, mkDictTy, mkPredTy, + splitForAllTys, splitSigmaTy, funArgTy, + splitMethodTy, splitRhoTy, classesOfPreds, + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, + tidyOpenType, tidyOpenTypes ) -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 Bag import Outputable \end{code} @@ -111,7 +101,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 @@ -171,8 +161,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 @@ -180,10 +170,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 @@ -208,17 +194,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} @@ -333,7 +316,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) -> @@ -341,7 +324,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) @@ -349,7 +332,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 @@ -358,7 +341,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) @@ -367,15 +350,15 @@ 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 (tyvars, rho) = splitForAllTys (idType id) rho_ty = substTy (mkTyVarSubst tyvars tys) rho - (theta, tau) = splitRhoTy rho_ty + (pred, tau) = splitMethodTy rho_ty in - newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst -> + newMethodWithGivenTy orig id tys [pred] tau `thenNF_Tc` \ meth_inst -> returnNF_Tc (unitLIE meth_inst, instToId meth_inst) instOverloadedFun orig v arg_tys theta tau @@ -408,7 +391,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 @@ -430,10 +413,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) @@ -441,9 +424,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 -> @@ -456,12 +438,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} @@ -502,7 +487,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) @@ -510,7 +495,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) @@ -534,7 +519,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 @@ -563,19 +547,15 @@ 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 pprInst m@(Method u id tys theta tau loc) = hsep [ppr id, ptext SLIT("at"), brackets (interppSP tys) {- , - ppr theta, ppr tau, + ptext SLIT("theta"), ppr theta, + ptext SLIT("tau"), ppr tau show_uniq u, ppr (instToId m) -}] @@ -632,7 +612,7 @@ data LookupInstResult s | GenInst [Inst] TcExpr -- The expression and its needed insts lookupInst :: Inst - -> NF_TcM s (LookupInstResult s) + -> NF_TcM (LookupInstResult s) -- Dictionaries @@ -642,11 +622,11 @@ lookupInst dict@(Dict _ (Class clas tys) loc) 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 @@ -672,7 +652,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 @@ -680,45 +660,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 @@ -735,7 +715,7 @@ ambiguous dictionaries. \begin{code} lookupSimpleInst :: Class -> [Type] -- Look up (c,t) - -> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s + -> NF_TcM (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s lookupSimpleInst clas tys = tcGetInstEnv `thenNF_Tc` \ inst_env -> @@ -744,7 +724,7 @@ lookupSimpleInst clas tys -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta')) where (_, theta, _) = splitSigmaTy (idType dfun) - theta' = map (\(Class clas tys) -> (clas,tys)) theta + theta' = classesOfPreds theta other -> returnNF_Tc Nothing \end{code}