\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
\begin{code}
-module WorkWrap ( workersAndWrappers, getWorkerIdAndCons ) where
+module WorkWrap ( wwTopBinds, getWorkerIdAndCons ) where
#include "HsVersions.h"
import CoreSyn
import CoreUnfold ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance )
-import CmdLineOpts ( opt_UnfoldingCreationThreshold )
-
+import CmdLineOpts ( opt_UnfoldingCreationThreshold, opt_D_verbose_core2core,
+ opt_D_dump_worker_wrapper )
+import CoreLint ( beginPass, endPass )
import CoreUtils ( coreExprType )
import Const ( Con(..) )
import DataCon ( DataCon )
import MkId ( mkWorkerId )
import Id ( Id, getIdStrictness,
setIdStrictness, setInlinePragma, idWantsToBeINLINEd,
- )
+ setIdWorkerInfo, getIdCprInfo )
import VarSet
import Type ( splitAlgTyConApp_maybe )
-import IdInfo ( mkStrictnessInfo, StrictnessInfo(..),
- InlinePragInfo(..) )
+import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
+ InlinePragInfo(..), CprInfo(..) )
+import Demand ( wwLazy )
import SaLib
import UniqSupply ( UniqSupply, initUs, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import UniqSet
import Outputable
\end{code}
-We take Core bindings whose binders have their strictness attached (by
-the front-end of the strictness analyser), and we return some
-``plain'' bindings which have been worker/wrapper-ified, meaning:
+We take Core bindings whose binders have:
+
\begin{enumerate}
-\item
-Functions have been split into workers and wrappers where appropriate;
-\item
-Binders' @IdInfos@ have been updated to reflect the existence
-of these workers/wrappers (this is where we get STRICTNESS pragma
+
+\item Strictness attached (by the front-end of the strictness
+analyser), and / or
+
+\item Constructed Product Result information attached by the CPR
+analysis pass.
+
+\end{enumerate}
+
+and we return some ``plain'' bindings which have been
+worker/wrapper-ified, meaning:
+
+\begin{enumerate}
+
+\item Functions have been split into workers and wrappers where
+appropriate. If a function has both strictness and CPR properties
+then only one worker/wrapper doing both transformations is produced;
+
+\item Binders' @IdInfos@ have been updated to reflect the existence of
+these workers/wrappers (this is where we get STRICTNESS and CPR pragma
info for exported values).
\end{enumerate}
\begin{code}
+
+wwTopBinds :: UniqSupply
+ -> [CoreBind]
+ -> IO [CoreBind]
+
+wwTopBinds us binds
+ = do {
+ beginPass "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'
+ }
+\end{code}
+
+
+\begin{code}
workersAndWrappers :: UniqSupply -> [CoreBind] -> [CoreBind]
workersAndWrappers us top_binds
-- twice, this test also prevents wrappers (which are INLINEd)
-- from being re-done.
- || not has_strictness_info
- || not (worthSplitting revised_wrap_args_info)
+ || not (do_strict_ww || do_cpr_ww)
= returnUs [ (fn_id, rhs) ]
| otherwise -- Do w/w split
in
mkWwBodies tyvars wrap_args
(coreExprType body)
- revised_wrap_args_info `thenUs` \ (wrap_fn, work_fn, work_demands) ->
+ revised_wrap_args_info
+ cpr_info
+ `thenUs` \ (wrap_fn, work_fn, work_demands) ->
getUniqueUs `thenUs` \ work_uniq ->
let
work_rhs = work_fn body
work_id = mkWorkerId work_uniq fn_id (coreExprType work_rhs) `setIdStrictness`
- mkStrictnessInfo (work_demands, result_bot) False
+ (if do_strict_ww then mkStrictnessInfo (work_demands, result_bot)
+ else noStrictnessInfo)
wrap_rhs = wrap_fn work_id
- wrap_id = fn_id `setIdStrictness` mkStrictnessInfo (revised_wrap_args_info, result_bot) True
+ wrap_id = fn_id `setIdStrictness`
+ (if do_strict_ww then mkStrictnessInfo (revised_wrap_args_info, result_bot)
+ else noStrictnessInfo)
+ `setIdWorkerInfo` (Just work_id)
`setInlinePragma` IWantToBeINLINEd
-- Add info to the wrapper:
-- (a) we want to inline it everywhere
- -- (b) we want to pin on its revised stricteness info
- -- (c) we pin on its worker id and the list of constructors mentioned in the wrapper
+ -- (b) we want to pin on its revised strictness info
+ -- (c) we pin on its worker id
in
returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
-- Worker first, because wrapper mentions it
where
strictness_info = getIdStrictness fn_id
has_strictness_info = case strictness_info of
- StrictnessInfo _ _ _ -> True
- other -> False
+ StrictnessInfo _ _ -> True
+ other -> False
- StrictnessInfo wrap_args_info result_bot _ = strictness_info
+ StrictnessInfo wrap_args_info result_bot = strictness_info
- revised_wrap_args_info = setUnpackStrategy wrap_args_info
+ revised_wrap_args_info = if has_strictness_info
+ then setUnpackStrategy wrap_args_info
+ else repeat wwLazy
+
+
+ -- If we are going to split for CPR purposes anyway, then
+ -- we may as well do the strictness transformation
+ do_strict_ww = has_strictness_info && (do_cpr_ww ||
+ worthSplitting revised_wrap_args_info)
+
+ cpr_info = getIdCprInfo fn_id
+ has_cpr_info = case cpr_info of
+ CPRInfo _ -> True
+ other -> False
+
+ do_cpr_ww = has_cpr_info
unfold_guidance = calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
-- snaffles out (a) the worker Id and (b) constructors needed to
-- make the wrapper.
-- These are needed when we write an interface file.
+
+-- <Mar 1999 (keving)> - Well, since the addition of the CPR transformation this function
+-- got too crude!
+-- Now the worker id is stored directly in the id's Info field. We still use this function to
+-- snaffle the wrapper's constructors but I don't trust the code to find the worker id.
getWorkerIdAndCons :: Id -> CoreExpr -> (Id, UniqSet DataCon)
getWorkerIdAndCons wrap_id wrapper_fn
- = (get_work_id wrapper_fn, get_cons wrapper_fn)
+ = (work_id wrapper_fn, get_cons wrapper_fn)
where
+
+ work_id wrapper_fn
+ = case get_work_id wrapper_fn of
+ [] -> case work_id_try2 wrapper_fn of
+ [] -> pprPanic "getWorkerIdAndCons: can't find worker id" (ppr wrap_id)
+ [id] -> id
+ _ -> pprPanic "getWorkerIdAndCons: found too many worker ids" (ppr wrap_id)
+ [id] -> id
+ _ -> pprPanic "getWorkerIdAndCons: found too many worker ids" (ppr wrap_id)
+
get_work_id (Lam _ body) = get_work_id body
- get_work_id (Case _ _ [(_,_,rhs)]) = get_work_id rhs
+ get_work_id (Case _ _ [(_,_,rhs@(Case _ _ _))]) = get_work_id rhs
+ get_work_id (Case scrut _ [(_,_,rhs)]) = (get_work_id scrut) ++ (get_work_id rhs)
get_work_id (Note _ body) = get_work_id body
get_work_id (Let _ body) = get_work_id body
+ get_work_id (App (Var work_id) _) = [work_id]
get_work_id (App fn _) = get_work_id fn
- get_work_id (Var work_id) = work_id
- get_work_id other = pprPanic "getWorkerIdAndCons" (ppr wrap_id)
-
+ get_work_id (Var work_id) = []
+ get_work_id other = []
+
+ work_id_try2 (Lam _ body) = work_id_try2 body
+ work_id_try2 (Note _ body) = work_id_try2 body
+ work_id_try2 (Let _ body) = work_id_try2 body
+ work_id_try2 (App fn _) = work_id_try2 fn
+ work_id_try2 (Var work_id) = [work_id]
+ work_id_try2 other = []
get_cons (Lam _ body) = get_cons body
get_cons (Let (NonRec _ rhs) body) = get_cons rhs `unionUniqSets` get_cons body
projects / ghc-hetmet.git / blobdiff