Commit 7cdf141d authored by Joachim Breitner's avatar Joachim Breitner

Refactor WorkWrap, get rid of worthSplittingArgDmd

Instead of first checking whether splitting is useful, and then firing
up the worker-wrapper-machinery, which will do the same checks again, we
now simply generate a worker and wrapper, and while doing so keep track
of whether what we did was in any way useful.

So now there is only one place left where we decide whether we want to
do w/w, and that place has access to more information, in particular the
actual types at hand.
parent ab74d75d
......@@ -47,8 +47,6 @@ module Demand (
isSingleUsed, reuseEnv, zapDemand, zapStrictSig,
worthSplittingArgDmd, worthSplittingThunkDmd,
strictifyDictDmd
) where
......@@ -845,32 +843,6 @@ different:
unused, so we can use absDmd there.
* Further arguments *can* be used, of course. Hence topDmd is used.
%************************************************************************
%* *
Whether a demand justifies a w/w split
%* *
%************************************************************************
\begin{code}
worthSplittingArgDmd :: Demand -- Demand on a function argument
-> Bool
worthSplittingArgDmd dmd
= go dmd
where
go (JD {absd=Abs}) = True -- Absent arg
-- See Note [Worker-wrapper for bottoming functions]
go (JD {strd=Str HyperStr, absd=Use _ (UProd _)}) = True
-- See Note [Worthy functions for Worker-Wrapper split]
go (JD {strd=Str (SProd {})}) = True -- Product arg to evaluate
go (JD {strd=Str HeadStr, absd=Use _ (UProd _)}) = True -- Strictly used product arg
go (JD {strd=Str HeadStr, absd=Use _ UHead}) = True
go _ = False
\end{code}
Note [Worthy functions for Worker-Wrapper split]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For non-bottoming functions a worker-wrapper transformation takes into
......
......@@ -17,7 +17,6 @@ import CoreSyn
import CoreUnfold ( certainlyWillInline, mkInlineUnfolding, mkWwInlineRule )
import CoreUtils ( exprType, exprIsHNF )
import CoreArity ( exprArity )
import Type ( isVoidTy )
import Var
import Id
import IdInfo
......@@ -257,30 +256,21 @@ tryWW dflags is_rec fn_id rhs
-- Furthermore, don't even expose strictness info
= return [ (fn_id, rhs) ]
| is_fun && (worth_splitting_args wrap_dmds rhs || returnsCPR res_info)
= checkSize dflags new_fn_id rhs $
splitFun dflags new_fn_id fn_info wrap_dmds res_info rhs
| is_thunk && (worthSplittingArgDmd fn_dmd || returnsCPR res_info)
-- See Note [Thunk splitting]
= ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive
checkSize dflags new_fn_id rhs $
splitThunk dflags new_fn_id rhs
| otherwise
= return [ (new_fn_id, rhs) ]
= do
let doSplit | is_fun = splitFun dflags new_fn_id fn_info wrap_dmds res_info rhs
| is_thunk = splitThunk dflags is_rec new_fn_id rhs
-- See Note [Thunk splitting]
| otherwise = return Nothing
try <- doSplit
case try of
Nothing -> return $ [ (new_fn_id, rhs) ]
Just binds -> checkSize dflags new_fn_id rhs binds
where
fn_info = idInfo fn_id
fn_dmd = demandInfo fn_info
fn_info = idInfo fn_id
inline_act = inlinePragmaActivation (inlinePragInfo fn_info)
worth_splitting_args [d] (Lam b _)
| isAbsDmd d && isVoidTy (idType b)
= False -- Note [Do not split void functions]
worth_splitting_args wrap_dmds _
= any worthSplittingArgDmd wrap_dmds
-- In practice it always will have a strictness
-- signature, even if it's a uninformative one
strict_sig = strictnessInfo fn_info
......@@ -299,8 +289,7 @@ tryWW dflags is_rec fn_id rhs
is_thunk = not is_fun && not (exprIsHNF rhs)
---------------------
checkSize :: DynFlags -> Id -> CoreExpr
-> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)]
checkSize :: DynFlags -> Id -> CoreExpr -> [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)]
checkSize dflags fn_id rhs thing_inside
| isStableUnfolding (realIdUnfolding fn_id)
= return [ (fn_id, rhs) ]
......@@ -315,22 +304,22 @@ checkSize dflags fn_id rhs thing_inside
-- NB: use idUnfolding because we don't want to apply
-- this criterion to a loop breaker!
| otherwise = thing_inside
| otherwise = return thing_inside
where
inline_rule = mkInlineUnfolding Nothing rhs
---------------------
splitFun :: DynFlags -> Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var
-> UniqSM [(Id, CoreExpr)]
splitFun :: DynFlags -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr
-> UniqSM (Maybe [(Id, CoreExpr)])
splitFun dflags fn_id fn_info wrap_dmds res_info rhs
= WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
(do {
-- The arity should match the signature
(work_demands, wrap_fn, work_fn) <- mkWwBodies dflags fun_ty wrap_dmds res_info one_shots
; work_uniq <- getUniqueM
; let
work_rhs = work_fn rhs
work_id = mkWorkerId work_uniq fn_id (exprType work_rhs)
= WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do
-- The arity should match the signature
stuff <- mkWwBodies dflags fun_ty wrap_dmds res_info one_shots
case stuff of
Just (work_demands, wrap_fn, work_fn) -> do
work_uniq <- getUniqueM
let work_rhs = work_fn rhs
work_id = mkWorkerId work_uniq fn_id (exprType work_rhs)
`setIdOccInfo` occInfo fn_info
-- Copy over occurrence info from parent
-- Notably whether it's a loop breaker
......@@ -354,25 +343,27 @@ splitFun dflags fn_id fn_info wrap_dmds res_info rhs
-- Set the arity so that the Core Lint check that the
-- arity is consistent with the demand type goes through
wrap_rhs = wrap_fn work_id
wrap_prag = InlinePragma { inl_inline = Inline
, inl_sat = Nothing
, inl_act = ActiveAfter 0
, inl_rule = rule_match_info }
wrap_rhs = wrap_fn work_id
wrap_prag = InlinePragma { inl_inline = Inline
, inl_sat = Nothing
, inl_act = ActiveAfter 0
, inl_rule = rule_match_info }
-- See Note [Wrapper activation]
-- The RuleMatchInfo is (and must be) unaffected
-- The inl_inline is bound to be False, else we would not be
-- making a wrapper
wrap_id = fn_id `setIdUnfolding` mkWwInlineRule wrap_rhs arity
`setInlinePragma` wrap_prag
`setIdOccInfo` NoOccInfo
wrap_id = fn_id `setIdUnfolding` mkWwInlineRule wrap_rhs arity
`setInlinePragma` wrap_prag
`setIdOccInfo` NoOccInfo
-- Zap any loop-breaker-ness, to avoid bleating from Lint
-- about a loop breaker with an INLINE rule
return $ Just [(work_id, work_rhs), (wrap_id, wrap_rhs)]
-- Worker first, because wrapper mentions it
-- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it
; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) })
-- Worker first, because wrapper mentions it
-- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it
Nothing ->
return Nothing
where
fun_ty = idType fn_id
inl_prag = inlinePragInfo fn_info
......@@ -458,8 +449,11 @@ then the splitting will go deeper too.
-- --> x = let x = e in
-- case x of (a,b) -> let x = (a,b) in x
splitThunk :: DynFlags -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
splitThunk dflags fn_id rhs = do
(_, wrap_fn, work_fn) <- mkWWstr dflags [fn_id]
return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
splitThunk :: DynFlags -> RecFlag -> Var -> Expr Var -> UniqSM (Maybe [(Var, Expr Var)])
splitThunk dflags is_rec fn_id rhs = do
(useful,_, wrap_fn, work_fn) <- mkWWstr dflags [fn_id]
let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive
return (Just res)
else return Nothing
\end{code}
......@@ -105,13 +105,13 @@ the unusable strictness-info into the interfaces.
\begin{code}
mkWwBodies :: DynFlags
-> Type -- Type of original function
-> [Demand] -- Strictness of original function
-> DmdResult -- Info about function result
-> [OneShotInfo] -- One-shot-ness of the function, value args only
-> UniqSM ([Demand], -- Demands for worker (value) args
Id -> CoreExpr, -- Wrapper body, lacking only the worker Id
CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs
-> Type -- Type of original function
-> [Demand] -- Strictness of original function
-> DmdResult -- Info about function result
-> [OneShotInfo] -- One-shot-ness of the function, value args only
-> UniqSM (Maybe ([Demand], -- Demands for worker (value) args
Id -> CoreExpr, -- Wrapper body, lacking only the worker Id
CoreExpr -> CoreExpr)) -- Worker body, lacking the original function rhs
-- wrap_fn_args E = \x y -> E
-- work_fn_args E = E x y
......@@ -128,15 +128,20 @@ mkWwBodies dflags fun_ty demands res_info one_shots
= do { let arg_info = demands `zip` (one_shots ++ repeat NoOneShotInfo)
all_one_shots = foldr (worstOneShot . snd) OneShotLam arg_info
; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info
; (work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags wrap_args
; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags wrap_args
-- Do CPR w/w. See Note [Always do CPR w/w]
; (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) <- mkWWcpr res_ty res_info
; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) <- mkWWcpr res_ty res_info
; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args all_one_shots cpr_res_ty
; return ([idDemandInfo v | v <- work_call_args, isId v],
wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) }
worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]
wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var
worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args
; if useful1 && not (only_one_void_argument) || useful2
then return (Just (worker_args_dmds, wrapper_body, worker_body))
else return Nothing
}
-- We use an INLINE unconditionally, even if the wrapper turns out to be
-- something trivial like
-- fw = ...
......@@ -144,6 +149,16 @@ mkWwBodies dflags fun_ty demands res_info one_shots
-- The point is to propagate the coerce to f's call sites, so even though
-- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
-- fw from being inlined into f's RHS
where
-- Note [Do not split void functions]
only_one_void_argument
| [d] <- demands
, Just (arg_ty1, _) <- splitFunTy_maybe fun_ty
, isAbsDmd d && isVoidTy arg_ty1
= True
| otherwise
= False
\end{code}
Note [Always do CPR w/w]
......@@ -358,7 +373,8 @@ That's why we carry the TvSubst through mkWWargs
mkWWstr :: DynFlags
-> [Var] -- Wrapper args; have their demand info on them
-- *Includes type variables*
-> UniqSM ([Var], -- Worker args
-> UniqSM (Bool, -- Is this useful
[Var], -- Worker args
CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
-- and without its lambdas
-- This fn adds the unboxing
......@@ -367,12 +383,12 @@ mkWWstr :: DynFlags
-- and lacking its lambdas.
-- This fn does the reboxing
mkWWstr _ []
= return ([], nop_fn, nop_fn)
= return (False, [], nop_fn, nop_fn)
mkWWstr dflags (arg : args) = do
(args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags arg
(args2, wrap_fn2, work_fn2) <- mkWWstr dflags args
return (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
(useful1, args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags arg
(useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags args
return (useful1 || useful2, args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
\end{code}
......@@ -405,29 +421,31 @@ as-yet-un-filled-in pkgState files.
\begin{code}
----------------------
-- mkWWstr_one wrap_arg = (work_args, wrap_fn, work_fn)
-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
-- * wrap_fn assumes wrap_arg is in scope,
-- brings into scope work_args (via cases)
-- * work_fn assumes work_args are in scope, a
-- brings into scope wrap_arg (via lets)
mkWWstr_one :: DynFlags -> Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one :: DynFlags -> Var -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one dflags arg
| isTyVar arg
= return ([arg], nop_fn, nop_fn)
= return (False, [arg], nop_fn, nop_fn)
-- See Note [Worker-wrapper for bottoming functions]
| isAbsDmd dmd
, Just work_fn <- mk_absent_let dflags arg
-- Absent case. We can't always handle absence for arbitrary
-- unlifted types, so we need to choose just the cases we can
--- (that's what mk_absent_let does)
= return ([], nop_fn, work_fn)
= return (True, [], nop_fn, work_fn)
-- See Note [Worthy functions for Worker-Wrapper split]
| isSeqDmd dmd -- `seq` demand; evaluate in wrapper in the hope
-- of dropping seqs in the worker
= let arg_w_unf = arg `setIdUnfolding` evaldUnfolding
-- Tell the worker arg that it's sure to be evaluated
-- so that internal seqs can be dropped
in return ([arg_w_unf], mk_seq_case arg, nop_fn)
in return (True, [arg_w_unf], mk_seq_case arg, nop_fn)
-- Pass the arg, anyway, even if it is in theory discarded
-- Consider
-- f x y = x `seq` y
......@@ -455,12 +473,12 @@ mkWWstr_one dflags arg
data_con unpk_args
rebox_fn = Let (NonRec arg con_app)
con_app = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
; (worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds
; return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds
; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
-- Don't pass the arg, rebox instead
| otherwise -- Other cases
= return ([arg], nop_fn, nop_fn)
= return (False, [arg], nop_fn, nop_fn)
where
dmd = idDemandInfo arg
......@@ -530,22 +548,23 @@ left-to-right traversal of the result structure.
\begin{code}
mkWWcpr :: Type -- function body type
-> DmdResult -- CPR analysis results
-> UniqSM (CoreExpr -> CoreExpr, -- New wrapper
CoreExpr -> CoreExpr, -- New worker
Type) -- Type of worker's body
-> UniqSM (Bool, -- Is w/w'ing useful?
CoreExpr -> CoreExpr, -- New wrapper
CoreExpr -> CoreExpr, -- New worker
Type) -- Type of worker's body
mkWWcpr body_ty res
= case returnsCPR_maybe res of
Nothing -> return (id, id, body_ty) -- No CPR info
Nothing -> return (False, id, id, body_ty) -- No CPR info
Just con_tag | Just stuff <- deepSplitCprType_maybe con_tag body_ty
-> mkWWcpr_help stuff
| otherwise
-- See Note [non-algebraic or open body type warning]
-> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
return (id, id, body_ty)
return (False, id, id, body_ty)
mkWWcpr_help :: (DataCon, [Type], [Type], Coercion)
-> UniqSM (CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWcpr_help (data_con, inst_tys, arg_tys, co)
| [arg_ty1] <- arg_tys
......@@ -558,7 +577,8 @@ mkWWcpr_help (data_con, inst_tys, arg_tys, co)
; let arg = mk_ww_local arg_uniq arg_ty1
con_app = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co
; return ( \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
; return ( True
, \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
, \ body -> mkUnpackCase body co work_uniq data_con [arg] (Var arg)
, arg_ty1 ) }
......@@ -572,7 +592,8 @@ mkWWcpr_help (data_con, inst_tys, arg_tys, co)
ubx_tup_app = mkConApp2 ubx_tup_con arg_tys args
con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co
; return ( \ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)]
; return (True
, \ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)]
, \ body -> mkUnpackCase body co work_uniq data_con args ubx_tup_app
, ubx_tup_ty ) }
......
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