%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
\begin{code}
-#include "HsVersions.h"
-
-module WorkWrap ( workersAndWrappers ) where
+module WorkWrap ( wwTopBinds, getWorkerId ) where
-IMPORT_Trace
-import Outputable
-import Pretty
+#include "HsVersions.h"
-import Id ( idType, addIdStrictness, getIdStrictness,
- getIdUnfolding, mkWorkerId,
- replaceIdInfo, getIdInfo, idWantsToBeINLINEd
+import CoreSyn
+import CoreUnfold ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance )
+import CmdLineOpts ( opt_UF_CreationThreshold , opt_D_verbose_core2core,
+ opt_D_dump_worker_wrapper
)
-import IdInfo -- bits and pieces
-import Maybes ( maybeToBool, Maybe(..) )
+import CoreLint ( beginPass, endPass )
+import CoreUtils ( coreExprType )
+import Const ( Con(..) )
+import DataCon ( DataCon )
+import MkId ( mkWorkerId )
+import Id ( Id, getIdStrictness, setIdArity,
+ setIdStrictness,
+ setIdWorkerInfo, getIdCprInfo )
+import VarSet
+import Type ( splitAlgTyConApp_maybe )
+import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
+ CprInfo(..), exactArity
+ )
+import Demand ( wwLazy )
import SaLib
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import Util
+import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
+import UniqSet
import WwLib
+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}
-workersAndWrappers :: [CoreBinding] -> WwM [CoreBinding]
-workersAndWrappers top_binds
- = mapWw (wwBind True{-top-level-}) top_binds `thenWw` \ top_binds2 ->
+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
+ = initUs_ us $
+ mapUs (wwBind True{-top-level-}) top_binds `thenUs` \ top_binds2 ->
let
top_binds3 = map make_top_binding top_binds2
in
- returnWw (concat top_binds3)
+ returnUs (concat top_binds3)
where
- make_top_binding :: WwBinding -> [CoreBinding]
+ make_top_binding :: WwBinding -> [CoreBind]
make_top_binding (WwLet binds) = binds
\end{code}
\begin{code}
wwBind :: Bool -- True <=> top-level binding
- -> CoreBinding
- -> WwM WwBinding -- returns a WwBinding intermediate form;
+ -> CoreBind
+ -> UniqSM WwBinding -- returns a WwBinding intermediate form;
-- the caller will convert to Expr/Binding,
-- as appropriate.
wwBind top_level (NonRec binder rhs)
- = wwExpr rhs `thenWw` \ new_rhs ->
- tryWW binder new_rhs `thenWw` \ new_pairs ->
- returnWw (WwLet [NonRec b e | (b,e) <- new_pairs])
+ = wwExpr rhs `thenUs` \ new_rhs ->
+ tryWW True {- non-recursive -} binder new_rhs `thenUs` \ new_pairs ->
+ returnUs (WwLet [NonRec b e | (b,e) <- new_pairs])
-- Generated bindings must be non-recursive
-- because the original binding was.
------------------------------
wwBind top_level (Rec pairs)
- = mapWw do_one pairs `thenWw` \ new_pairs ->
- returnWw (WwLet [Rec (concat new_pairs)])
+ = mapUs do_one pairs `thenUs` \ new_pairs ->
+ returnUs (WwLet [Rec (concat new_pairs)])
where
- do_one (binder, rhs) = wwExpr rhs `thenWw` \ new_rhs ->
- tryWW binder new_rhs
+ do_one (binder, rhs) = wwExpr rhs `thenUs` \ new_rhs ->
+ tryWW False {- recursive -} binder new_rhs
\end{code}
@wwExpr@ basically just walks the tree, looking for appropriate
???????????????? ToDo
\begin{code}
-wwExpr :: CoreExpr -> WwM CoreExpr
+wwExpr :: CoreExpr -> UniqSM CoreExpr
-wwExpr e@(Var _) = returnWw e
-wwExpr e@(Lit _) = returnWw e
-wwExpr e@(Con _ _ _) = returnWw e
-wwExpr e@(Prim _ _ _) = returnWw e
+wwExpr e@(Type _) = returnUs e
+wwExpr e@(Var _) = returnUs e
-wwExpr (Lam binders expr)
- = wwExpr expr `thenWw` \ new_expr ->
- returnWw (Lam binders new_expr)
+wwExpr e@(Con con args)
+ = mapUs wwExpr args `thenUs` \ args' ->
+ returnUs (Con con args')
-wwExpr (CoTyLam ty expr)
- = wwExpr expr `thenWw` \ new_expr ->
- returnWw (CoTyLam ty new_expr)
+wwExpr (Lam binder expr)
+ = wwExpr expr `thenUs` \ new_expr ->
+ returnUs (Lam binder new_expr)
-wwExpr (App e1 e2)
- = wwExpr e1 `thenWw` \ new_e1 ->
- returnWw (App new_e1 e2)
+wwExpr (App f a)
+ = wwExpr f `thenUs` \ new_f ->
+ wwExpr a `thenUs` \ new_a ->
+ returnUs (App new_f new_a)
-wwExpr (CoTyApp expr ty)
- = wwExpr expr `thenWw` \ new_expr ->
- returnWw (CoTyApp new_expr ty)
-
-wwExpr (SCC cc expr)
- = wwExpr expr `thenWw` \ new_expr ->
- returnWw (SCC cc new_expr)
+wwExpr (Note note expr)
+ = wwExpr expr `thenUs` \ new_expr ->
+ returnUs (Note note new_expr)
wwExpr (Let bind expr)
- = wwBind False{-not top-level-} bind `thenWw` \ intermediate_bind ->
- wwExpr expr `thenWw` \ new_expr ->
- returnWw (mash_ww_bind intermediate_bind new_expr)
+ = wwBind False{-not top-level-} bind `thenUs` \ intermediate_bind ->
+ wwExpr expr `thenUs` \ new_expr ->
+ returnUs (mash_ww_bind intermediate_bind new_expr)
where
- mash_ww_bind (WwLet binds) body = mkCoLetsNoUnboxed binds body
+ mash_ww_bind (WwLet binds) body = mkLets binds body
mash_ww_bind (WwCase case_fn) body = case_fn body
-wwExpr (Case expr alts)
- = wwExpr expr `thenWw` \ new_expr ->
- ww_alts alts `thenWw` \ new_alts ->
- returnWw (Case new_expr new_alts)
+wwExpr (Case expr binder alts)
+ = wwExpr expr `thenUs` \ new_expr ->
+ mapUs ww_alt alts `thenUs` \ new_alts ->
+ returnUs (Case new_expr binder new_alts)
where
- ww_alts (AlgAlts alts deflt)
- = mapWw ww_alg_alt alts `thenWw` \ new_alts ->
- ww_deflt deflt `thenWw` \ new_deflt ->
- returnWw (AlgAlts new_alts new_deflt)
-
- ww_alts (PrimAlts alts deflt)
- = mapWw ww_prim_alt alts `thenWw` \ new_alts ->
- ww_deflt deflt `thenWw` \ new_deflt ->
- returnWw (PrimAlts new_alts new_deflt)
-
- ww_alg_alt (con, binders, rhs)
- = wwExpr rhs `thenWw` \ new_rhs ->
- returnWw (con, binders, new_rhs)
-
- ww_prim_alt (lit, rhs)
- = wwExpr rhs `thenWw` \ new_rhs ->
- returnWw (lit, new_rhs)
-
- ww_deflt NoDefault
- = returnWw NoDefault
-
- ww_deflt (BindDefault binder rhs)
- = wwExpr rhs `thenWw` \ new_rhs ->
- returnWw (BindDefault binder new_rhs)
+ ww_alt (con, binders, rhs)
+ = wwExpr rhs `thenUs` \ new_rhs ->
+ returnUs (con, binders, new_rhs)
\end{code}
%************************************************************************
The only reason this is monadised is for the unique supply.
\begin{code}
-tryWW :: Id -- the fn binder
- -> CoreExpr -- the bound rhs; its innards
+tryWW :: Bool -- True <=> a non-recursive binding
+ -> Id -- The fn binder
+ -> CoreExpr -- The bound rhs; its innards
-- are already ww'd
- -> WwM [(Id, CoreExpr)] -- either *one* or *two* pairs;
+ -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs;
-- if one, then no worker (only
-- the orig "wrapper" lives on);
-- if two, then a worker and a
-- wrapper.
-tryWW fn_id rhs
- | idWantsToBeINLINEd fn_id
- -- No point in worker/wrappering something 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.
- = do_nothing
-
- | otherwise
- = case (getIdStrictness fn_id) of
-
- NoStrictnessInfo -> do_nothing
- BottomGuaranteed -> do_nothing
- StrictnessInfo [] _ -> do_nothing -- V weird (but possible?)
-
- StrictnessInfo args_info _ ->
- if not (indicatesWorker args_info) then
- do_nothing
- else
-
- -- OK, it looks as if a worker is worth a try
- let
- (uvars, tyvars, args, body) = digForLambdas rhs
- body_ty = coreExprType body
- in
- uniqSMtoWwM (mkWwBodies body_ty tyvars args args_info) `thenWw` \ result ->
- case result of
-
- Nothing -> -- Very peculiar. This can only happen if we hit an
- -- abstract type, which we shouldn't have since we've
- -- constructed the args_info in this module!
-
- -- False. We might hit the all-args-absent-and-the-
- -- body-is-unboxed case. A Nothing is legit. (WDP 94/10)
- do_nothing
-
- Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
-
- -- Terrific! It worked!
- getUniqueWw `thenWw` \ worker_uniq ->
- let
- worker_ty = worker_ty_w_hole body_ty
-
- worker_id = mkWorkerId worker_uniq fn_id worker_ty
- (noIdInfo `addInfo` worker_strictness)
-
- wrapper_rhs = wrapper_w_hole worker_id
- worker_rhs = worker_w_hole body
-
- revised_strictness_info
- = -- We know the basic strictness info already, but
- -- we need to slam in the exact identity of the
- -- worker Id:
- mkStrictnessInfo args_info (Just worker_id)
-
- wrapper_id = fn_id `replaceIdInfo`
- (getIdInfo fn_id `addInfo`
- revised_strictness_info `addInfo_UF`
- iWantToBeINLINEd UnfoldAlways)
- -- NB! the "iWantToBeINLINEd" part adds an INLINE pragma to
- -- the wrapper, which is of course what we want.
- in
- returnWw [ (worker_id, worker_rhs), -- worker comes first
- (wrapper_id, wrapper_rhs) ] -- because wrapper mentions it
+tryWW non_rec fn_id rhs
+ | (non_rec && -- Don't split if its non-recursive and small
+ certainlySmallEnoughToInline unfold_guidance
+ )
+ -- No point in worker/wrappering something 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.
+
+ || not (do_strict_ww || do_cpr_ww)
+ = returnUs [ (fn_id, rhs) ]
+
+ | otherwise -- Do w/w split
+ = mkWwBodies tyvars wrap_args
+ (coreExprType body)
+ wrap_demands
+ 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`
+ (if has_strictness_info then mkStrictnessInfo (work_demands ++ remaining_arg_demands, result_bot)
+ else noStrictnessInfo)
+
+ wrap_rhs = wrap_fn work_id
+ wrap_id = fn_id `setIdStrictness`
+ (if has_strictness_info then mkStrictnessInfo (wrap_demands ++ remaining_arg_demands, result_bot)
+ else noStrictnessInfo)
+ `setIdWorkerInfo` Just work_id
+ `setIdArity` exactArity (length wrap_args)
+ -- Add info to the wrapper:
+ -- (a) we want to inline it everywhere
+ -- (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
+ (tyvars, wrap_args, body) = collectTyAndValBinders rhs
+ n_wrap_args = length wrap_args
+
+ strictness_info = getIdStrictness fn_id
+ has_strictness_info = case strictness_info of
+ StrictnessInfo _ _ -> True
+ other -> False
+
+ StrictnessInfo arg_demands result_bot = strictness_info
+
+ -- NB: There maybe be more items in arg_demands than wrap_args, because
+ -- the strictness info is semantic and looks through InlineMe and Scc
+ -- Notes, whereas wrap_args does not
+ demands_for_visible_args = take n_wrap_args arg_demands
+ remaining_arg_demands = drop n_wrap_args arg_demands
+
+ wrap_demands | has_strictness_info = setUnpackStrategy demands_for_visible_args
+ | otherwise = repeat wwLazy
+
+ do_strict_ww = has_strictness_info && worthSplitting wrap_demands result_bot
+
+ 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_UF_CreationThreshold rhs
+
+-- This rather (nay! extremely!) crude function looks at a wrapper function, and
+-- snaffles out the worker Id from the wrapper.
+-- This is needed when we write an interface file.
+-- [May 1999: we used to get the constructors too, but that's no longer
+-- necessary, because the renamer hauls in all type decls in
+-- their fullness.]
+
+-- <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.
+getWorkerId :: Id -> CoreExpr -> Id
+getWorkerId wrap_id wrapper_fn
+ = work_id wrapper_fn
where
- do_nothing = returnWw [ (fn_id, rhs) ]
+
+ work_id wrapper_fn
+ = case get_work_id wrapper_fn of
+ [] -> case work_id_try2 wrapper_fn of
+ [] -> pprPanic "getWorkerId: can't find worker id" (ppr wrap_id)
+ [id] -> id
+ _ -> pprPanic "getWorkerId: found too many worker ids" (ppr wrap_id)
+ [id] -> id
+ _ -> pprPanic "getWorkerId: found too many worker ids" (ppr wrap_id)
+
+ get_work_id (Lam _ body) = get_work_id body
+ 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) = []
+ 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 = []
\end{code}
projects / ghc-hetmet.git / blobdiff