X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fstranal%2FWorkWrap.lhs;h=5143eea08e4b5192801f65a7fc16e1970af62e26;hb=a26e1e3310f4c92196fe6b4d407f72f3c6824132;hp=3af7e2d7c543ed08ecbbbe4899e2e533621045b6;hpb=d634ffcd96c0a5e895e10cade5e32282e8de0735;p=ghc-hetmet.git diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index 3af7e2d..5143eea 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -4,30 +4,21 @@ \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 ) -import CoreLint ( showPass, endPass ) import CoreUtils ( exprType, exprIsHNF, exprArity ) +import Var import Id ( Id, idType, isOneShotLambda, setIdNewStrictness, mkWorkerId, setIdWorkerInfo, setInlinePragma, setIdArity, idInfo ) import MkId ( lazyIdKey, lazyIdUnfolding ) import Type ( Type ) -import IdInfo ( WorkerInfo(..), arityInfo, - newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo - ) +import IdInfo import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent ) @@ -36,10 +27,10 @@ import Unique ( hasKey ) import BasicTypes ( RecFlag(..), isNonRec, isNeverActive ) import VarEnv ( isEmptyVarEnv ) import Maybes ( orElse ) -import DynFlags import WwLib import Util ( lengthIs, notNull ) import Outputable +import MonadUtils \end{code} We take Core bindings whose binders have: @@ -69,30 +60,9 @@ info for exported values). \end{enumerate} \begin{code} +wwTopBinds :: UniqSupply -> [CoreBind] -> [CoreBind] -wwTopBinds :: DynFlags - -> UniqSupply - -> [CoreBind] - -> IO [CoreBind] - -wwTopBinds dflags us binds - = do { - 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 dflags "Worker Wrapper binds" - Opt_D_dump_worker_wrapper binds' - } -\end{code} - - -\begin{code} -workersAndWrappers :: UniqSupply -> [CoreBind] -> [CoreBind] - -workersAndWrappers us top_binds +wwTopBinds us top_binds = initUs_ us $ do top_binds' <- mapM wwBind top_binds return (concat top_binds') @@ -135,9 +105,9 @@ 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@(Note InlineMe expr) = 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) @@ -265,12 +235,15 @@ tryWW is_rec fn_id rhs is_thunk = not is_fun && not (exprIsHNF rhs) --------------------- +splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> InlinePragInfo -> Expr Var + -> UniqSM [(Id, CoreExpr)] 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) ) do + = 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 fun_ty wrap_dmds res_info one_shots - work_uniq <- getUniqueM - let + (work_demands, wrap_fn, work_fn) <- mkWwBodies 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) `setInlinePragma` inline_prag @@ -290,7 +263,7 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs wrap_rhs = wrap_fn work_id wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity - return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) + ; 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 where @@ -308,11 +281,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) - | isId b = isOneShotLambda b : get_one_shots e + | isIdVar 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 @@ -358,6 +332,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)))) ] @@ -380,8 +355,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 @@ -391,7 +366,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] @@ -427,5 +402,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}