X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FWorkWrap.lhs;h=276d8da52f580f9a444b8e00db3c4e3c7c8ee241;hb=0cf6f8c36250e64b5b2bdf0bd6ed10e71984becc;hp=331b62369afa2b36a96beca8c82624c36326c0f9;hpb=d3f613149e033256620ef26e713d67a0f896f0df;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 331b623..276d8da 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -11,19 +11,27 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where import CoreSyn import CoreUnfold ( certainlyWillInline ) import CoreLint ( showPass, endPass ) -import CoreUtils ( exprType ) -import Id ( Id, idType, idNewStrictness, idArity, isOneShotLambda, - setIdNewStrictness, zapIdNewStrictness, idInlinePragma, mkWorkerId, - setIdWorkerInfo, setInlinePragma ) +import CoreUtils ( exprType, exprIsValue ) +import Id ( Id, idType, isOneShotLambda, + setIdNewStrictness, mkWorkerId, + setIdWorkerInfo, setInlinePragma, + idInfo ) +import MkId ( lazyIdKey, lazyIdUnfolding ) import Type ( Type ) -import IdInfo ( InlinePragInfo(..), isNeverInlinePrag, WorkerInfo(..) ) +import IdInfo ( WorkerInfo(..), arityInfo, + newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo + ) import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), - mkTopDmdType, isBotRes, returnsCPR + Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent ) import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) -import BasicTypes ( RecFlag(..), isNonRec ) +import Unique ( hasKey ) +import BasicTypes ( RecFlag(..), isNonRec, Activation(..) ) +import VarEnv ( isEmptyVarEnv ) +import Maybes ( orElse ) import CmdLineOpts import WwLib +import Util ( lengthIs, notNull ) import Outputable \end{code} @@ -121,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 -> @@ -143,10 +158,12 @@ wwExpr (Let bind expr) wwExpr expr `thenUs` \ new_expr -> returnUs (mkLets intermediate_bind new_expr) -wwExpr (Case expr binder alts) +-- gaw 2004 +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) +-- gaw 2004 + returnUs (Case new_expr binder ty new_alts) where ww_alt (con, binders, rhs) = wwExpr rhs `thenUs` \ new_rhs -> @@ -182,29 +199,7 @@ tryWW :: RecFlag -- if two, then a worker and a -- wrapper. tryWW is_rec fn_id rhs - | isNeverInlinePrag inline_prag - -- Don't split NOINLINE things, because they will never be inlined - -- Furthermore, zap the strictess info in the Id. Why? Because - -- the NOINLINE says "don't expose any of the inner workings at the call - -- site" and the strictness is certainly an inner working. - -- - -- More concretely, the demand analyser discovers the following strictness - -- for unsafePerformIO: C(U(AV)) - -- But then consider - -- unsafePerformIO (\s -> let r = f x in - -- case writeIORef v r s of (# s1, _ #) -> - -- (# s1, r #) - -- The strictness analyser will find that the binding for r is strict, - -- (becuase of uPIO's strictness sig), and so it'll evaluate it before - -- doing the writeIORef. This actually makes tests/lib/should_run/memo002 - -- get a deadlock! - -- - -- Solution: don't expose the strictness of unsafePerformIO. - = returnUs [ (zapIdNewStrictness fn_id, rhs) ] - - | arity == 0 - -- Don't worker-wrapper thunks - || isNonRec is_rec && certainlyWillInline fn_id + | 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) @@ -218,12 +213,44 @@ tryWW is_rec fn_id rhs -- fw = \ab -> (__inline (\x -> E)) (a,b) -- and the original __inline now vanishes, so E is no longer -- inside its __inline wrapper. Death! Disaster! - || not (worthSplitting strict_sig) - -- Strictness info suggests not to w/w - = returnUs [ (fn_id, rhs) ] + = 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 - | otherwise -- Do w/w split! - = WARN( arity /= length wrap_dmds, ppr fn_id <+> (ppr arity $$ ppr strict_sig) ) + | 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 (exprIsValue 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 -> @@ -236,22 +263,19 @@ tryWW is_rec fn_id rhs -- it's ok to give it an empty DmdEnv wrap_rhs = wrap_fn work_id - wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity - `setInlinePragma` NoInlinePragInfo -- Zap any inline pragma; - -- Put it on the worker instead + 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 - -- So it may be more than the number of top-level-visible lambdas - inline_prag = idInlinePragma fn_id - strict_sig = idNewStrictness fn_id + 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 - StrictSig (DmdType _ wrap_dmds res_info) = strict_sig work_res_info | isBotRes res_info = BotRes -- Cpr stuff done by wrapper | otherwise = TopRes @@ -268,6 +292,54 @@ 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} + %************************************************************************ %* * @@ -276,12 +348,12 @@ get_one_shots other = noOneShotInfo %************************************************************************ \begin{code} -worthSplitting :: StrictSig -> Bool +worthSplittingFun :: [Demand] -> DmdResult -> Bool -- True <=> the wrapper would not be an identity function -worthSplitting (StrictSig (DmdType _ ds res)) +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 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.] @@ -294,9 +366,19 @@ worthSplitting (StrictSig (DmdType _ ds res)) -- [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 (Seq _ ds) = True -- Arg to evaluate - worth_it other = False + 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}