From 3e0a7b9fbc16e432efa562df027d189fa274943a Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 22 Dec 2010 13:08:54 +0000 Subject: [PATCH] Make mkDFunUnfolding more robust It now uses tcSplitDFunTy, which is designed for the purpose and allows arbitrary argument types to the dfun, rather than tcSplitSigmaTy. This generality is used in DPH, which has internally-generated dfuns with impliciation-typed arguments. To do this I had to make tcSplitDFunTy return the number of arguments, so there are some minor knock-on effects in other modules. --- compiler/coreSyn/CoreUnfold.lhs | 16 ++++++---------- compiler/iface/MkIface.lhs | 2 +- compiler/iface/TcIface.lhs | 2 +- compiler/typecheck/TcInstDcls.lhs | 2 +- compiler/typecheck/TcType.lhs | 19 ++++++++++--------- compiler/types/InstEnv.lhs | 6 +++--- 6 files changed, 22 insertions(+), 25 deletions(-) diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index dfbb322..06a2d72 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -41,8 +41,8 @@ import StaticFlags import DynFlags import CoreSyn import PprCore () -- Instances -import TcType ( tcSplitSigmaTy, tcSplitDFunHead ) -import OccurAnal +import TcType ( tcSplitDFunTy ) +import OccurAnal ( occurAnalyseExpr ) import CoreSubst hiding( substTy ) import CoreFVs ( exprFreeVars ) import CoreArity ( manifestArity, exprBotStrictness_maybe ) @@ -54,8 +54,7 @@ import Literal import PrimOp import IdInfo import BasicTypes ( Arity ) -import TcType ( tcSplitDFunTy ) -import Type +import Type import Coercion import PrelNames import VarEnv ( mkInScopeSet ) @@ -95,11 +94,8 @@ mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding mkDFunUnfolding dfun_ty ops = DFunUnfolding dfun_nargs data_con ops where - (tvs, theta, head_ty) = tcSplitSigmaTy dfun_ty - -- NB: tcSplitSigmaTy: do not look through a newtype - -- when the dictionary type is a newtype - (cls, _) = tcSplitDFunHead head_ty - dfun_nargs = length tvs + length theta + (tvs, n_theta, cls, _) = tcSplitDFunTy dfun_ty + dfun_nargs = length tvs + n_theta data_con = classDataCon cls mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding @@ -1285,7 +1281,7 @@ exprIsConApp_maybe id_unf expr , let sat = length args == dfun_nargs -- See Note [DFun arity check] in if sat then True else pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False - , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) + , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) mk_arg (DFunConstArg e) = e mk_arg (DFunLamArg i) = args !! i diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index f8d66d5..c0d49a3 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1428,7 +1428,7 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, is_local name = nameIsLocalOrFrom mod name -- Compute orphanhood. See Note [Orphans] in IfaceSyn - (_, cls, tys) = tcSplitDFunTy (idType dfun_id) + (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id) -- Slightly awkward: we need the Class to get the fundeps (tvs, fds) = classTvsFds cls arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys] diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index c880a8a..8dccc72 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -989,7 +989,7 @@ tcIdDetails _ IfVanillaId = return VanillaId tcIdDetails ty (IfDFunId ns) = return (DFunId ns (isNewTyCon (classTyCon cls))) where - (_, cls, _) = tcSplitDFunTy ty + (_, _, cls, _) = tcSplitDFunTy ty tcIdDetails _ (IfRecSelId tc naughty) = do { tc' <- tcIfaceTyCon tc diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index f4e338d..f84f3d5 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -1249,7 +1249,7 @@ instDeclCtxt2 :: Type -> SDoc instDeclCtxt2 dfun_ty = inst_decl_ctxt (ppr (mkClassPred cls tys)) where - (_,cls,tys) = tcSplitDFunTy dfun_ty + (_,_,cls,tys) = tcSplitDFunTy dfun_ty inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 50ac35a..c68c10f 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -919,23 +919,24 @@ tcIsTyVarTy :: Type -> Bool tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty) ----------------------- -tcSplitDFunTy :: Type -> ([TyVar], Class, [Type]) +tcSplitDFunTy :: Type -> ([TyVar], Int, Class, [Type]) -- Split the type of a dictionary function -- We don't use tcSplitSigmaTy, because a DFun may (with NDP) -- have non-Pred arguments, such as -- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m tcSplitDFunTy ty - = case tcSplitForAllTys ty of { (tvs, rho) -> - case tcSplitDFunHead (drop_pred_tys rho) of { (clas, tys) -> - (tvs, clas, tys) }} + = case tcSplitForAllTys ty of { (tvs, rho) -> + case split_dfun_args 0 rho of { (n_theta, tau) -> + case tcSplitDFunHead tau of { (clas, tys) -> + (tvs, n_theta, clas, tys) }}} where - -- Discard the context of the dfun. This can be a mix of + -- Count the context of the dfun. This can be a mix of -- coercion and class constraints; or (in the general NDP case) -- some other function argument - drop_pred_tys ty | Just ty' <- tcView ty = drop_pred_tys ty' - drop_pred_tys (ForAllTy tv ty) = ASSERT( isCoVar tv ) drop_pred_tys ty - drop_pred_tys (FunTy _ ty) = drop_pred_tys ty - drop_pred_tys ty = ty + split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty' + split_dfun_args n (ForAllTy tv ty) = ASSERT( isCoVar tv ) split_dfun_args (n+1) ty + split_dfun_args n (FunTy _ ty) = split_dfun_args (n+1) ty + split_dfun_args n ty = (n, ty) tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead tau diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 34bd5eb..753b04a 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -128,7 +128,7 @@ setInstanceDFunId ispec dfun -- are ok; hence the assert ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys } where - (tvs, _, tys) = tcSplitDFunTy (idType dfun) + (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) instanceRoughTcs :: Instance -> [Maybe Name] instanceRoughTcs = is_tcs @@ -184,7 +184,7 @@ mkLocalInstance dfun oflag is_tvs = mkVarSet tvs, is_tys = tys, is_cls = className cls, is_tcs = roughMatchTcs tys } where - (tvs, cls, tys) = tcSplitDFunTy (idType dfun) + (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) mkImportedInstance :: Name -> [Maybe Name] -> DFunId -> OverlapFlag -> Instance @@ -195,7 +195,7 @@ mkImportedInstance cls mb_tcs dfun oflag is_tvs = mkVarSet tvs, is_tys = tys, is_cls = cls, is_tcs = mb_tcs } where - (tvs, _, tys) = tcSplitDFunTy (idType dfun) + (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) roughMatchTcs :: [Type] -> [Maybe Name] roughMatchTcs tys = map rough tys -- 1.7.10.4