X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=cff48e382f1761fd3d42f98cf892ff2f67a047ea;hb=00cc4d8773d1138f7b3b3ac122f3c98a6f93e68a;hp=8768e202505aacb50fb35ec6a0f8ff06cffdbadb;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 8768e20..cff48e3 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -12,10 +12,12 @@ module Inst ( tidyInsts, tidyMoreInsts, - newDicts, newDictAtLoc, newDictsAtLoc, cloneDict, + newDictBndr, newDictBndrs, newDictBndrsO, + instCall, instStupidTheta, + cloneDict, shortCutFracLit, shortCutIntLit, newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy, - tcInstClassOp, tcInstStupidTheta, + tcInstClassOp, tcSyntaxName, isHsVar, tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, @@ -30,7 +32,7 @@ module Inst ( isTyVarDict, isMethodFor, zonkInst, zonkInsts, - instToId, instName, + instToId, instToVar, instName, InstOrigin(..), InstLoc(..), pprInstLoc ) where @@ -38,10 +40,12 @@ module Inst ( #include "HsVersions.h" import {-# SOURCE #-} TcExpr( tcPolyExpr ) +import {-# SOURCE #-} TcUnify( unifyType ) import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp, + ExprCoFn(..), (<.>), mkCoTyApps, idCoercion, nlHsLit, nlHsVar ) -import TcHsSyn ( mkHsTyApp, mkHsDictApp, zonkId ) +import TcHsSyn ( zonkId ) import TcRnMonad import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy ) import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..), @@ -65,28 +69,28 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, pprPred, pprParendType, pprTheta ) -import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst, +import Type ( TvSubst, substTy, substTyVar, substTyWith, 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 ( dataConWrapId ) +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, isId, mkTyVar ) import VarEnv ( TidyEnv, emptyTidyEnv ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet ) import TysWiredIn ( floatDataCon, doubleDataCon ) import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName ) 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} @@ -99,9 +103,16 @@ 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 @@ -199,37 +210,79 @@ linearInstType (Dict _ (IParam _ ty) _) = ty %* * %************************************************************************ +-- newDictBndrs makes a dictionary at a binding site +-- instCall makes a dictionary at an occurrence site +-- and throws it into the LIE + \begin{code} -newDicts :: InstOrigin - -> TcThetaType - -> TcM [Inst] -newDicts orig theta - = getInstLoc orig `thenM` \ loc -> - newDictsAtLoc loc theta +---------------- +newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst] +newDictBndrsO orig theta = do { loc <- getInstLoc orig + ; newDictBndrs loc theta } + +newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst] +newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta + +newDictBndr :: InstLoc -> TcPredType -> TcM Inst +newDictBndr inst_loc pred + = do { uniq <- newUnique + ; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred + ; return (Dict name pred inst_loc) } + +---------------- +instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM ExprCoFn +-- Instantiate the constraints of a call +-- (instCall o tys theta) +-- (a) Makes fresh dictionaries as necessary for the constraints (theta) +-- (b) Throws these dictionaries into the LIE +-- (c) Eeturns an ExprCoFn ([.] tys dicts) + +instCall orig tys theta + = do { loc <- getInstLoc orig + ; (dicts, dict_app) <- instCallDicts loc theta + ; extendLIEs dicts + ; return (dict_app <.> mkCoTyApps tys) } + +---------------- +instStupidTheta :: InstOrigin -> TcThetaType -> TcM () +-- Similar to instCall, but only emit the constraints in the LIE +-- Used exclusively for the 'stupid theta' of a data constructor +instStupidTheta orig theta + = do { loc <- getInstLoc orig + ; (dicts, _) <- instCallDicts loc theta + ; extendLIEs dicts } + +---------------- +instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], ExprCoFn) +-- This is the key place where equality predicates +-- are unleashed into the world +instCallDicts loc [] = return ([], idCoercion) + +instCallDicts loc (EqPred ty1 ty2 : preds) + = do { unifyType ty1 ty2 -- For now, we insist that they unify right away + -- Later on, when we do associated types, + -- unifyType :: Type -> Type -> TcM ([Inst], Coercion) + ; (dicts, co_fn) <- instCallDicts loc preds + ; return (dicts, co_fn <.> CoTyApp ty1) } + -- We use type application to apply the function to the + -- coercion; here ty1 *is* the appropriate identity coercion + +instCallDicts loc (pred : preds) + = do { uniq <- newUnique + ; let name = mkPredName uniq (instLocSrcLoc loc) pred + dict = Dict name pred loc + ; (dicts, co_fn) <- instCallDicts loc preds + ; return (dict:dicts, co_fn <.> CoApp (instToId dict)) } -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 - -- 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 @@ -253,20 +306,6 @@ newIPDict orig ip_name ty \begin{code} -tcInstStupidTheta :: DataCon -> [TcType] -> TcM () --- Instantiate the "stupid theta" of the data con, and throw --- the constraints into the constraint set -tcInstStupidTheta data_con inst_tys - | null stupid_theta - = return () - | otherwise - = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con)) - (substTheta tenv stupid_theta) - ; extendLIEs stupid_dicts } - where - stupid_theta = dataConStupidTheta data_con - tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys - newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId newMethodFromName origin ty name = tcLookupId name `thenM` \ id -> @@ -580,8 +619,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, dict_app) <- instCallDicts loc theta + ; let co_fn = dict_app <.> mkCoTyApps tys + ; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) } where span = instLocSrcSpan loc @@ -654,14 +694,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 (mkCoTyApps tys) dfun)) else do - { dicts <- newDictsAtLoc loc theta - ; let rhs = mkHsDictApp ty_app (map instToId dicts) - ; returnM (GenInst dicts rhs) + { (dicts, dict_app) <- instCallDicts loc theta + ; let co_fn = dict_app <.> mkCoTyApps tys + ; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun)) }}}} --------------- @@ -698,11 +739,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)