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
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,7 +54,6 @@ import Literal
import PrimOp
import IdInfo
import BasicTypes ( Arity )
import TcType ( tcSplitDFunTy )
import Type
import Coercion
import PrelNames
......@@ -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
......
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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 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
......
......@@ -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
......
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