X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FFloatIn.lhs;h=97e1c06aad8babe3702ccc2cd298615ba4fcf290;hb=c3cf681e8f65430d4e0dcef08c8f7b75332a034e;hp=353a3b2c3d564d0b661e46e1b1262e6454c73873;hpb=ba013704bfb94aa133fb28f342e0d432698a5d6d;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 353a3b2..97e1c06 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,34 @@ module FloatIn ( floatInwards ) where #include "HsVersions.h" -import AnnCoreSyn +import CmdLineOpts ( opt_D_verbose_core2core ) import CoreSyn - -import FreeVars -import Id ( emptyIdSet, unionIdSets, unionManyIdSets, - elementOfIdSet, IdSet, GenId, Id - ) -import Util ( nOfThem, panic, zipEqual ) +import CoreLint ( beginPass, endPass ) +import Const ( isDataCon ) +import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf ) +import Id ( isOneShotLambda ) +import Var ( Id, idType, isTyVar ) +import Type ( isUnLiftedType ) +import VarSet +import Util ( zipEqual ) +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 :: [CoreBind] -> IO [CoreBind] floatInwards binds - = map fi_top_bind binds + = do { + beginPass "Float inwards"; + let { binds' = map fi_top_bind binds }; + endPass "Float inwards" + opt_D_verbose_core2core {- no specific flag for dumping float-in -} + binds' + } + where fi_top_bind (NonRec binder rhs) = NonRec binder (fiExpr [] (freeVars rhs)) @@ -61,12 +71,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 +124,91 @@ 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 (_, AnnCon c args) + | isDataCon c -- Don't float into the args of a data construtor; + -- the simplifier will float straight back out + = mkCoLets' to_drop (Con c (map (fiExpr []) args)) -fiExpr to_drop (_,AnnPrim c atoms) - = mkCoLets' to_drop (Prim c atoms) + | otherwise + = mkCoLets' drop_here (Con c args') + where + (drop_here : arg_drops) = sepBindsByDropPoint (map freeVarsOf args) to_drop + args' = zipWith fiExpr arg_drops args \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 [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 +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) + + is_ok bndr = isTyVar bndr || isOneShotLambda bndr \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 +216,18 @@ 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@(TermUsg _) expr) + = -- Float in past term usage annotation + -- (for now; not sure if this is correct: KSW 1999-05) + Note note (fiExpr to_drop expr) \end{code} For @Lets@, the possible ``drop points'' for the \tr{to_drop} @@ -213,12 +240,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 +253,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 [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,7 +273,7 @@ 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 @@ -250,8 +283,25 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) 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 (final_body_fvs:rhss_fvs) to_drop new_to_drop = -- the bindings used only in the body body_binds ++ @@ -260,8 +310,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 +319,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 +328,34 @@ 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 alts) + = mkCoLets' drop_here (Case (fiExpr scrut_drops scrut) case_bndr + (zipWith fi_alt alts_drops 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) + (drop_here : scrut_drops : alts_drops) = sepBindsByDropPoint (scrut_fvs : alts_fvs) to_drop + scrut_fvs = freeVarsOf scrut + alts_fvs = map alt_fvs alts + 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 (AnnCon con _) = isDataCon con +noFloatIntoRhs other = False \end{code} + %************************************************************************ %* * \subsection{@sepBindsByDropPoint@} @@ -340,52 +379,55 @@ 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 + :: [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. sepBindsByDropPoint drop_pts [] - = ([[] | p <- drop_pts], []) -- cut to the chase scene; it happens + = [] : [[] | 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) + = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts)) where - split' drop_pts_fvs [] mult_branch drop_boxes - = (drop_boxes, mult_branch, drop_pts_fvs) + go :: FloatingBinds -> [(FreeVarsSet, FloatingBinds)] -> [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! - split' drop_pts_fvs (bind:binds) mult_branch drop_boxes - | no_of_branches == 1 -- Exactly one branch - = split' drop_pts_fvs' binds mult_branch drop_boxes' + go [] drop_boxes = map (reverse . snd) drop_boxes - | otherwise -- Zero or many branches; drop it here - = split' drop_pts_fvs binds (bind:mult_branch) drop_boxes + go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes + = go binds (insert drop_boxes (drop_here : used_in_flags)) + -- insert puts the find in box whose True flag comes first + where + (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind) + | (fvs, drops) <- drop_boxes] - where - binders = bindersOf (fst bind) - no_of_branches = length [() | True <- in_branch_flags] - in_branch_flags = [ any (`elementOfIdSet` branch_fvs) binders - | branch_fvs <- drop_pts_fvs ] + drop_here = used_here || not (exactlyOneTrue used_in_flags) - (drop_pts_fvs', drop_boxes') = unzip (zipWith3 drop in_branch_flags drop_pts_fvs drop_boxes) - drop True drop_fvs box = (drop_fvs `unionIdSets` fvsOfBind bind, bind:box) - drop False drop_fvs box = (drop_fvs, box) - + insert ((fvs,drops) : drop_boxes) (True : _) + = ((fvs `unionVarSet` bind_fvs, bind_w_fvs:drops) : drop_boxes) + insert (drop_box : drop_boxes) (False : others) + = drop_box : insert drop_boxes others + insert _ _ = panic "sepBindsByDropPoint" -- Should never happen - ------------------------- - fvsOfBind (_,fvs) = fvs +exactlyOneTrue :: [Bool] -> Bool +exactlyOneTrue flags = case [() | True <- flags] of + [_] -> True + other -> False 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 \end{code}