X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FWorkWrap.lhs;h=472cfd9f016535515411fdcaabdebb674b666337;hb=edd06d674dd5ffa05c08b6d75dd3a6b63b016f58;hp=bda7de10b176a8933742fcb0c1a44bbc4c806314;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index bda7de1..472cfd9 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -1,52 +1,97 @@ % -% (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} @@ -62,26 +107,26 @@ turn. Non-recursive case first, then recursive... \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 @@ -91,70 +136,44 @@ matching by looking for strict arguments of the correct type. ???????????????? 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} %************************************************************************ @@ -176,78 +195,122 @@ reason), then we don't w-w it. 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.] + +-- - 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}