diff options
Diffstat (limited to 'compiler/coreSyn/CoreSubst.lhs')
| -rw-r--r-- | compiler/coreSyn/CoreSubst.lhs | 79 |
1 files changed, 39 insertions, 40 deletions
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 8023786cf7..2e6d907b51 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -59,7 +59,6 @@ import Type hiding ( substTy, extendTvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr ) import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr ) -import TcType ( tcSplitDFunTy ) import TyCon ( tyConArity ) import DataCon import PrelNames ( eqBoxDataConKey ) @@ -78,7 +77,6 @@ import Maybes import ErrUtils import DynFlags import BasicTypes ( isAlwaysActive ) -import ListSetOps import Util import Pair import Outputable @@ -656,10 +654,11 @@ substUnfoldingSC subst unf -- Short-cut version | isEmptySubst subst = unf | otherwise = substUnfolding subst unf -substUnfolding subst (DFunUnfolding ar con args) - = DFunUnfolding ar con (map subst_arg args) +substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = df { df_bndrs = bndrs', df_args = args' } where - subst_arg = fmap (substExpr (text "dfun-unf") subst) + (subst',bndrs') = substBndrs subst bndrs + args' = map (substExpr (text "subst-unf:dfun") subst') args substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) -- Retain an InlineRule! @@ -896,12 +895,12 @@ type OutExpr = CoreExpr -- In these functions the substitution maps InVar -> OutExpr ---------------------- -simple_opt_expr, simple_opt_expr' :: Subst -> InExpr -> OutExpr -simple_opt_expr s e = simple_opt_expr' s e - -simple_opt_expr' subst expr +simple_opt_expr :: Subst -> InExpr -> OutExpr +simple_opt_expr subst expr = go expr where + in_scope_env = (substInScope subst, simpleUnfoldingFun) + go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v go (App e1 e2) = simple_app subst e1 [go e2] go (Type ty) = Type (substTy subst ty) @@ -921,7 +920,7 @@ simple_opt_expr' subst expr go (Case e b ty as) -- See Note [Optimise coercion boxes agressively] | isDeadBinder b - , Just (con, _tys, es) <- expr_is_con_app e' + , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e' , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as = case altcon of DEFAULT -> go rhs @@ -1088,8 +1087,10 @@ add_info subst old_bndr new_bndr | otherwise = maybeModifyIdInfo mb_new_info new_bndr where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr) -expr_is_con_app :: OutExpr -> Maybe (DataCon, [Type], [OutExpr]) -expr_is_con_app = exprIsConApp_maybe (\id -> if isAlwaysActive (idInlineActivation id) then idUnfolding id else noUnfolding) +simpleUnfoldingFun :: IdUnfoldingFun +simpleUnfoldingFun id + | isAlwaysActive (idInlineActivation id) = idUnfolding id + | otherwise = noUnfolding \end{code} Note [Inline prag in simplOpt] @@ -1137,12 +1138,10 @@ data ConCont = CC [CoreExpr] Coercion -- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is -- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@, -- where t1..tk are the *universally-qantified* type args of 'dc' -exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) -exprIsConApp_maybe id_unf expr - = go (Left in_scope) expr (CC [] (mkReflCo (exprType expr))) +exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) +exprIsConApp_maybe (in_scope, id_unf) expr + = go (Left in_scope) expr (CC [] (mkReflCo Representational (exprType expr))) where - in_scope = mkInScopeSet (exprFreeVars expr) - go :: Either InScopeSet Subst -> CoreExpr -> ConCont -> Maybe (DataCon, [Type], [CoreExpr]) @@ -1163,17 +1162,13 @@ exprIsConApp_maybe id_unf expr go (Left in_scope) (Var fun) cont@(CC args co) | Just con <- isDataConWorkId_maybe fun , count isValArg args == idArity fun - , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args - = dealWithCoercion co (con, stripTypeArgs univ_ty_args, rest_args) + = dealWithCoercion co con args -- Look through dictionary functions; see Note [Unfolding DFuns] - | DFunUnfolding dfun_nargs con ops <- unfolding - , length args == dfun_nargs -- See Note [DFun arity check] - , let (dfun_tvs, _theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) - subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) - mk_arg (DFunPolyArg e) = mkApps e args - mk_arg (DFunLamArg i) = getNth args i - = dealWithCoercion co (con, substTys subst dfun_res_tys, map mk_arg ops) + | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding + , bndrs `equalLength` args -- See Note [DFun arity check] + , let subst = mkOpenSubst in_scope (bndrs `zip` args) + = dealWithCoercion co con (map (substExpr (text "exprIsConApp1") subst) dfun_args) -- Look through unfoldings, but only arity-zero one; -- if arity > 0 we are effectively inlining a function call, @@ -1196,17 +1191,17 @@ exprIsConApp_maybe id_unf expr subst_co (Right s) co = CoreSubst.substCo s co subst_arg (Left {}) e = e - subst_arg (Right s) e = substExpr (text "exprIsConApp") s e + subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) extend (Right s) v e = Right (extendSubst s v e) -dealWithCoercion :: Coercion - -> (DataCon, [Type], [CoreExpr]) +dealWithCoercion :: Coercion -> DataCon -> [CoreExpr] -> Maybe (DataCon, [Type], [CoreExpr]) -dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args) +dealWithCoercion co dc dc_args | isReflCo co - = Just stuff + , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args + = Just (dc, stripTypeArgs univ_ty_args, rest_args) | Pair _from_ty to_ty <- coercionKind co , Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty @@ -1229,23 +1224,27 @@ dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args) dc_ex_tyvars = dataConExTyVars dc arg_tys = dataConRepArgTys dc - (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args + non_univ_args = dropList dc_univ_tyvars dc_args + (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args -- Make the "theta" from Fig 3 of the paper gammas = decomposeCo tc_arity co - theta_subst = liftCoSubstWith + theta_subst = liftCoSubstWith Representational (dc_univ_tyvars ++ dc_ex_tyvars) - (gammas ++ map mkReflCo (stripTypeArgs ex_args)) + -- existentials are at role N + (gammas ++ map (mkReflCo Nominal) + (stripTypeArgs ex_args)) -- Cast the value arguments (which include dictionaries) new_val_args = zipWith cast_arg arg_tys val_args cast_arg arg_ty arg = mkCast arg (theta_subst arg_ty) dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, - ppr arg_tys, ppr dc_args, ppr _dc_univ_args, + ppr arg_tys, ppr dc_args, ppr ex_args, ppr val_args, ppr co, ppr _from_ty, ppr to_ty, ppr to_tc ] in - ASSERT2( eqType _from_ty (mkTyConApp to_tc _dc_univ_args), dump_doc ) + ASSERT2( eqType _from_ty (mkTyConApp to_tc (stripTypeArgs $ takeList dc_univ_tyvars dc_args)) + , dump_doc ) ASSERT2( all isTypeArg ex_args, dump_doc ) ASSERT2( equalLength val_args arg_tys, dump_doc ) Just (dc, to_tc_arg_tys, ex_args ++ new_val_args) @@ -1278,16 +1277,16 @@ type args) matches what the dfun is expecting. This may be *less* than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn \begin{code} -exprIsLiteral_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe Literal +exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal -- Same deal as exprIsConApp_maybe, but much simpler -- Nevertheless we do need to look through unfoldings for -- Integer literals, which are vigorously hoisted to top level -- and not subsequently inlined -exprIsLiteral_maybe id_unf e +exprIsLiteral_maybe env@(_, id_unf) e = case e of Lit l -> Just l - Tick _ e' -> exprIsLiteral_maybe id_unf e' -- dubious? + Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? Var v | Just rhs <- expandUnfolding_maybe (id_unf v) - -> exprIsLiteral_maybe id_unf rhs + -> exprIsLiteral_maybe env rhs _ -> Nothing \end{code} |