Commit 3e0a7b9f authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent db0c13a4
...@@ -41,8 +41,8 @@ import StaticFlags ...@@ -41,8 +41,8 @@ import StaticFlags
import DynFlags import DynFlags
import CoreSyn import CoreSyn
import PprCore () -- Instances import PprCore () -- Instances
import TcType ( tcSplitSigmaTy, tcSplitDFunHead ) import TcType ( tcSplitDFunTy )
import OccurAnal import OccurAnal ( occurAnalyseExpr )
import CoreSubst hiding( substTy ) import CoreSubst hiding( substTy )
import CoreFVs ( exprFreeVars ) import CoreFVs ( exprFreeVars )
import CoreArity ( manifestArity, exprBotStrictness_maybe ) import CoreArity ( manifestArity, exprBotStrictness_maybe )
...@@ -54,8 +54,7 @@ import Literal ...@@ -54,8 +54,7 @@ import Literal
import PrimOp import PrimOp
import IdInfo import IdInfo
import BasicTypes ( Arity ) import BasicTypes ( Arity )
import TcType ( tcSplitDFunTy ) import Type
import Type
import Coercion import Coercion
import PrelNames import PrelNames
import VarEnv ( mkInScopeSet ) import VarEnv ( mkInScopeSet )
...@@ -95,11 +94,8 @@ mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding ...@@ -95,11 +94,8 @@ mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
mkDFunUnfolding dfun_ty ops mkDFunUnfolding dfun_ty ops
= DFunUnfolding dfun_nargs data_con ops = DFunUnfolding dfun_nargs data_con ops
where where
(tvs, theta, head_ty) = tcSplitSigmaTy dfun_ty (tvs, n_theta, cls, _) = tcSplitDFunTy dfun_ty
-- NB: tcSplitSigmaTy: do not look through a newtype dfun_nargs = length tvs + n_theta
-- when the dictionary type is a newtype
(cls, _) = tcSplitDFunHead head_ty
dfun_nargs = length tvs + length theta
data_con = classDataCon cls data_con = classDataCon cls
mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
...@@ -1285,7 +1281,7 @@ exprIsConApp_maybe id_unf expr ...@@ -1285,7 +1281,7 @@ exprIsConApp_maybe id_unf expr
, let sat = length args == dfun_nargs -- See Note [DFun arity check] , let sat = length args == dfun_nargs -- See Note [DFun arity check]
in if sat then True else in if sat then True else
pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False 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)) subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
mk_arg (DFunConstArg e) = e mk_arg (DFunConstArg e) = e
mk_arg (DFunLamArg i) = args !! i mk_arg (DFunLamArg i) = args !! i
......
...@@ -1428,7 +1428,7 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, ...@@ -1428,7 +1428,7 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
is_local name = nameIsLocalOrFrom mod name is_local name = nameIsLocalOrFrom mod name
-- Compute orphanhood. See Note [Orphans] in IfaceSyn -- 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 -- Slightly awkward: we need the Class to get the fundeps
(tvs, fds) = classTvsFds cls (tvs, fds) = classTvsFds cls
arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys] arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
......
...@@ -989,7 +989,7 @@ tcIdDetails _ IfVanillaId = return VanillaId ...@@ -989,7 +989,7 @@ tcIdDetails _ IfVanillaId = return VanillaId
tcIdDetails ty (IfDFunId ns) tcIdDetails ty (IfDFunId ns)
= return (DFunId ns (isNewTyCon (classTyCon cls))) = return (DFunId ns (isNewTyCon (classTyCon cls)))
where where
(_, cls, _) = tcSplitDFunTy ty (_, _, cls, _) = tcSplitDFunTy ty
tcIdDetails _ (IfRecSelId tc naughty) tcIdDetails _ (IfRecSelId tc naughty)
= do { tc' <- tcIfaceTyCon tc = do { tc' <- tcIfaceTyCon tc
......
...@@ -1249,7 +1249,7 @@ instDeclCtxt2 :: Type -> SDoc ...@@ -1249,7 +1249,7 @@ instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 dfun_ty instDeclCtxt2 dfun_ty
= inst_decl_ctxt (ppr (mkClassPred cls tys)) = inst_decl_ctxt (ppr (mkClassPred cls tys))
where where
(_,cls,tys) = tcSplitDFunTy dfun_ty (_,_,cls,tys) = tcSplitDFunTy dfun_ty
inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
......
...@@ -919,23 +919,24 @@ tcIsTyVarTy :: Type -> Bool ...@@ -919,23 +919,24 @@ tcIsTyVarTy :: Type -> Bool
tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty) tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
----------------------- -----------------------
tcSplitDFunTy :: Type -> ([TyVar], Class, [Type]) tcSplitDFunTy :: Type -> ([TyVar], Int, Class, [Type])
-- Split the type of a dictionary function -- Split the type of a dictionary function
-- We don't use tcSplitSigmaTy, because a DFun may (with NDP) -- We don't use tcSplitSigmaTy, because a DFun may (with NDP)
-- have non-Pred arguments, such as -- have non-Pred arguments, such as
-- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m -- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m
tcSplitDFunTy ty tcSplitDFunTy ty
= case tcSplitForAllTys ty of { (tvs, rho) -> = case tcSplitForAllTys ty of { (tvs, rho) ->
case tcSplitDFunHead (drop_pred_tys rho) of { (clas, tys) -> case split_dfun_args 0 rho of { (n_theta, tau) ->
(tvs, clas, tys) }} case tcSplitDFunHead tau of { (clas, tys) ->
(tvs, n_theta, clas, tys) }}}
where 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) -- coercion and class constraints; or (in the general NDP case)
-- some other function argument -- some other function argument
drop_pred_tys ty | Just ty' <- tcView ty = drop_pred_tys ty' split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty'
drop_pred_tys (ForAllTy tv ty) = ASSERT( isCoVar tv ) drop_pred_tys ty split_dfun_args n (ForAllTy tv ty) = ASSERT( isCoVar tv ) split_dfun_args (n+1) ty
drop_pred_tys (FunTy _ ty) = drop_pred_tys ty split_dfun_args n (FunTy _ ty) = split_dfun_args (n+1) ty
drop_pred_tys ty = ty split_dfun_args n ty = (n, ty)
tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead :: Type -> (Class, [Type])
tcSplitDFunHead tau tcSplitDFunHead tau
......
...@@ -128,7 +128,7 @@ setInstanceDFunId ispec dfun ...@@ -128,7 +128,7 @@ setInstanceDFunId ispec dfun
-- are ok; hence the assert -- are ok; hence the assert
ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys } ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys }
where where
(tvs, _, tys) = tcSplitDFunTy (idType dfun) (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
instanceRoughTcs :: Instance -> [Maybe Name] instanceRoughTcs :: Instance -> [Maybe Name]
instanceRoughTcs = is_tcs instanceRoughTcs = is_tcs
...@@ -184,7 +184,7 @@ mkLocalInstance dfun oflag ...@@ -184,7 +184,7 @@ mkLocalInstance dfun oflag
is_tvs = mkVarSet tvs, is_tys = tys, is_tvs = mkVarSet tvs, is_tys = tys,
is_cls = className cls, is_tcs = roughMatchTcs tys } is_cls = className cls, is_tcs = roughMatchTcs tys }
where where
(tvs, cls, tys) = tcSplitDFunTy (idType dfun) (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
mkImportedInstance :: Name -> [Maybe Name] mkImportedInstance :: Name -> [Maybe Name]
-> DFunId -> OverlapFlag -> Instance -> DFunId -> OverlapFlag -> Instance
...@@ -195,7 +195,7 @@ mkImportedInstance cls mb_tcs dfun oflag ...@@ -195,7 +195,7 @@ mkImportedInstance cls mb_tcs dfun oflag
is_tvs = mkVarSet tvs, is_tys = tys, is_tvs = mkVarSet tvs, is_tys = tys,
is_cls = cls, is_tcs = mb_tcs } is_cls = cls, is_tcs = mb_tcs }
where where
(tvs, _, tys) = tcSplitDFunTy (idType dfun) (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
roughMatchTcs :: [Type] -> [Maybe Name] roughMatchTcs :: [Type] -> [Maybe Name]
roughMatchTcs tys = map rough tys roughMatchTcs tys = map rough tys
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment