X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FWorkWrap.lhs;h=64eba892738b01fd615b78ac70d3d77bd7c4a7f6;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=86f64371ca70952946d775be8e6090aba0d0783a;hpb=cae34044d89a87bd3da83b0e867b4a5d6994079a;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 86f6437..64eba89 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -9,22 +9,29 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where #include "HsVersions.h" import CoreSyn -import CoreUnfold ( Unfolding, certainlyWillInline ) -import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_worker_wrapper ) -import CoreLint ( beginPass, endPass ) -import CoreUtils ( exprType, exprEtaExpandArity ) -import MkId ( mkWorkerId ) -import Id ( Id, idType, idStrictness, idArity, isOneShotLambda, - setIdStrictness, idInlinePragma, - setIdWorkerInfo, idCprInfo, setInlinePragma ) -import Type ( Type, isNewType, splitForAllTys, splitFunTys ) -import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..), - CprInfo(..), exactArity, InlinePragInfo(..), isNeverInlinePrag, - WorkerInfo(..) +import CoreUnfold ( certainlyWillInline ) +import CoreLint ( showPass, endPass ) +import CoreUtils ( exprType, exprIsHNF ) +import Id ( Id, idType, isOneShotLambda, + setIdNewStrictness, mkWorkerId, + setIdWorkerInfo, setInlinePragma, + idInfo ) +import MkId ( lazyIdKey, lazyIdUnfolding ) +import Type ( Type ) +import IdInfo ( WorkerInfo(..), arityInfo, + newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo + ) +import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), + Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent ) -import Demand ( Demand, wwLazy ) import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) +import Unique ( hasKey ) +import BasicTypes ( RecFlag(..), isNonRec, Activation(..) ) +import VarEnv ( isEmptyVarEnv ) +import Maybes ( orElse ) +import DynFlags import WwLib +import Util ( lengthIs, notNull ) import Outputable \end{code} @@ -56,20 +63,21 @@ info for exported values). \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} @@ -99,20 +107,18 @@ wwBind :: CoreBind -- as appropriate. wwBind (NonRec binder rhs) - = wwExpr rhs `thenUs` \ new_rhs -> - tryWW True {- non-recursive -} binder new_rhs `thenUs` \ new_pairs -> + = wwExpr rhs `thenUs` \ new_rhs -> + tryWW NonRecursive binder new_rhs `thenUs` \ new_pairs -> returnUs [NonRec b e | (b,e) <- new_pairs] -- Generated bindings must be non-recursive -- because the original binding was. ------------------------------- - wwBind (Rec pairs) = mapUs do_one pairs `thenUs` \ new_pairs -> returnUs [Rec (concat new_pairs)] where do_one (binder, rhs) = wwExpr rhs `thenUs` \ new_rhs -> - tryWW False {- recursive -} binder new_rhs + tryWW Recursive binder new_rhs \end{code} @wwExpr@ basically just walks the tree, looking for appropriate @@ -123,9 +129,16 @@ matching by looking for strict arguments of the correct type. \begin{code} wwExpr :: CoreExpr -> UniqSM CoreExpr -wwExpr e@(Type _) = returnUs e -wwExpr e@(Var _) = returnUs e -wwExpr e@(Lit _) = returnUs e +wwExpr e@(Type _) = returnUs e +wwExpr e@(Lit _) = returnUs e +wwExpr e@(Note InlineMe expr) = returnUs e + -- Don't w/w inside InlineMe's + +wwExpr e@(Var v) + | v `hasKey` lazyIdKey = returnUs lazyIdUnfolding + | otherwise = returnUs e + -- Inline 'lazy' after strictness analysis + -- (but not inside InlineMe's) wwExpr (Lam binder expr) = wwExpr expr `thenUs` \ new_expr -> @@ -145,10 +158,10 @@ wwExpr (Let bind expr) wwExpr expr `thenUs` \ new_expr -> returnUs (mkLets intermediate_bind new_expr) -wwExpr (Case expr binder alts) +wwExpr (Case expr binder ty alts) = wwExpr expr `thenUs` \ new_expr -> mapUs ww_alt alts `thenUs` \ new_alts -> - returnUs (Case new_expr binder new_alts) + returnUs (Case new_expr binder ty new_alts) where ww_alt (con, binders, rhs) = wwExpr rhs `thenUs` \ new_rhs -> @@ -174,7 +187,7 @@ reason), then we don't w-w it. The only reason this is monadised is for the unique supply. \begin{code} -tryWW :: Bool -- True <=> a non-recursive binding +tryWW :: RecFlag -> Id -- The fn binder -> CoreExpr -- The bound rhs; its innards -- are already ww'd @@ -183,128 +196,88 @@ tryWW :: Bool -- True <=> a non-recursive binding -- the orig "wrapper" lives on); -- if two, then a worker and a -- wrapper. -tryWW non_rec fn_id rhs - | isNeverInlinePrag inline_prag || arity == 0 - = -- Don't split things that will never be inlined - returnUs [ (fn_id, rhs) ] - - | non_rec && not do_coerce_ww && certainlyWillInline fn_id +tryWW is_rec fn_id rhs + | isNonRec is_rec && certainlyWillInline unfolding -- 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. - -- - -- 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: - -- It's out of date because now 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 - -- g = \yz -> ... -- And g is strict - -- 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. - = returnUs [ (fn_id, rhs) ] - - | not (do_strict_ww || do_cpr_ww || do_coerce_ww) - = returnUs [ (fn_id, rhs) ] - - | otherwise -- Do w/w split - = mkWwBodies fun_ty arity wrap_dmds result_bot one_shots cpr_info `thenUs` \ (work_demands, wrap_fn, work_fn) -> - getUniqueUs `thenUs` \ work_uniq -> + -- + -- 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! + = returnUs [ (new_fn_id, rhs) ] + + | is_thunk && worthSplittingThunk maybe_fn_dmd res_info + = ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive + splitThunk new_fn_id rhs + + | is_fun && worthSplittingFun wrap_dmds res_info + = splitFun new_fn_id fn_info wrap_dmds res_info inline_prag rhs + + | otherwise + = returnUs [ (new_fn_id, rhs) ] + + where + fn_info = idInfo fn_id + maybe_fn_dmd = newDemandInfo fn_info + unfolding = unfoldingInfo fn_info + inline_prag = inlinePragInfo fn_info + + -- In practice it always will have a strictness + -- signature, even if it's a uninformative one + strict_sig = newStrictnessInfo fn_info `orElse` topSig + StrictSig (DmdType env wrap_dmds res_info) = strict_sig + + -- new_fn_id has the DmdEnv zapped. + -- (a) it is never used again + -- (b) it wastes space + -- (c) it becomes incorrect as things are cloned, because + -- we don't push the substitution into it + new_fn_id | isEmptyVarEnv env = fn_id + | otherwise = fn_id `setIdNewStrictness` + StrictSig (mkTopDmdType wrap_dmds res_info) + + is_fun = notNull wrap_dmds + is_thunk = not is_fun && not (exprIsHNF rhs) + +--------------------- +splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs + = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) + -- The arity should match the signature + mkWwBodies fun_ty wrap_dmds res_info one_shots `thenUs` \ (work_demands, wrap_fn, work_fn) -> + getUniqueUs `thenUs` \ work_uniq -> let - work_rhs = work_fn rhs - proto_work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) + work_rhs = work_fn rhs + work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) `setInlinePragma` inline_prag - - work_id | has_strictness = proto_work_id `setIdStrictness` mkStrictnessInfo (work_demands, result_bot) - | otherwise = proto_work_id + `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info) + -- Even though we may not be at top level, + -- it's ok to give it an empty DmdEnv wrap_rhs = wrap_fn work_id - wrap_id = fn_id `setIdStrictness` wrapper_strictness - `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 - -- (b) we want to pin on its revised strictness info - -- (c) we pin on its worker id + wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity + `setInlinePragma` AlwaysActive -- Zap any inline pragma; + -- Put it on the worker instead in returnUs ([(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 where fun_ty = idType fn_id - arity = idArity fn_id -- The arity is set by the simplifier using exprEtaExpandArity + + arity = arityInfo fn_info -- The arity is set by the simplifier using exprEtaExpandArity -- So it may be more than the number of top-level-visible lambdas - inline_prag = idInlinePragma fn_id - - strictness_info = idStrictness fn_id - has_strictness = case strictness_info of - StrictnessInfo _ _ -> True - NoStrictnessInfo -> False - (arg_demands, result_bot) = case strictness_info of - StrictnessInfo d r -> (d, r) - NoStrictnessInfo -> ([], False) - - wrap_dmds = setUnpackStrategy arg_demands - do_strict_ww = WARN( has_strictness && not result_bot && arity < length arg_demands && worthSplitting wrap_dmds result_bot, - text "Insufficient arity" <+> ppr fn_id <+> ppr arity <+> ppr arg_demands ) - (result_bot || arity >= length arg_demands) -- Only if there's enough visible arity - && -- (else strictness info isn't valid) - -- - worthSplitting wrap_dmds result_bot -- And it's useful - -- worthSplitting returns False for an empty list of demands, - -- and hence do_strict_ww is False if arity is zero - -- Also it's false if there is no strictness (arg_demands is []) - - wrapper_strictness | has_strictness = mkStrictnessInfo (wrap_dmds, result_bot) - | otherwise = noStrictnessInfo - - ------------------------------------------------------------- - cpr_info = idCprInfo fn_id - do_cpr_ww = arity > 0 && - case cpr_info of - ReturnsCPR -> True - other -> False - - ------------------------------------------------------------- - do_coerce_ww = check_for_coerce arity fun_ty - -- We are willing to do a w/w even if the arity is zero. - -- x = coerce t E - -- ==> - -- x' = E - -- x = coerce t x' - - ------------------------------------------------------------- - one_shots = get_one_shots rhs + work_res_info | isBotRes res_info = BotRes -- Cpr stuff done by wrapper + | otherwise = TopRes --- See if there's a Coerce before we run out of arity; --- if so, it's worth trying a w/w split. Reason: we find --- functions like f = coerce (\s -> e) --- and g = \x -> coerce (\s -> e) --- and they may have no useful strictness or cpr info, but if we --- do the w/w thing we get rid of the coerces. - -check_for_coerce arity ty - = length arg_tys <= arity && isNewType res_ty - -- Don't look further than arity args, - -- but if there are arity or fewer, see if there's - -- a newtype in the corner - where - (_, tau) = splitForAllTys ty - (arg_tys, res_ty) = splitFunTys tau + one_shots = get_one_shots rhs -- If the original function has one-shot arguments, it is important to -- make the wrapper and worker have corresponding one-shot arguments too. @@ -317,6 +290,95 @@ get_one_shots (Note _ e) = get_one_shots e get_one_shots other = noOneShotInfo \end{code} +Thunk splitting +~~~~~~~~~~~~~~~ +Suppose x is used strictly (never mind whether it has the CPR +property). + + let + x* = x-rhs + in body + +splitThunk transforms like this: + + let + x* = case x-rhs of { I# a -> I# a } + in body + +Now simplifier will transform to + + case x-rhs of + I# a -> let x* = I# b + in body + +which is what we want. Now suppose x-rhs is itself a case: + + x-rhs = case e of { T -> I# a; F -> I# b } + +The join point will abstract over a, rather than over (which is +what would have happened before) which is fine. + +Notice that x certainly has the CPR property now! + +In fact, splitThunk uses the function argument w/w splitting +function, so that if x's demand is deeper (say U(U(L,L),L)) +then the splitting will go deeper too. + +\begin{code} +-- splitThunk converts the *non-recursive* binding +-- x = e +-- into +-- x = let x = e +-- in case x of +-- I# y -> let x = I# y in x } +-- See comments above. Is it not beautifully short? + +splitThunk fn_id rhs + = mkWWstr [fn_id] `thenUs` \ (_, wrap_fn, work_fn) -> + returnUs [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] +\end{code} + + +%************************************************************************ +%* * +\subsection{Functions over Demands} +%* * +%************************************************************************ + +\begin{code} +worthSplittingFun :: [Demand] -> DmdResult -> Bool + -- True <=> the wrapper would not be an identity function +worthSplittingFun ds res + = any worth_it ds || returnsCPR res + -- worthSplitting returns False for an empty list of demands, + -- and hence do_strict_ww is False if arity is zero and there is no CPR + + -- We used not to split if the result is bottom. + -- [Justification: there's no efficiency to be gained.] + -- But it's sometimes bad not to make a wrapper. Consider + -- fw = \x# -> let x = I# x# in case e of + -- p1 -> error_fn x + -- p2 -> error_fn x + -- p3 -> the real stuff + -- The re-boxing code won't go away unless error_fn gets a wrapper too. + -- [We don't do reboxing now, but in general it's better to pass + -- an unboxed thing to f, and have it reboxed in the error cases....] + where + worth_it Abs = True -- Absent arg + worth_it (Eval (Prod ds)) = True -- Product arg to evaluate + worth_it other = False + +worthSplittingThunk :: Maybe Demand -- Demand on the thunk + -> DmdResult -- CPR info for the thunk + -> Bool +worthSplittingThunk maybe_dmd res + = worth_it maybe_dmd || returnsCPR res + where + -- Split if the thing is unpacked + worth_it (Just (Eval (Prod ds))) = not (all isAbsent ds) + worth_it other = False +\end{code} + %************************************************************************ @@ -330,17 +392,12 @@ the function and the name of its worker, and we want to make its body (the wrapp \begin{code} mkWrapper :: Type -- Wrapper type - -> Int -- Arity - -> [Demand] -- Wrapper strictness info - -> Bool -- Function returns bottom - -> CprInfo -- Wrapper cpr info + -> StrictSig -- Wrapper strictness info -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id -mkWrapper fun_ty arity demands res_bot cpr_info - = mkWwBodies fun_ty arity demands res_bot noOneShotInfo cpr_info `thenUs` \ (_, wrap_fn, _) -> +mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) + = mkWwBodies fun_ty demands res_info noOneShotInfo `thenUs` \ (_, wrap_fn, _) -> returnUs wrap_fn noOneShotInfo = repeat False \end{code} - -