diff options
Diffstat (limited to 'compiler/specialise/Specialise.hs')
| -rw-r--r-- | compiler/specialise/Specialise.hs | 60 |
1 files changed, 33 insertions, 27 deletions
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index cb671be7a5..d45b72a718 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -10,8 +10,8 @@ module Specialise ( specProgram, specUnfolding ) where #include "HsVersions.h" import Id -import TcType hiding( substTy, extendTvSubstList ) -import Type hiding( substTy, extendTvSubstList ) +import TcType hiding( substTy, extendTCvSubstList ) +import Type hiding( substTy, extendTCvSubstList ) import Coercion( Coercion ) import Module( Module, HasModule(..) ) import CoreMonad @@ -21,7 +21,7 @@ import VarSet import VarEnv import CoreSyn import Rules -import CoreUtils ( exprIsTrivial, applyTypeToArgs ) +import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkCast ) import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) import UniqSupply import Name @@ -858,7 +858,7 @@ specExpr env (Var v) = return (specVar env v, emptyUDs) specExpr _ (Lit lit) = return (Lit lit, emptyUDs) specExpr env (Cast e co) = do { (e', uds) <- specExpr env e - ; return ((Cast e' (substCo env co)), uds) } + ; return ((mkCast e' (substCo env co)), uds) } specExpr env (Tick tickish body) = do { (body', uds) <- specExpr env body ; return (Tick (specTickish env tickish) body', uds) } @@ -959,7 +959,7 @@ specCase env scrut' case_bndr [(con, args, rhs)] sc_args' = filter is_flt_sc_arg args' clone_me bndr = do { uniq <- getUniqueM - ; return (mkUserLocal occ uniq ty loc) } + ; return (mkUserLocalOrCoVar occ uniq ty loc) } where name = idName bndr ty = idType bndr @@ -970,7 +970,7 @@ specCase env scrut' case_bndr [(con, args, rhs)] is_flt_sc_arg var = isId var && not (isDeadBinder var) && isDictTy var_ty - && not (tyVarsOfType var_ty `intersectsVarSet` arg_set) + && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set) where var_ty = idType var @@ -1182,15 +1182,15 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs , ppr rhs_ids, ppr n_dicts , ppr (idInlineActivation fn) ] - fn_type = idType fn - fn_arity = idArity fn - fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here - (tyvars, theta, _) = tcSplitSigmaTy fn_type - n_tyvars = length tyvars - n_dicts = length theta - inl_prag = idInlinePragma fn - inl_act = inlinePragmaActivation inl_prag - is_local = isLocalId fn + fn_type = idType fn + fn_arity = idArity fn + fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here + (tyvars, theta, _) = tcSplitSigmaTy fn_type + n_tyvars = length tyvars + n_dicts = length theta + inl_prag = idInlinePragma fn + inl_act = inlinePragmaActivation inl_prag + is_local = isLocalId fn -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] @@ -1244,7 +1244,7 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs -- spec_tyvars = [a,c] -- ty_args = [t1,b,t3] spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts] - env1 = extendTvSubstList env spec_tv_binds + env1 = extendTCvSubstList env spec_tv_binds (rhs_env, poly_tyvars) = substBndrs env1 [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts] @@ -1775,7 +1775,7 @@ singleCall id tys dicts Map.singleton (CallKey tys) (dicts, call_fvs) } where call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs - tys_fvs = tyVarsOfTypes (catMaybes tys) + tys_fvs = tyCoVarsOfTypes (catMaybes tys) -- The type args (tys) are guaranteed to be part of the dictionary -- types, because they are just the constrained types, -- and the dictionary is therefore sure to be bound @@ -1812,14 +1812,20 @@ mkCallUDs' env f args where _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts , ppr (map (interestingDict env) dicts)] - (tyvars, theta, _) = tcSplitSigmaTy (idType f) - constrained_tyvars = closeOverKinds (tyVarsOfTypes theta) - n_tyvars = length tyvars - n_dicts = length theta + (tyvars, theta, _) = tcSplitSigmaTy (idType f) + constrained_tyvars = tyCoVarsOfTypes theta + n_tyvars = length tyvars + n_dicts = length theta - spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args] + spec_tys = [mk_spec_ty tv ty | (tv, ty) <- tyvars `type_zip` args] dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)] + -- ignores Coercion arguments + type_zip :: [TyVar] -> [CoreExpr] -> [(TyVar, Type)] + type_zip tvs (Coercion _ : args) = type_zip tvs args + type_zip (tv:tvs) (Type ty : args) = (tv, ty) : type_zip tvs args + type_zip _ _ = [] + mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars = Just ty | otherwise = Nothing @@ -2131,9 +2137,9 @@ mapAndCombineSM f (x:xs) = do (y, uds1) <- f x (ys, uds2) <- mapAndCombineSM f xs return (y:ys, uds1 `plusUDs` uds2) -extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv -extendTvSubstList env tv_binds - = env { se_subst = CoreSubst.extendTvSubstList (se_subst env) tv_binds } +extendTCvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv +extendTCvSubstList env tv_binds + = env { se_subst = CoreSubst.extendTCvSubstList (se_subst env) tv_binds } substTy :: SpecEnv -> Type -> Type substTy env ty = CoreSubst.substTy (se_subst env) ty @@ -2175,7 +2181,7 @@ newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr newDictBndr env b = do { uniq <- getUniqueM ; let n = idName b ty' = substTy env (idType b) - ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) } + ; return (mkUserLocalOrCoVar (nameOccName n) uniq ty' (getSrcSpan n)) } newSpecIdSM :: Id -> Type -> SpecM Id -- Give the new Id a similar occurrence name to the old one @@ -2183,7 +2189,7 @@ newSpecIdSM old_id new_ty = do { uniq <- getUniqueM ; let name = idName old_id new_occ = mkSpecOcc (nameOccName name) - new_id = mkUserLocal new_occ uniq new_ty (getSrcSpan name) + new_id = mkUserLocalOrCoVar new_occ uniq new_ty (getSrcSpan name) ; return new_id } {- |