X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FFloatIn.lhs;h=0e8edb5930b314921725f7fed3b80256061863d0;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=877304dfe3295e386cf72e0f5a14235d5f8942c0;hpb=2c8f04b5b883db74f449dfc8c224929fe28b027d;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 877304d..0e8edb5 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-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % %************************************************************************ %* * @@ -16,24 +16,33 @@ module FloatIn ( floatInwards ) where #include "HsVersions.h" -import AnnCoreSyn +import DynFlags ( DynFlags, DynFlag(..) ) import CoreSyn - -import FreeVars -import Id ( emptyIdSet, unionIdSets, unionManyIdSets, - elementOfIdSet, IdSet, GenId, Id - ) -import Util ( nOfThem, panic, zipEqual ) +import CoreUtils ( exprIsHNF, exprIsDupable ) +import CoreLint ( showPass, endPass ) +import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf ) +import Id ( isOneShotBndr ) +import Var ( Id, idType ) +import Type ( isUnLiftedType ) +import VarSet +import Util ( zipEqual, zipWithEqual, count ) +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 :: [CoreBinding] -> [CoreBinding] - -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 (NonRec binder rhs) = NonRec binder (fiExpr [] (freeVars rhs)) @@ -61,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 ... @@ -114,83 +123,89 @@ the closure for a is not built. \begin{code} type FreeVarsSet = IdSet -type FloatingBinds = [(CoreBinding, 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 - -> CoreExpr -- result + -> CoreExprWithFVs -- Input expr + -> CoreExpr -- Result -fiExpr to_drop (_,AnnVar v) = mkCoLets' to_drop (Var v) +fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) -fiExpr to_drop (_,AnnLit k) = mkCoLets' to_drop (Lit k) +fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) + Type ty -fiExpr to_drop (_,AnnCon c atoms) - = mkCoLets' to_drop (Con c atoms) - -fiExpr to_drop (_,AnnPrim c atoms) - = mkCoLets' to_drop (Prim c atoms) +fiExpr to_drop (_, AnnLit lit) = Lit lit \end{code} -Here we are not floating inside lambda (type lambdas are OK): +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 (_,AnnLam b@(ValBinder binder) body) - = mkCoLets' to_drop (Lam b (fiExpr [] body)) - -fiExpr to_drop (_,AnnLam b@(TyBinder 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 (Lam b (fiExpr [] body)) - | otherwise - = Lam b (fiExpr to_drop body) +fiExpr to_drop (_,AnnApp fun arg) + = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg)) where - whnf :: CoreExprWithFVs -> Bool - - whnf (_,AnnLit _) = True - whnf (_,AnnCon _ _) = True - whnf (_,AnnLam x e) = if isValBinder x then True else whnf e - whnf (_,AnnNote _ e) = whnf e - whnf _ = False + [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 (_,AnnApp fun arg) - | isValArg arg - = mkCoLets' to_drop (App (fiExpr [] fun) arg) - | otherwise - = App (fiExpr to_drop fun) arg + -- Hack alert! We only float in through one-shot lambdas, + -- not (as you might guess) through big lambdas. + -- Reason: we float *out* past big lambdas (see the test in the Lam + -- case of FloatOut.floatExpr) and we don't want to float straight + -- back in again. + -- + -- It *is* important to float into one-shot lambdas, however; + -- see the remarks with noFloatIntoRhs. +fiExpr to_drop lam@(_, AnnLam _ _) + | all is_one_shot bndrs -- Float in + = mkLams bndrs (fiExpr to_drop body) + + | otherwise -- Dump it all here + = mkCoLets' to_drop (mkLams bndrs (fiExpr [] body)) + + where + (bndrs, body) = collectAnnBndrs lam \end{code} We don't float lets inwards past an SCC. - -ToDo: SCC: {\em should} + 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. \begin{code} fiExpr to_drop (_, AnnNote note@(SCC cc) expr) = -- Wimp out for now - -- 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. mkCoLets' to_drop (Note note (fiExpr [] expr)) fiExpr to_drop (_, AnnNote InlineCall expr) @@ -198,9 +213,16 @@ fiExpr to_drop (_, AnnNote InlineCall expr) -- 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) + +fiExpr to_drop (_, AnnNote note@(CoreNote _) expr) + = Note note (fiExpr to_drop expr) \end{code} For @Lets@, the possible ``drop points'' for the \tr{to_drop} @@ -213,12 +235,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 @@ -226,13 +248,19 @@ things to drop in the outer let's body, and let nature take its course. \begin{code} -fiExpr to_drop (_,AnnLet (AnnNonRec 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 [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself @@ -240,18 +268,35 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs) body) -- Push rhs_binds into the right hand side of the binding rhs' = fiExpr rhs_binds rhs - rhs_fvs' = rhs_fvs `unionIdSets` floatedBindsFVs rhs_binds + rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds 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 ++ @@ -260,8 +305,8 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) -- the bindings used both in rhs and body or in more than one rhs shared_binds - rhs_fvs' = unionIdSets (unionManyIdSets rhss_fvs) - (unionManyIdSets (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 @@ -269,7 +314,8 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) -> [(Id, CoreExpr)] fi_bind to_drops pairs - = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] + = [ (binder, fiExpr to_drop rhs) + | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] \end{code} For @Case@, the possible ``drop points'' for the \tr{to_drop} @@ -277,46 +323,44 @@ bindings are: (a)~inside the scrutinee, (b)~inside one of the alternatives/default [default FVs always {\em first}!]. \begin{code} -fiExpr to_drop (_, AnnCase 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 (Case (fiExpr scrut_drops scrut) - (fi_alts deflt_drops alts_drops alts)) - +fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) + = mkCoLets' drop_here1 $ + mkCoLets' drop_here2 $ + Case (fiExpr scrut_drops scrut) case_bndr ty + (zipWith fi_alt alts_drops_s alts) where - ---------------------------- - -- pin default FVs on first! - -- - get_fvs_from_deflt_and_alts (AnnAlgAlts alts deflt) - = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, _, rhs) <- alts ] - - get_fvs_from_deflt_and_alts (AnnPrimAlts alts deflt) - = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, rhs) <- alts] - - get_deflt_fvs AnnNoDefault = emptyIdSet - get_deflt_fvs (AnnBindDefault b rhs) = freeVarsOf rhs - - ---------------------------- - fi_alts to_drop_deflt to_drop_alts (AnnAlgAlts alts deflt) - = AlgAlts - [ (con, params, fiExpr to_drop rhs) - | ((con, params, rhs), to_drop) <- zipEqual "fi_alts" alts to_drop_alts ] - (fi_default to_drop_deflt deflt) - - fi_alts to_drop_deflt to_drop_alts (AnnPrimAlts alts deflt) - = PrimAlts - [ (lit, fiExpr to_drop rhs) - | ((lit, rhs), to_drop) <- zipEqual "fi_alts2" alts to_drop_alts ] - (fi_default to_drop_deflt deflt) - - fi_default to_drop AnnNoDefault = NoDefault - fi_default to_drop (AnnBindDefault b e) = BindDefault 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 (is_one_shot 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 = exprIsHNF (deAnnotate' rhs) -- We'd just float right back out again... + +is_one_shot b = isId b && isOneShotBndr b \end{code} + %************************************************************************ %* * \subsection{@sepBindsByDropPoint@} @@ -340,56 +384,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 emptyIdSet{-fvs of prev drop_pts-} floaters - = split' drop_pts floaters [] empty_boxes - empty_boxes = nOfThem (length drop_pts) [] - 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 `elementOfIdSet` a &&-} - not (b `elementOfIdSet` (unionManyIdSets as))) - (bindersOf (fst bind)) - = split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes) - where - a' = a `unionIdSets` fvsOfBind bind - - -- not in a - split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes) - | all (\b -> not (b `elementOfIdSet` 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 (unionIdSets (fvsOfBind bind)) aas - - ------------------------- - fvsOfBind (_,fvs) = fvs + 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 = count id used_in_flags -- returns number of Trues in list. + + 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 = unionManyIdSets (map snd binds) +floatedBindsFVs binds = unionVarSets (map snd binds) mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr -mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e +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}