Commit f970ae23 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Make the specialiser understand about polymorphic kinds

parent c676a15e
......@@ -1071,12 +1071,15 @@ specCalls subst rules_for_me calls_for_me fn rhs
(substInScope subst)
fn args rules_for_me)
mk_ty_args :: [Maybe Type] -> [CoreExpr]
mk_ty_args call_ts = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts
where
mk_ty_arg rhs_tyvar Nothing = Type (mkTyVarTy rhs_tyvar)
mk_ty_arg _ (Just ty) = Type ty
mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr]
mk_ty_args [] poly_tvs
= ASSERT( null poly_tvs ) []
mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs)
= Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs
mk_ty_args (Just ty : call_ts) poly_tvs
= Type ty : mk_ty_args call_ts poly_tvs
mk_ty_args (Nothing : _) [] = panic "mk_ty_args"
----------------------------------------------------------
-- Specialise to one particular call pattern
spec_call :: CallInfo -- Call instance
......@@ -1103,17 +1106,19 @@ specCalls subst rules_for_me calls_for_me fn rhs
-- poly_tyvars = [b] in the example above
-- spec_tyvars = [a,c]
-- ty_args = [t1,b,t3]
poly_tyvars = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]
spec_ty_args = map snd spec_tv_binds
ty_args = mk_ty_args call_ts
rhs_subst = CoreSubst.extendTvSubstList subst spec_tv_binds
subst1 = CoreSubst.extendTvSubstList subst spec_tv_binds
(rhs_subst, poly_tyvars)
= CoreSubst.substBndrs subst1
[tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
; (rhs_subst1, inst_dict_ids) <- newDictBndrs rhs_subst rhs_dict_ids
-- Clone rhs_dicts, including instantiating their types
; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $
(my_zipEqual rhs_dict_ids inst_dict_ids call_ds)
ty_args = mk_ty_args call_ts poly_tyvars
inst_args = ty_args ++ map Var inst_dict_ids
; if already_covered inst_args then
......
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