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

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