#include "HsVersions.h"
-import CmdLineOpts ( opt_D_verbose_core2core )
+import DynFlags ( DynFlags, DynFlag(..) )
import CoreSyn
-import CoreLint ( beginPass, endPass )
-import Const ( isDataCon )
+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 )
+import Util ( zipEqual, zipWithEqual, count )
import Outputable
\end{code}
actually float any bindings downwards from the top-level.
\begin{code}
-floatInwards :: [CoreBind] -> IO [CoreBind]
+floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind]
-floatInwards binds
+floatInwards dflags binds
= do {
- beginPass "Float inwards";
+ showPass dflags "Float inwards";
let { binds' = map fi_top_bind binds };
- endPass "Float inwards"
- opt_D_verbose_core2core {- no specific flag for dumping float-in -}
- binds'
+ endPass dflags "Float inwards" Opt_D_verbose_core2core binds'
+ {- no specific flag for dumping float-in -}
}
where
fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
Type ty
-fiExpr to_drop (_, AnnCon c args)
- = mkCoLets' drop_here (Con c args')
- where
- (drop_here : arg_drops) = sepBindsByDropPoint (map freeVarsOf args) to_drop
- args' = zipWith fiExpr arg_drops args
+fiExpr to_drop (_, AnnLit lit) = Lit lit
\end{code}
Applications: we do float inside applications, mainly because we
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 [freeVarsOf fun, freeVarsOf arg] to_drop
+ [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop
\end{code}
-We are careful about lambdas:
+We are careful about lambdas:
-* We never float inside a value lambda. That risks losing laziness.
+* 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 don't float inside type lambdas either. At one time we did, and
+* 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:
This is bad as now f is an updatable closure (update PAP)
and has arity 0.
-So the simple thing is never to float inside big lambda either.
-Maybe we'll find cases when that loses something important; if
-so we can modify the decision.
+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 (_, AnnLam b body)
- = mkCoLets' to_drop (Lam b (fiExpr [] body))
+ -- 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.
= -- 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)
+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}
-- 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
+ [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
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
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
+ (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 ++
alternatives/default [default FVs always {\em first}!].
\begin{code}
-fiExpr to_drop (_, AnnCase scrut case_bndr alts)
- = mkCoLets' drop_here (Case (fiExpr scrut_drops scrut) case_bndr
- (zipWith fi_alt 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
- (drop_here : scrut_drops : alts_drops) = sepBindsByDropPoint (scrut_fvs : alts_fvs) to_drop
- scrut_fvs = freeVarsOf scrut
- alts_fvs = map alt_fvs alts
+ -- 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 _ _) = True
-noFloatIntoRhs (AnnCon con _) = isDataCon con
-noFloatIntoRhs other = False
+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}
\begin{code}
sepBindsByDropPoint
- :: [FreeVarsSet] -- One set of FVs per drop point
+ :: 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
-- 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 []
+type DropBox = (FreeVarsSet, FloatingBinds)
+
+sepBindsByDropPoint is_case drop_pts []
= [] : [[] | p <- drop_pts] -- cut to the chase scene; it happens
-sepBindsByDropPoint drop_pts floaters
+sepBindsByDropPoint is_case drop_pts floaters
= go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
where
- go :: FloatingBinds -> [(FreeVarsSet, FloatingBinds)] -> [FloatingBinds]
+ 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
- = go binds (insert drop_boxes (drop_here : used_in_flags))
- -- insert puts the find in box whose True flag comes first
+ 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 (exactlyOneTrue used_in_flags)
+ 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
- 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
+ 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
-exactlyOneTrue :: [Bool] -> Bool
-exactlyOneTrue flags = case [() | True <- flags] of
- [_] -> True
- other -> False
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}
projects / ghc-hetmet.git / blobdiff