X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FWorkWrap.lhs;h=fbac09bc6c81b55d945074a068233ce5895970a4;hb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;hp=457cab22def0221cf39427b9d111478de73d0290;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 457cab2..fbac09b 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -4,27 +4,27 @@ \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} \begin{code} -#include "HsVersions.h" - -module WorkWrap ( workersAndWrappers ) where +module WorkWrap ( workersAndWrappers, getWorkerIdAndCons ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CoreSyn import CoreUnfold ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance ) import CmdLineOpts ( opt_UnfoldingCreationThreshold ) import CoreUtils ( coreExprType ) -import Id ( idWantsToBeINLINEd, getIdStrictness, mkWorkerId, +import Id ( getInlinePragma, getIdStrictness, mkWorkerId, addIdStrictness, addInlinePragma, - GenId + IdSet, emptyIdSet, addOneToIdSet, + GenId, Id ) import IdInfo ( noIdInfo, addUnfoldInfo, mkStrictnessInfo, addStrictnessInfo, StrictnessInfo(..) ) import SaLib -import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) ) +import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM ) import WwLib +import Outputable \end{code} We take Core bindings whose binders have their strictness attached (by @@ -175,8 +175,8 @@ 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 :: Id -- The fn binder + -> CoreExpr -- The bound rhs; its innards -- are already ww'd -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs; -- if one, then no worker (only @@ -184,60 +184,69 @@ tryWW :: Id -- the fn binder -- if two, then a worker and a -- wrapper. tryWW fn_id rhs - | certainlySmallEnoughToInline $ - calcUnfoldingGuidance (idWantsToBeINLINEd fn_id) + | (certainlySmallEnoughToInline $ + calcUnfoldingGuidance (getInlinePragma fn_id) opt_UnfoldingCreationThreshold rhs - -- 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 args_info _ -> - let - (uvars, tyvars, args, body) = collectBinders rhs - body_ty = coreExprType body - in - mkWwBodies body_ty tyvars args args_info `thenUs` \ result -> - case result of - - Nothing -> -- We've hit the all-args-absent-and-the-body-is-unboxed case, - -- or there are too many args for a w/w split, - -- or there's no benefit from w/w (e.g. SSS) - do_nothing - - Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) -> - - -- Terrific! It worked! - getUnique `thenUs` \ worker_uniq -> - let - worker_ty = worker_ty_w_hole body_ty - - worker_id = mkWorkerId worker_uniq fn_id worker_ty - (noIdInfo `addStrictnessInfo` 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 = addInlinePragma (fn_id `addIdStrictness` - revised_strictness_info) - -- NB the "addInlinePragma" part; we want to inline wrappers everywhere - in - returnUs [ (worker_id, worker_rhs), -- worker comes first - (wrapper_id, wrapper_rhs) ] -- because wrapper mentions it + ) + -- 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 has_strictness_info + || not (worthSplitting revised_wrap_args_info) + = returnUs [ (fn_id, rhs) ] + + | otherwise -- Do w/w split + = let + (tyvars, wrap_args, body) = collectBinders rhs + in + mkWwBodies tyvars wrap_args + (coreExprType body) + revised_wrap_args_info `thenUs` \ (wrap_fn, work_fn, work_demands) -> + getUnique `thenUs` \ work_uniq -> + let + work_rhs = work_fn body + work_id = mkWorkerId work_uniq fn_id (coreExprType work_rhs) work_info + work_info = noIdInfo `addStrictnessInfo` mkStrictnessInfo work_demands False + + wrap_rhs = wrap_fn work_id + wrap_id = addInlinePragma (fn_id `addIdStrictness` + mkStrictnessInfo revised_wrap_args_info True) + -- 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 + 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 + + wrap_args_info = case strictness_info of + StrictnessInfo args_info _ -> args_info + revised_wrap_args_info = setUnpackStrategy wrap_args_info + +-- This rather (nay! extremely!) crude function looks at a wrapper function, and +-- snaffles out (a) the worker Id and (b) constructors needed to +-- make the wrapper. +-- These are needed when we write an interface file. +getWorkerIdAndCons wrap_id wrapper_fn + = go wrapper_fn where - do_nothing = returnUs [ (fn_id, rhs) ] + go (Lam _ body) = go body + go (Case _ (AlgAlts [(con,_,rhs)] _)) = let (wrap_id, cons) = go rhs + in (wrap_id, cons `addOneToIdSet` con) + go (Let (NonRec _ (Coerce (CoerceOut con) _ _)) body) + = let (wrap_id, cons) = go body + in (wrap_id, cons `addOneToIdSet` con) + go other = (get_work_id other, emptyIdSet) + + 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) \end{code}