#include "HsVersions.h"
import CoreSyn
-import CoreUnfold ( Unfolding, certainlyWillInline )
-import CmdLineOpts ( opt_UF_CreationThreshold , opt_D_verbose_core2core,
- opt_D_dump_worker_wrapper
- )
-import CoreLint ( beginPass, endPass )
-import CoreUtils ( exprType, exprArity, exprEtaExpandArity )
-import DataCon ( DataCon )
-import MkId ( mkWorkerId )
-import Id ( Id, idType, idStrictness, setIdArityInfo, isOneShotLambda,
- setIdStrictness, idInlinePragma,
+import CoreUnfold ( certainlyWillInline )
+import CoreLint ( showPass, endPass )
+import CoreUtils ( exprType )
+import Id ( Id, idType, idStrictness, idArity, isOneShotLambda,
+ setIdStrictness, idInlinePragma, mkWorkerId,
setIdWorkerInfo, idCprInfo, setInlinePragma )
-import VarSet
import Type ( Type, isNewType, splitForAllTys, splitFunTys )
import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
- CprInfo(..), exactArity, InlinePragInfo(..), isNeverInlinePrag,
+ CprInfo(..), InlinePragInfo(..), isNeverInlinePrag,
WorkerInfo(..)
)
-import Demand ( Demand, wwLazy )
-import SaLib
+import Demand ( Demand )
import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
-import UniqSet
+import CmdLineOpts
import WwLib
import Outputable
\end{code}
\begin{code}
-wwTopBinds :: UniqSupply
- -> [CoreBind]
- -> IO [CoreBind]
+wwTopBinds :: DynFlags
+ -> UniqSupply
+ -> [CoreBind]
+ -> IO [CoreBind]
-wwTopBinds us binds
+wwTopBinds dflags us binds
= do {
- beginPass "Worker Wrapper binds";
+ showPass dflags "Worker Wrapper binds";
-- Create worker/wrappers, and mark binders with their
-- "strictness info" [which encodes their worker/wrapper-ness]
let { binds' = workersAndWrappers us binds };
- endPass "Worker Wrapper binds" (opt_D_dump_worker_wrapper ||
- opt_D_verbose_core2core) binds'
+ endPass dflags "Worker Wrapper binds"
+ Opt_D_dump_worker_wrapper binds'
}
\end{code}
-- if two, then a worker and a
-- wrapper.
tryWW non_rec fn_id rhs
- | not (isNeverInlinePrag inline_prag)
+ | isNeverInlinePrag inline_prag || arity == 0
= -- Don't split things that will never be inlined
returnUs [ (fn_id, rhs) ]
| non_rec && certainlyWillInline fn_id
- -- No point in worker/wrappering something that is going to be
+ -- No point in worker/wrappering a function that is going to be
-- INLINEd wholesale anyway. If the strictness analyser is run
-- twice, this test also prevents wrappers (which are INLINEd)
-- from being re-done.
+ --
+ -- It's very important to refrain from w/w-ing an INLINE function
+ -- If we do so by mistake we transform
+ -- f = __inline (\x -> E)
+ -- into
+ -- f = __inline (\x -> case x of (a,b) -> fw E)
+ -- fw = \ab -> (__inline (\x -> E)) (a,b)
+ -- and the original __inline now vanishes, so E is no longer
+ -- inside its __inline wrapper. Death! Disaster!
+ --
+ -- OUT OF DATE NOTE:
+ -- [There used to be "&& not do_coerce_ww" in the above test.
+ -- No longer necessary because SimplUtils.tryEtaExpansion
+ -- now deals with coerces.]
+ -- The do_coerce_ww test is so that
+ -- a function with a coerce should w/w to get rid
+ -- of the coerces, which can significantly improve its arity.
+ -- Example: f [] = return [] :: IO [Int]
+ -- f (x:xs) = return (x:xs)
+ -- If we aren't careful we end up with
+ -- f = \ x -> case x of {
+ -- x:xs -> __coerce (IO [Int]) (\ s -> (# s, x:xs #)
+ -- [] -> lvl_sJ8
--
- -- OUT OF DATE NOTE, kept for info:
+ -- OUT OF DATE NOTE:
+ -- [Out of date because the size calculation in CoreUnfold now
+ -- makes wrappers look very cheap even when they are inlined.]
-- In this case we add an INLINE pragma to the RHS. Why?
-- Because consider
-- f = \x -> g x x
-- Then f is small, so we don't w/w it. But g is big, and we do, so
-- g's wrapper will get inlined in f's RHS, which makes f look big now.
-- So f doesn't get inlined, but it is strict and we have failed to w/w it.
- -- It's out of date because now wrappers look very cheap
- -- even when they are inlined.
= returnUs [ (fn_id, rhs) ]
| not (do_strict_ww || do_cpr_ww || do_coerce_ww)
work_id | has_strictness = proto_work_id `setIdStrictness` mkStrictnessInfo (work_demands, result_bot)
| otherwise = proto_work_id
- wrap_arity = exprArity wrap_rhs -- Might be greater than the current visible arity
- -- if the function returns bottom
-
wrap_rhs = wrap_fn work_id
wrap_id = fn_id `setIdStrictness` wrapper_strictness
- `setIdWorkerInfo` HasWorker work_id wrap_arity
- `setIdArityInfo` exactArity wrap_arity
+ `setIdWorkerInfo` HasWorker work_id arity
`setInlinePragma` NoInlinePragInfo -- Put it on the worker instead
-- Add info to the wrapper:
-- (a) we want to set its arity
in
returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
-- Worker first, because wrapper mentions it
- -- Arrange to inline the wrapper unconditionally
+ -- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it
where
fun_ty = idType fn_id
- arity = exprEtaExpandArity rhs
+ arity = idArity fn_id -- The arity is set by the simplifier using exprEtaExpandArity
+ -- So it may be more than the number of top-level-visible lambdas
- -- Don't split something which is marked unconditionally NOINLINE
inline_prag = idInlinePragma fn_id
strictness_info = idStrictness fn_id