X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fstranal%2FWorkWrap.lhs;h=30754e5fe51abe8c4caf2d1a42bcd24ef7970607;hb=c0778bd3da61e80948e5813255ee82cdfebe0fdf;hp=6ddbbd8fa41f1c414df1bdf7ce409dde878b3799;hpb=d95ce839533391e7118257537044f01cbb1d6694;p=ghc-hetmet.git diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index 6ddbbd8..30754e5 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -4,34 +4,29 @@ \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module WorkWrap ( wwTopBinds, mkWrapper ) where #include "HsVersions.h" import CoreSyn -import CoreUnfold ( certainlyWillInline, mkWwInlineRule ) -import CoreLint ( showPass, endPass ) -import CoreUtils ( exprType, exprIsHNF, exprArity ) +import CoreUnfold ( certainlyWillInline ) +import CoreUtils ( exprType, exprIsHNF ) +import CoreArity ( exprArity ) +import Var import Id ( Id, idType, isOneShotLambda, setIdNewStrictness, mkWorkerId, - setInlinePragma, setIdUnfolding, setIdArity, idInfo ) + setIdWorkerInfo, setInlineActivation, + setIdArity, idInfo ) import MkId ( lazyIdKey, lazyIdUnfolding ) import Type ( Type ) -import IdInfo ( arityInfo, newDemandInfo, newStrictnessInfo, - unfoldingInfo, inlinePragInfo ) +import IdInfo import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent ) import UniqSupply import Unique ( hasKey ) -import BasicTypes ( RecFlag(..), isNonRec, isNeverActive ) +import BasicTypes ( RecFlag(..), isNonRec, isNeverActive, + Activation, inlinePragmaActivation ) import VarEnv ( isEmptyVarEnv ) import Maybes ( orElse ) import WwLib @@ -112,12 +107,16 @@ matching by looking for strict arguments of the correct type. \begin{code} wwExpr :: CoreExpr -> UniqSM CoreExpr -wwExpr e@(Type _) = return e -wwExpr e@(Lit _) = return e +wwExpr e@(Type _) = return e +wwExpr e@(Lit _) = return e +wwExpr e@(Note InlineMe _) = return e + -- Don't w/w inside InlineMe's + wwExpr e@(Var v) | v `hasKey` lazyIdKey = return lazyIdUnfolding | otherwise = return e -- HACK alert: Inline 'lazy' after strictness analysis + -- (but not inside InlineMe's) wwExpr (Lam binder expr) = Lam binder <$> wwExpr expr @@ -166,10 +165,7 @@ The only reason this is monadised is for the unique supply. Note [Don't w/w inline things] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's very important to refrain from w/w-ing an INLINE function -because the wrapepr will then overwrite the InlineRule unfolding. - -It was wrong with the old InlineMe Note too: if we do so by mistake -we transform +If we do so by mistake we transform f = __inline (\x -> E) into f = __inline (\x -> case x of (a,b) -> fw E) @@ -201,7 +197,7 @@ tryWW is_rec fn_id rhs | -- isNonRec is_rec && -- Now omitted: see Note [Don't w/w inline things] certainlyWillInline unfolding - || isNeverActive inline_prag + || isNeverActive inline_act -- No point in worker/wrappering if the thing is never inlined! -- Because the no-inline prag will prevent the wrapper ever -- being inlined at a call site. @@ -212,7 +208,7 @@ tryWW is_rec fn_id rhs 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 + = splitFun new_fn_id fn_info wrap_dmds res_info inline_act rhs | otherwise = return [ (new_fn_id, rhs) ] @@ -221,7 +217,7 @@ tryWW is_rec fn_id rhs fn_info = idInfo fn_id maybe_fn_dmd = newDemandInfo fn_info unfolding = unfoldingInfo fn_info - inline_prag = inlinePragInfo fn_info + inline_act = inlinePragmaActivation (inlinePragInfo fn_info) -- In practice it always will have a strictness -- signature, even if it's a uninformative one @@ -241,7 +237,9 @@ tryWW is_rec fn_id rhs is_thunk = not is_fun && not (exprIsHNF rhs) --------------------- -splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs +splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var + -> UniqSM [(Id, CoreExpr)] +splitFun fn_id fn_info wrap_dmds res_info inline_act 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 @@ -250,13 +248,14 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs ; let work_rhs = work_fn rhs work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) - `setInlinePragma` inline_prag - -- Any inline pragma (which sets when inlining is active) + `setInlineActivation` inline_act + -- Any inline activation (which sets when inlining is active) -- on the original function is duplicated on the worker and wrapper -- It *matters* that the pragma stays on the wrapper -- It seems sensible to have it on the worker too, although we -- can't think of a compelling reason. (In ptic, INLINE things are - -- not w/wd) + -- not w/wd). However, the RuleMatchInfo is not transferred since + -- it does not make sense for workers to be constructorlike. `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 @@ -265,7 +264,7 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs -- arity is consistent with the demand type goes through wrap_rhs = wrap_fn work_id - wrap_id = fn_id `setIdUnfolding` mkWwInlineRule wrap_rhs arity work_id + wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) }) -- Worker first, because wrapper mentions it @@ -285,11 +284,12 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs -- make the wrapper and worker have corresponding one-shot arguments too. -- Otherwise we spuriously float stuff out of case-expression join points, -- which is very annoying. +get_one_shots :: Expr Var -> [Bool] get_one_shots (Lam b e) - | isIdVar b = isOneShotLambda b : get_one_shots e + | isId b = isOneShotLambda b : get_one_shots e | otherwise = get_one_shots e get_one_shots (Note _ e) = get_one_shots e -get_one_shots other = noOneShotInfo +get_one_shots _ = noOneShotInfo \end{code} Thunk splitting @@ -335,6 +335,7 @@ then the splitting will go deeper too. -- I# y -> let x = I# y in x } -- See comments above. Is it not beautifully short? +splitThunk :: Var -> Expr Var -> UniqSM [(Var, Expr Var)] splitThunk fn_id rhs = do (_, wrap_fn, work_fn) <- mkWWstr [fn_id] return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] @@ -357,8 +358,8 @@ worthSplittingFun ds res -- See Note [Worker-wrapper for bottoming functions] where worth_it Abs = True -- Absent arg - worth_it (Eval (Prod ds)) = True -- Product arg to evaluate - worth_it other = False + worth_it (Eval (Prod _)) = True -- Product arg to evaluate + worth_it _ = False worthSplittingThunk :: Maybe Demand -- Demand on the thunk -> DmdResult -- CPR info for the thunk @@ -368,7 +369,7 @@ worthSplittingThunk maybe_dmd res where -- Split if the thing is unpacked worth_it (Just (Eval (Prod ds))) = not (all isAbsent ds) - worth_it other = False + worth_it _ = False \end{code} Note [Worker-wrapper for bottoming functions] @@ -404,5 +405,6 @@ mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) = do (_, wrap_fn, _) <- mkWwBodies fun_ty demands res_info noOneShotInfo return wrap_fn +noOneShotInfo :: [Bool] noOneShotInfo = repeat False \end{code}