X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=cc91be8239ac9322d83bf40f7034fa736e5b1e19;hb=5d541fe7c43a1dc4c1b2dd9ee49e64238b0754ca;hp=8768e202505aacb50fb35ec6a0f8ff06cffdbadb;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 8768e20..cc91be8 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -12,7 +12,7 @@ module Inst ( tidyInsts, tidyMoreInsts, - newDicts, newDictAtLoc, newDictsAtLoc, cloneDict, + newDicts, newDictsAtLoc, cloneDict, shortCutFracLit, shortCutIntLit, newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy, tcInstClassOp, tcInstStupidTheta, @@ -22,6 +22,7 @@ module Inst ( ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, instLoc, getDictClassTys, dictPred, + mkInstCoFn, lookupInst, LookupInstResult(..), lookupPred, tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag, @@ -30,7 +31,7 @@ module Inst ( isTyVarDict, isMethodFor, zonkInst, zonkInsts, - instToId, instName, + instToId, instToVar, instName, InstOrigin(..), InstLoc(..), pprInstLoc ) where @@ -40,8 +41,8 @@ module Inst ( import {-# SOURCE #-} TcExpr( tcPolyExpr ) import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp, - nlHsLit, nlHsVar ) -import TcHsSyn ( mkHsTyApp, mkHsDictApp, zonkId ) + ExprCoFn(..), (<.>), nlHsLit, nlHsVar ) +import TcHsSyn ( zonkId ) import TcRnMonad import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy ) import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..), @@ -68,17 +69,19 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType, import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst, notElemTvSubst, extendTvSubstList ) import Unify ( tcMatchTys ) -import Kind ( isSubKind ) -import Packages ( isHomeModule ) -import HscTypes ( ExternalPackageState(..) ) +import Module ( modulePackageId ) +import {- Kind parts of -} Type ( isSubKind ) +import Coercion ( isEqPred ) +import HscTypes ( ExternalPackageState(..), HscEnv(..) ) import CoreFVs ( idFreeTyVars ) -import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId ) -import Id ( Id, idName, idType, mkUserLocal, mkLocalId ) +import DataCon ( DataCon, dataConStupidTheta, dataConName, + dataConWrapId, dataConUnivTyVars ) +import Id ( Id, idName, idType, mkUserLocal, mkLocalId, isId ) import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule, isInternalName, setNameUnique ) import NameSet ( addOneToNameSet ) import Literal ( inIntRange ) -import Var ( TyVar, tyVarKind, setIdType ) +import Var ( Var, TyVar, tyVarKind, setIdType, mkTyVar ) import VarEnv ( TidyEnv, emptyTidyEnv ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet ) import TysWiredIn ( floatDataCon, doubleDataCon ) @@ -86,7 +89,7 @@ import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rational import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) ) -import DynFlags ( DynFlag(..), dopt ) +import DynFlags ( DynFlag(..), DynFlags(..), dopt ) import Maybes ( isJust ) import Outputable \end{code} @@ -95,13 +98,23 @@ import Outputable Selection ~~~~~~~~~ \begin{code} +mkInstCoFn :: [TcType] -> [Inst] -> ExprCoFn +mkInstCoFn tys dicts = CoApps (map instToId dicts) <.> CoTyApps tys + instName :: Inst -> Name instName inst = idName (instToId inst) instToId :: Inst -> TcId -instToId (LitInst nm _ ty _) = mkLocalId nm ty -instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred) -instToId (Method id _ _ _ _) = id +instToId inst = ASSERT2( isId id, ppr inst ) id + where + id = instToVar inst + +instToVar :: Inst -> Var +instToVar (LitInst nm _ ty _) = mkLocalId nm ty +instToVar (Method id _ _ _ _) = id +instToVar (Dict nm pred _) + | isEqPred pred = mkTyVar nm (mkPredTy pred) + | otherwise = mkLocalId nm (mkPredTy pred) instLoc (Dict _ _ loc) = loc instLoc (Method _ _ _ _ loc) = loc @@ -207,29 +220,28 @@ newDicts orig theta = getInstLoc orig `thenM` \ loc -> newDictsAtLoc loc theta -cloneDict :: Inst -> TcM Inst +cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq -> returnM (Dict (setNameUnique nm uniq) ty loc) -newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst -newDictAtLoc inst_loc pred - = do { uniq <- newUnique - ; return (mkDict inst_loc uniq pred) } - newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst] -newDictsAtLoc inst_loc theta - = newUniqueSupply `thenM` \ us -> - returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta) - -mkDict inst_loc uniq pred - = Dict name pred inst_loc - where - name = mkPredName uniq (instLocSrcLoc inst_loc) pred +newDictsAtLoc inst_loc theta = mapM (newDictAtLoc inst_loc) theta + +{- +newDictOcc :: InstLoc -> TcPredType -> TcM Inst +newDictOcc inst_loc (EqPred ty1 ty2) + = do { unifyType ty1 ty2 -- We insist that they unify right away + ; return ty1 } -- And return the relexive coercion +-} +newDictAtLoc inst_loc pred + = do { uniq <- newUnique + ; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred + ; return (Dict name pred inst_loc) } -- For vanilla implicit parameters, there is only one in scope -- at any time, so we used to use the name of the implicit parameter itself -- But with splittable implicit parameters there may be many in --- scope, so we make up a new name. +-- scope, so we make up a new namea. newIPDict :: InstOrigin -> IPName Name -> Type -> TcM (IPName Id, Inst) newIPDict orig ip_name ty @@ -265,7 +277,7 @@ tcInstStupidTheta data_con inst_tys ; extendLIEs stupid_dicts } where stupid_theta = dataConStupidTheta data_con - tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys + tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId newMethodFromName origin ty name @@ -580,8 +592,9 @@ lookupInst :: Inst -> TcM LookupInstResult -- Methods lookupInst inst@(Method _ id tys theta loc) - = newDictsAtLoc loc theta `thenM` \ dicts -> - returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts))) + = do { dicts <- newDictsAtLoc loc theta + ; let co_fn = mkInstCoFn tys dicts + ; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) } where span = instLocSrcSpan loc @@ -654,14 +667,15 @@ lookupInst (Dict _ pred loc) -- any nested for-alls in rho. So the in-scope set is unchanged dfun_rho = substTy tenv' rho (theta, _) = tcSplitPhiTy dfun_rho - ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) - (map (substTyVar tenv') tyvars) + src_loc = instLocSrcSpan loc + dfun = HsVar dfun_id + tys = map (substTyVar tenv') tyvars ; if null theta then - returnM (SimpleInst ty_app) + returnM (SimpleInst (L src_loc $ HsCoerce (CoTyApps tys) dfun)) else do { dicts <- newDictsAtLoc loc theta - ; let rhs = mkHsDictApp ty_app (map instToId dicts) - ; returnM (GenInst dicts rhs) + ; let co_fn = mkInstCoFn tys dicts + ; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun)) }}}} --------------- @@ -698,11 +712,11 @@ lookupPred pred@(ClassP clas tys) lookupPred ip_pred = return Nothing record_dfun_usage dfun_id - = do { gbl <- getGblEnv + = do { hsc_env <- getTopEnv ; let dfun_name = idName dfun_id dfun_mod = nameModule dfun_name ; if isInternalName dfun_name || -- Internal name => defined in this module - not (isHomeModule (tcg_home_mods gbl) dfun_mod) + modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env) then return () -- internal, or in another package else do { tcg_env <- getGblEnv ; updMutVar (tcg_inst_uses tcg_env)