X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FFloatIn.lhs;h=ec02ec0f8307e703ae1c3e4bc4d6248674f8ecc6;hb=36e5ebd7a6f8620926a21532e089117e19197428;hp=25685333e6bf46a79c5bef2b9ab2313857764051;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 2568533..ec02ec0 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % %************************************************************************ %* * @@ -12,39 +12,42 @@ case, so that we don't allocate things, save them on the stack, and then discover that they aren't needed in the chosen branch. \begin{code} -#include "HsVersions.h" - -module FloatIn ( - floatInwards, - - -- and to make the interface self-sufficient... - CoreExpr, CoreBinding, Id, - PlainCoreProgram(..), PlainCoreExpr(..) - ) where +module FloatIn ( floatInwards ) where -import Pretty -- ToDo: debugging only - -import PlainCore -import AnnCoreSyn +#include "HsVersions.h" -import FreeVars -import UniqSet -import Util +import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) +import CoreSyn +import CoreUtils ( exprIsValue, exprIsDupable ) +import CoreLint ( showPass, endPass ) +import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf ) +import Id ( isOneShotLambda ) +import Var ( Id, idType, isTyVar ) +import Type ( isUnLiftedType ) +import VarSet +import Util ( zipEqual, zipWithEqual ) +import Outputable \end{code} Top-level interface function, @floatInwards@. Note that we do not actually float any bindings downwards from the top-level. \begin{code} -floatInwards :: [PlainCoreBinding] -> [PlainCoreBinding] - -floatInwards binds - = map fi_top_bind binds +floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind] + +floatInwards dflags binds + = do { + showPass dflags "Float inwards"; + let { binds' = map fi_top_bind binds }; + endPass dflags "Float inwards" Opt_D_verbose_core2core binds' + {- no specific flag for dumping float-in -} + } + where - fi_top_bind (CoNonRec binder rhs) - = CoNonRec binder (fiExpr [] (freeVars rhs)) - fi_top_bind (CoRec pairs) - = CoRec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ] + fi_top_bind (NonRec binder rhs) + = NonRec binder (fiExpr [] (freeVars rhs)) + fi_top_bind (Rec pairs) + = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ] \end{code} %************************************************************************ @@ -67,12 +70,12 @@ aggressive and do float inwards past lambdas. Actually we are not doing a proper full laziness (see below), which was another reason for not floating inwards past a lambda. -This can easily be fixed. -The problem is that we float lets outwards, -but there are a few expressions which are not -let bound, like case scrutinees and case alternatives. -After floating inwards the simplifier could decide to inline -the let and the laziness would be lost, e.g. +This can easily be fixed. The problem is that we float lets outwards, +but there are a few expressions which are not let bound, like case +scrutinees and case alternatives. After floating inwards the +simplifier could decide to inline the let and the laziness would be +lost, e.g. + \begin{verbatim} let a = expensive ==> \b -> case expensive of ... in \ b -> case a of ... @@ -118,88 +121,103 @@ the closure for a is not built. %************************************************************************ \begin{code} -type FreeVarsSet = UniqSet Id +type FreeVarsSet = IdSet -type FloatingBinds = [(PlainCoreBinding, FreeVarsSet)] - -- In dependency order (outermost first) +type FloatingBinds = [(CoreBind, FreeVarsSet)] + -- In reverse dependency order (innermost bindiner first) -- The FreeVarsSet is the free variables of the binding. In the case -- of recursive bindings, the set doesn't include the bound -- variables. -fiExpr :: FloatingBinds -- binds we're trying to drop +fiExpr :: FloatingBinds -- Binds we're trying to drop -- as far "inwards" as possible - -> CoreExprWithFVs -- input expr - -> PlainCoreExpr -- result + -> CoreExprWithFVs -- Input expr + -> CoreExpr -- Result -fiExpr to_drop (_,AnnCoVar v) = mkCoLets' to_drop (CoVar v) +fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) -fiExpr to_drop (_,AnnCoLit k) = mkCoLets' to_drop (CoLit k) +fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) + Type ty -fiExpr to_drop (_,AnnCoCon c tys atoms) - = mkCoLets' to_drop (CoCon c tys atoms) - -fiExpr to_drop (_,AnnCoPrim c tys atoms) - = mkCoLets' to_drop (CoPrim c tys atoms) +fiExpr to_drop (_, AnnLit lit) = Lit lit \end{code} -Here we are not floating inside lambda (type lambdas are OK): -\begin{code} -fiExpr to_drop (_,AnnCoLam binders body) - = mkCoLets' to_drop (mkCoLam binders (fiExpr [] body)) - -fiExpr to_drop (_,AnnCoTyLam tyvar body) - | whnf body - -- we do not float into type lambdas if they are followed by - -- a whnf (actually we check for lambdas and constructors). - -- The reason is that a let binding will get stuck - -- in between the type lambda and the whnf and the simplifier - -- does not know how to pull it back out from a type lambda. - -- Ex: - -- let v = ... - -- in let f = /\t -> \a -> ... - -- ==> - -- let f = /\t -> let v = ... in \a -> ... - -- which is bad as now f is an updatable closure (update PAP) - -- and has arity 0. This example comes from cichelli. - = mkCoLets' to_drop (CoTyLam tyvar (fiExpr [] body)) - | otherwise - = CoTyLam tyvar (fiExpr to_drop body) - where - whnf :: CoreExprWithFVs -> Bool - whnf (_,AnnCoLit _) = True - whnf (_,AnnCoCon _ _ _) = True - whnf (_,AnnCoLam _ _) = True - whnf (_,AnnCoTyLam _ e) = whnf e - whnf (_,AnnCoSCC _ e) = whnf e - whnf _ = False +Applications: we do float inside applications, mainly because we +need to get at all the arguments. The next simplifier run will +pull out any silly ones. +\begin{code} +fiExpr to_drop (_,AnnApp fun arg) + = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg)) + where + [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop \end{code} -Applications: we could float inside applications, but it's probably -not worth it (a purely practical choice, hunch- [not experience-] -based). +We are careful about lambdas: + +* We must be careful about floating inside inside a value lambda. + That risks losing laziness. + The float-out pass might rescue us, but then again it might not. + +* We must be careful about type lambdas too. At one time we did, and + there is no risk of duplicating work thereby, but we do need to be + careful. In particular, here is a bad case (it happened in the + cichelli benchmark: + let v = ... + in let f = /\t -> \a -> ... + ==> + let f = /\t -> let v = ... in \a -> ... + This is bad as now f is an updatable closure (update PAP) + and has arity 0. + +So we treat lambda in groups, using the following rule: + + Float inside a group of lambdas only if + they are all either type lambdas or one-shot lambdas. + + Otherwise drop all the bindings outside the group. + \begin{code} -fiExpr to_drop (_,AnnCoApp fun atom) - = mkCoLets' to_drop (CoApp (fiExpr [] fun) atom) +fiExpr to_drop (_, AnnLam b body) + = case collect [b] body of + (bndrs, real_body) + | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body) + | otherwise -> mkCoLets' to_drop (mkLams bndrs (fiExpr [] real_body)) + where + collect bs (_, AnnLam b body) = collect (b:bs) body + collect bs body = (reverse bs, body) -fiExpr to_drop (_,AnnCoTyApp expr ty) - = CoTyApp (fiExpr to_drop expr) ty + is_ok bndr = isTyVar bndr || isOneShotLambda bndr \end{code} We don't float lets inwards past an SCC. + ToDo: keep info on current cc, and when passing + one, if it is not the same, annotate all lets in binds with current + cc, change current cc to the new one and float binds into expr. -ToDo: CoSCC: {\em should} keep info on current cc, and when passing -one, if it is not the same, annotate all lets in binds with current -cc, change current cc to the new one and float binds into expr. \begin{code} -fiExpr to_drop (_, AnnCoSCC cc expr) - = mkCoLets' to_drop (CoSCC cc (fiExpr [] expr)) +fiExpr to_drop (_, AnnNote note@(SCC cc) expr) + = -- Wimp out for now + mkCoLets' to_drop (Note note (fiExpr [] expr)) + +fiExpr to_drop (_, AnnNote InlineCall expr) + = -- Wimp out for InlineCall; keep it close + -- the the call it annotates + mkCoLets' to_drop (Note InlineCall (fiExpr [] expr)) + +fiExpr to_drop (_, AnnNote InlineMe expr) + = -- Ditto... don't float anything into an INLINE expression + mkCoLets' to_drop (Note InlineMe (fiExpr [] expr)) + +fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr) + = -- Just float in past coercion + Note note (fiExpr to_drop expr) \end{code} -For @CoLets@, the possible ``drop points'' for the \tr{to_drop} -bindings are: (a)~in the body, (b1)~in the RHS of a CoNonRec binding, -or~(b2), in each of the RHSs of the pairs of a @CoRec@. +For @Lets@, the possible ``drop points'' for the \tr{to_drop} +bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding, +or~(b2), in each of the RHSs of the pairs of a @Rec@. Note that we do {\em weird things} with this let's binding. Consider: \begin{verbatim} @@ -207,12 +225,12 @@ let w = ... in { let v = ... w ... - in ... w ... + in ... v .. w ... } \end{verbatim} Look at the inner \tr{let}. As \tr{w} is used in both the bind and body of the inner let, we could panic and leave \tr{w}'s binding where -it is. But \tr{v} is floatable into the body of the inner let, and +it is. But \tr{v} is floatable further into the body of the inner let, and {\em then} \tr{w} will also be only in the body of that inner let. So: rather than drop \tr{w}'s binding here, we add it onto the list of @@ -220,97 +238,117 @@ things to drop in the outer let's body, and let nature take its course. \begin{code} -fiExpr to_drop (_,AnnCoLet (AnnCoNonRec id rhs) body) +fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) = fiExpr new_to_drop body where - rhs_fvs = freeVarsOf rhs body_fvs = freeVarsOf body - ([rhs_binds, body_binds], shared_binds) = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop + final_body_fvs | noFloatIntoRhs ann_rhs + || isUnLiftedType (idType id) = body_fvs `unionVarSet` rhs_fvs + | otherwise = body_fvs + -- See commments with letrec below + -- No point in floating in only to float straight out again + -- Ditto ok-for-speculation unlifted RHSs + + [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint False [rhs_fvs, final_body_fvs] to_drop new_to_drop = body_binds ++ -- the bindings used only in the body - [(CoNonRec id rhs', rhs_fvs')] ++ -- the new binding itself - shared_binds -- the bindings used both in rhs and body + [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself + shared_binds -- the bindings used both in rhs and body -- Push rhs_binds into the right hand side of the binding rhs' = fiExpr rhs_binds rhs - rhs_fvs' = rhs_fvs `unionUniqSets` (floatedBindsFVs rhs_binds) + rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds -fiExpr to_drop (_,AnnCoLet (AnnCoRec bindings) body) +fiExpr to_drop (_,AnnLet (AnnRec bindings) body) = fiExpr new_to_drop body where - (binders, rhss) = unzip bindings + rhss = map snd bindings rhss_fvs = map freeVarsOf rhss body_fvs = freeVarsOf body - (body_binds:rhss_binds, shared_binds) - = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop + -- Add to body_fvs the free vars of any RHS that has + -- a lambda at the top. This has the effect of making it seem + -- that such things are used in the body as well, and hence prevents + -- them getting floated in. The big idea is to avoid turning: + -- let x# = y# +# 1# + -- in + -- letrec f = \z. ...x#...f... + -- in ... + -- into + -- letrec f = let x# = y# +# 1# in \z. ...x#...f... in ... + -- + -- Because now we can't float the let out again, because a letrec + -- can't have unboxed bindings. + + final_body_fvs = foldr (unionVarSet . get_extras) body_fvs rhss + get_extras (rhs_fvs, rhs) | noFloatIntoRhs rhs = rhs_fvs + | otherwise = emptyVarSet + + (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint False (final_body_fvs:rhss_fvs) to_drop new_to_drop = -- the bindings used only in the body - body_binds ++ - -- the new binding itself - [(CoRec (fi_bind rhss_binds bindings), rhs_fvs')] ++ - -- the bindings used both in rhs and body or in more than one rhs - shared_binds + body_binds ++ + -- the new binding itself + [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++ + -- the bindings used both in rhs and body or in more than one rhs + shared_binds - rhs_fvs' = unionUniqSets (unionManyUniqSets rhss_fvs) - (unionManyUniqSets (map floatedBindsFVs rhss_binds)) + rhs_fvs' = unionVarSet (unionVarSets rhss_fvs) + (unionVarSets (map floatedBindsFVs rhss_binds)) -- Push rhs_binds into the right hand side of the binding fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss -> [(Id, CoreExprWithFVs)] - -> [(Id, PlainCoreExpr)] + -> [(Id, CoreExpr)] fi_bind to_drops pairs - = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zip pairs to_drops ] + = [ (binder, fiExpr to_drop rhs) + | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] \end{code} -For @CoCase@, the possible ``drop points'' for the \tr{to_drop} +For @Case@, the possible ``drop points'' for the \tr{to_drop} bindings are: (a)~inside the scrutinee, (b)~inside one of the alternatives/default [default FVs always {\em first}!]. \begin{code} -fiExpr to_drop (_, AnnCoCase scrut alts) - = let - fvs_scrut = freeVarsOf scrut - drop_pts_fvs = fvs_scrut : (get_fvs_from_deflt_and_alts alts) - in - case (sepBindsByDropPoint drop_pts_fvs to_drop) - of (scrut_drops : deflt_drops : alts_drops, drop_here) -> - mkCoLets' drop_here (CoCase (fiExpr scrut_drops scrut) - (fi_alts deflt_drops alts_drops alts)) - +fiExpr to_drop (_, AnnCase scrut case_bndr alts) + = mkCoLets' drop_here1 $ + mkCoLets' drop_here2 $ + Case (fiExpr scrut_drops scrut) case_bndr + (zipWith fi_alt alts_drops_s alts) where - ---------------------------- - -- pin default FVs on first! - -- - get_fvs_from_deflt_and_alts (AnnCoAlgAlts alts deflt) - = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, _, rhs) <- alts ] - - get_fvs_from_deflt_and_alts (AnnCoPrimAlts alts deflt) - = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, rhs) <- alts] - - get_deflt_fvs AnnCoNoDefault = emptyUniqSet - get_deflt_fvs (AnnCoBindDefault b rhs) = freeVarsOf rhs - - ---------------------------- - fi_alts to_drop_deflt to_drop_alts (AnnCoAlgAlts alts deflt) - = CoAlgAlts - [ (con, params, fiExpr to_drop rhs) - | ((con, params, rhs), to_drop) <- alts `zip` to_drop_alts ] - (fi_default to_drop_deflt deflt) - - fi_alts to_drop_deflt to_drop_alts (AnnCoPrimAlts alts deflt) - = CoPrimAlts - [ (lit, fiExpr to_drop rhs) - | ((lit, rhs), to_drop) <- alts `zip` to_drop_alts ] - (fi_default to_drop_deflt deflt) - - fi_default to_drop AnnCoNoDefault = CoNoDefault - fi_default to_drop (AnnCoBindDefault b e) = CoBindDefault b (fiExpr to_drop e) + -- Float into the scrut and alts-considered-together just like App + [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop + + -- Float into the alts with the is_case flag set + (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops + + scrut_fvs = freeVarsOf scrut + alts_fvs = map alt_fvs alts + all_alts_fvs = unionVarSets alts_fvs + alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args) + -- Delete case_bndr and args from free vars of rhs + -- to get free vars of alt + + fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs) + +noFloatIntoRhs (AnnNote InlineMe _) = True +noFloatIntoRhs (AnnLam b _) = not (isId b && isOneShotLambda b) + -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top. + -- This makes a big difference for things like + -- f x# = let x = I# x# + -- in let j = \() -> ...x... + -- in if then normal-path else j () + -- If x is used only in the error case join point, j, we must float the + -- boxing constructor into it, else we box it every time which is very bad + -- news indeed. + +noFloatIntoRhs rhs = exprIsValue (deAnnotate' rhs) -- We'd just float rigt back out again... \end{code} + %************************************************************************ %* * \subsection{@sepBindsByDropPoint@} @@ -334,57 +372,81 @@ We have to maintain the order on these drop-point-related lists. \begin{code} sepBindsByDropPoint - :: [FreeVarsSet] -- one set of FVs per drop point - -> FloatingBinds -- candidate floaters - -> ([FloatingBinds], -- floaters that *can* be floated into - -- the corresponding drop point - FloatingBinds) -- everything else, bindings which must - -- not be floated inside any drop point - -sepBindsByDropPoint drop_pts [] - = ([[] | p <- drop_pts], []) -- cut to the chase scene; it happens - -sepBindsByDropPoint drop_pts floaters - = let - (per_drop_pt, must_stay_here, _) - --= sep drop_pts emptyUniqSet{-fvs of prev drop_pts-} floaters - = split' drop_pts floaters [] empty_boxes - empty_boxes = take (length drop_pts) (repeat []) - - in - (map reverse per_drop_pt, reverse must_stay_here) + :: Bool -- True <=> is case expression + -> [FreeVarsSet] -- One set of FVs per drop point + -> FloatingBinds -- Candidate floaters + -> [FloatingBinds] -- FIRST one is bindings which must not be floated + -- inside any drop point; the rest correspond + -- one-to-one with the input list of FV sets + +-- Every input floater is returned somewhere in the result; +-- none are dropped, not even ones which don't seem to be +-- free in *any* of the drop-point fvs. Why? Because, for example, +-- a binding (let x = E in B) might have a specialised version of +-- x (say x') stored inside x, but x' isn't free in E or B. + +type DropBox = (FreeVarsSet, FloatingBinds) + +sepBindsByDropPoint is_case drop_pts [] + = [] : [[] | p <- drop_pts] -- cut to the chase scene; it happens + +sepBindsByDropPoint is_case drop_pts floaters + = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts)) where - split' drop_pts_fvs [] mult_branch drop_boxes - = (drop_boxes, mult_branch, drop_pts_fvs) - - -- only in a or unused - split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes) - | all (\b -> {-b `elementOfUniqSet` a &&-} - not (b `elementOfUniqSet` (unionManyUniqSets as))) - (bindersOf (fst bind)) - = split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes) - where - a' = a `unionUniqSets` fvsOfBind bind - - -- not in a - split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes) - | all (\b -> not (b `elementOfUniqSet` a)) (bindersOf (fst bind)) - = split' (a:as') binds mult_branch' (drop_box_a:drop_boxes') - where - (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes - - -- in a and in as - split' aas@(a:as) (bind:binds) mult_branch drop_boxes - = split' aas' binds (bind : mult_branch) drop_boxes - where - aas' = map (unionUniqSets (fvsOfBind bind)) aas - - ------------------------- - fvsOfBind (_,fvs) = fvs - ---floatedBindsFVs :: -floatedBindsFVs binds = foldr unionUniqSets emptyUniqSet (map snd binds) - ---mkCoLets' :: [FloatingBinds] -> PlainCoreExpr -> PlainCoreExpr -mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e + go :: FloatingBinds -> [DropBox] -> [FloatingBinds] + -- The *first* one in the argument list is the drop_here set + -- The FloatingBinds in the lists are in the reverse of + -- the normal FloatingBinds order; that is, they are the right way round! + + go [] drop_boxes = map (reverse . snd) drop_boxes + + go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes) + = go binds new_boxes + where + -- "here" means the group of bindings dropped at the top of the fork + + (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind) + | (fvs, drops) <- drop_boxes] + + drop_here = used_here || not can_push + + -- For case expressions we duplicate the binding if it is + -- reasonably small, and if it is not used in all the RHSs + -- This is good for situations like + -- let x = I# y in + -- case e of + -- C -> error x + -- D -> error x + -- E -> ...not mentioning x... + + n_alts = length used_in_flags + n_used_alts = length [() | True <- used_in_flags] + + can_push = n_used_alts == 1 -- Used in just one branch + || (is_case && -- We are looking at case alternatives + n_used_alts > 1 && -- It's used in more than one + n_used_alts < n_alts && -- ...but not all + bindIsDupable bind) -- and we can duplicate the binding + + new_boxes | drop_here = (insert here_box : fork_boxes) + | otherwise = (here_box : new_fork_boxes) + + new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags + + insert :: DropBox -> DropBox + insert (fvs,drops) = (fvs `unionVarSet` bind_fvs, bind_w_fvs:drops) + + insert_maybe box True = insert box + insert_maybe box False = box + + +floatedBindsFVs :: FloatingBinds -> FreeVarsSet +floatedBindsFVs binds = unionVarSets (map snd binds) + +mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr +mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop + -- Remember to_drop is in *reverse* dependency order + +bindIsDupable (Rec prs) = all (exprIsDupable . snd) prs +bindIsDupable (NonRec b r) = exprIsDupable r \end{code}