%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
then discover that they aren't needed in the chosen branch.
\begin{code}
-#include "HsVersions.h"
-
module FloatIn ( floatInwards ) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
-import AnnCoreSyn
+import DynFlags ( DynFlags, DynFlag(..) )
import CoreSyn
-
-import FreeVars
-import Id ( emptyIdSet, unionIdSets, unionManyIdSets,
- elementOfIdSet, SYN_IE(IdSet), GenId
- )
-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))
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 ...
\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
-
-fiExpr to_drop (_,AnnVar v) = mkCoLets' to_drop (Var v)
+ -> CoreExprWithFVs -- Input expr
+ -> CoreExpr -- Result
-fiExpr to_drop (_,AnnLit k) = mkCoLets' to_drop (Lit k)
+fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
-fiExpr to_drop (_,AnnCon c atoms)
- = mkCoLets' to_drop (Con c atoms)
+fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
+ Type ty
-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 (UsageBinder binder) body)
- = panic "FloatIn.fiExpr:AnnLam UsageBinder"
-
-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 (_,AnnSCC _ 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: 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: SCC: {\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 (_, AnnSCC cc expr)
- = mkCoLets' to_drop (SCC cc (fiExpr [] expr))
-\end{code}
+fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
+ = -- Wimp out for now
+ mkCoLets' to_drop (Note note (fiExpr [] expr))
-\begin{code}
-fiExpr to_drop (_, AnnCoerce c ty expr)
- = --trace "fiExpr:Coerce:wimping out" $
- mkCoLets' to_drop (Coerce c ty (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)
+
+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}
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
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
-- 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 ++
-- 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
-> [(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}
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 <condition> 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@}
\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}
projects / ghc-hetmet.git / blobdiff