Commit d360ec39 authored by David Feuer's avatar David Feuer Committed by Ben Gamari

Split mkInlineUnfolding into two functions

Previously, `mkInlineUnfolding` took a `Maybe` argument indicating
whether the caller requested a specific arity.  This was not
self-documenting at call sites. Now we distinguish between
`mkInlineUnfolding` and `mkInlineUnfoldingWithArity`.

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2933
parent e195add1
...@@ -292,7 +292,8 @@ mkDictSelId name clas ...@@ -292,7 +292,8 @@ mkDictSelId name clas
info | new_tycon info | new_tycon
= base_info `setInlinePragInfo` alwaysInlinePragma = base_info `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkInlineUnfolding (Just 1) (mkDictSelRhs clas val_index) `setUnfoldingInfo` mkInlineUnfoldingWithArity 1
(mkDictSelRhs clas val_index)
-- See Note [Single-method classes] in TcInstDcls -- See Note [Single-method classes] in TcInstDcls
-- for why alwaysInlinePragma -- for why alwaysInlinePragma
...@@ -533,7 +534,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con ...@@ -533,7 +534,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
-- See Note [Inline partially-applied constructor wrappers] -- See Note [Inline partially-applied constructor wrappers]
-- Passing Nothing here allows the wrapper to inline when -- Passing Nothing here allows the wrapper to inline when
-- unsaturated. -- unsaturated.
wrap_unf = mkInlineUnfolding Nothing wrap_rhs wrap_unf = mkInlineUnfolding wrap_rhs
wrap_tvs = (univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs wrap_tvs = (univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs
wrap_rhs = mkLams wrap_tvs $ wrap_rhs = mkLams wrap_tvs $
mkLams wrap_args $ mkLams wrap_args $
...@@ -1091,7 +1092,7 @@ dollarId = pcMiscPrelId dollarName ty ...@@ -1091,7 +1092,7 @@ dollarId = pcMiscPrelId dollarName ty
fun_ty = mkFunTy alphaTy openBetaTy fun_ty = mkFunTy alphaTy openBetaTy
ty = mkSpecForAllTys [runtimeRep2TyVar, alphaTyVar, openBetaTyVar] $ ty = mkSpecForAllTys [runtimeRep2TyVar, alphaTyVar, openBetaTyVar] $
mkFunTy fun_ty fun_ty mkFunTy fun_ty fun_ty
unf = mkInlineUnfolding (Just 2) rhs unf = mkInlineUnfoldingWithArity 2 rhs
[f,x] = mkTemplateLocals [fun_ty, alphaTy] [f,x] = mkTemplateLocals [fun_ty, alphaTy]
rhs = mkLams [runtimeRep2TyVar, alphaTyVar, openBetaTyVar, f, x] $ rhs = mkLams [runtimeRep2TyVar, alphaTyVar, openBetaTyVar, f, x] $
App (Var f) (Var x) App (Var f) (Var x)
......
...@@ -23,7 +23,8 @@ module CoreUnfold ( ...@@ -23,7 +23,8 @@ module CoreUnfold (
noUnfolding, mkImplicitUnfolding, noUnfolding, mkImplicitUnfolding,
mkUnfolding, mkCoreUnfolding, mkUnfolding, mkCoreUnfolding,
mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding, mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding,
mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule, mkInlineUnfolding, mkInlineUnfoldingWithArity,
mkInlinableUnfolding, mkWwInlineRule,
mkCompulsoryUnfolding, mkDFunUnfolding, mkCompulsoryUnfolding, mkDFunUnfolding,
specUnfolding, specUnfolding,
...@@ -125,20 +126,34 @@ mkWorkerUnfolding dflags work_fn ...@@ -125,20 +126,34 @@ mkWorkerUnfolding dflags work_fn
mkWorkerUnfolding _ _ _ = noUnfolding mkWorkerUnfolding _ _ _ = noUnfolding
mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding -- | Make an unfolding that may be used unsaturated
mkInlineUnfolding mb_arity expr -- (ug_unsat_ok = unSaturatedOk) and that is reported as having its
-- manifest arity (the number of outer lambdas applications will
-- resolve before doing any work).
mkInlineUnfolding :: CoreExpr -> Unfolding
mkInlineUnfolding expr
= mkCoreUnfolding InlineStable = mkCoreUnfolding InlineStable
True -- Note [Top-level flag on inline rules] True -- Note [Top-level flag on inline rules]
expr' guide expr' guide
where where
expr' = simpleOptExpr expr expr' = simpleOptExpr expr
guide = case mb_arity of guide = UnfWhen { ug_arity = manifestArity expr'
Nothing -> UnfWhen { ug_arity = manifestArity expr' , ug_unsat_ok = unSaturatedOk
, ug_unsat_ok = unSaturatedOk , ug_boring_ok = boring_ok }
, ug_boring_ok = boring_ok } boring_ok = inlineBoringOk expr'
Just arity -> UnfWhen { ug_arity = arity
, ug_unsat_ok = needSaturated -- | Make an unfolding that will be used once the RHS has been saturated
, ug_boring_ok = boring_ok } -- to the given arity.
mkInlineUnfoldingWithArity :: Arity -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity arity expr
= mkCoreUnfolding InlineStable
True -- Note [Top-level flag on inline rules]
expr' guide
where
expr' = simpleOptExpr expr
guide = UnfWhen { ug_arity = arity
, ug_unsat_ok = needSaturated
, ug_boring_ok = boring_ok }
boring_ok = inlineBoringOk expr' boring_ok = inlineBoringOk expr'
mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding
......
...@@ -378,12 +378,12 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs ...@@ -378,12 +378,12 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
-- And eta-expand the RHS; see Note [Eta-expanding INLINE things] -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
, let real_arity = dict_arity + arity , let real_arity = dict_arity + arity
-- NB: The arity in the InlineRule takes account of the dictionaries -- NB: The arity in the InlineRule takes account of the dictionaries
= ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs
, etaExpand real_arity rhs) , etaExpand real_arity rhs)
| otherwise | otherwise
= pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
(gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs) (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)
dictArity :: [Var] -> Arity dictArity :: [Var] -> Arity
-- Don't count coercion variables in arity -- Don't count coercion variables in arity
......
...@@ -272,7 +272,8 @@ dsFCall fn_id co fcall mDeclHeader = do ...@@ -272,7 +272,8 @@ dsFCall fn_id co fcall mDeclHeader = do
wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
wrap_rhs = mkLams (tvs ++ args) wrapper_body wrap_rhs = mkLams (tvs ++ args) wrapper_body
wrap_rhs' = Cast wrap_rhs co wrap_rhs' = Cast wrap_rhs co
fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs' fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
(length args) wrap_rhs'
return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc) return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
......
...@@ -2494,7 +2494,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') = do ...@@ -2494,7 +2494,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') = do
DataAlt dc -> setIdUnfolding case_bndr unf DataAlt dc -> setIdUnfolding case_bndr unf
where where
-- See Note [Case binders and join points] -- See Note [Case binders and join points]
unf = mkInlineUnfolding Nothing rhs unf = mkInlineUnfolding rhs
rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'
LitAlt {} -> WARN( True, text "mkDupableAlt" LitAlt {} -> WARN( True, text "mkDupableAlt"
......
...@@ -36,7 +36,7 @@ import TcHsType ...@@ -36,7 +36,7 @@ import TcHsType
import TcUnify import TcUnify
import CoreSyn ( Expr(..), mkApps, mkVarApps, mkLams ) import CoreSyn ( Expr(..), mkApps, mkVarApps, mkLams )
import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import MkCore ( nO_METHOD_BINDING_ERROR_ID )
import CoreUnfold ( mkInlineUnfolding, mkDFunUnfolding ) import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
import Type import Type
import TcEvidence import TcEvidence
import TyCon import TyCon
...@@ -884,7 +884,7 @@ addDFunPrags :: DFunId -> [Id] -> DFunId ...@@ -884,7 +884,7 @@ addDFunPrags :: DFunId -> [Id] -> DFunId
-- is messing with. -- is messing with.
addDFunPrags dfun_id sc_meth_ids addDFunPrags dfun_id sc_meth_ids
| is_newtype | is_newtype
= dfun_id `setIdUnfolding` mkInlineUnfolding (Just 0) con_app = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app
`setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
| otherwise | otherwise
= dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args
......
...@@ -17,7 +17,7 @@ import Vectorise.Env ...@@ -17,7 +17,7 @@ import Vectorise.Env
import Vectorise.Monad import Vectorise.Monad
import HscTypes hiding ( MonadThings(..) ) import HscTypes hiding ( MonadThings(..) )
import CoreUnfold ( mkInlineUnfolding ) import CoreUnfold ( mkInlineUnfoldingWithArity )
import PprCore import PprCore
import CoreSyn import CoreSyn
import CoreMonad ( CoreM, getHscEnv ) import CoreMonad ( CoreM, getHscEnv )
...@@ -325,7 +325,7 @@ vectTopBinder var inline expr ...@@ -325,7 +325,7 @@ vectTopBinder var inline expr
} }
where where
unfolding = case inline of unfolding = case inline of
Inline arity -> mkInlineUnfolding (Just arity) expr Inline arity -> mkInlineUnfoldingWithArity arity expr
DontInline -> noUnfolding DontInline -> noUnfolding
{- {-
!!!TODO: dfuns and unfoldings: !!!TODO: dfuns and unfoldings:
......
...@@ -116,7 +116,8 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr ...@@ -116,7 +116,8 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr
let body = mkLams (tvs ++ args) expr let body = mkLams (tvs ++ args) expr
raw_var <- newExportedVar (method_name dfun_name name) (exprType body) raw_var <- newExportedVar (method_name dfun_name name) (exprType body)
let var = raw_var let var = raw_var
`setIdUnfolding` mkInlineUnfolding (Just (length args)) body `setIdUnfolding` mkInlineUnfoldingWithArity
(length args) body
`setInlinePragma` alwaysInlinePragma `setInlinePragma` alwaysInlinePragma
hoistBinding var body hoistBinding var body
return var return var
......
...@@ -448,7 +448,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc ...@@ -448,7 +448,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc
raw_worker <- mkVectId orig_worker (exprType body) raw_worker <- mkVectId orig_worker (exprType body)
let vect_worker = raw_worker `setIdUnfolding` let vect_worker = raw_worker `setIdUnfolding`
mkInlineUnfolding (Just arity) body mkInlineUnfoldingWithArity arity body
defGlobalVar orig_worker vect_worker defGlobalVar orig_worker vect_worker
return (vect_worker, body) return (vect_worker, body)
where where
......
...@@ -62,7 +62,7 @@ hoistExpr fs expr inl ...@@ -62,7 +62,7 @@ hoistExpr fs expr inl
where where
mk_inline var = case inl of mk_inline var = case inl of
Inline arity -> var `setIdUnfolding` Inline arity -> var `setIdUnfolding`
mkInlineUnfolding (Just arity) expr mkInlineUnfoldingWithArity arity expr
DontInline -> var DontInline -> var
hoistVExpr :: VExpr -> Inline -> VM VVar hoistVExpr :: VExpr -> Inline -> VM VVar
......
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