#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..) )
+import DynFlags ( DynFlags, DynFlag(..) )
import CoreSyn
-import CoreUtils ( exprIsValue, exprIsDupable )
+import CoreUtils ( exprIsHNF, exprIsDupable )
import CoreLint ( showPass, endPass )
import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf )
-import Id ( isOneShotLambda )
-import Var ( Id, idType, isTyVar )
+import Id ( isOneShotBndr )
+import Var ( Id, idType )
import Type ( isUnLiftedType )
import VarSet
-import Util ( zipEqual, zipWithEqual )
+import Util ( zipEqual, zipWithEqual, count )
import Outputable
\end{code}
Otherwise drop all the bindings outside the group.
\begin{code}
-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)
+ -- 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))
- is_ok bndr = isTyVar bndr || isOneShotLambda bndr
+ where
+ (bndrs, body) = collectAnnBndrs lam
\end{code}
We don't float lets inwards past an SCC.
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}
alternatives/default [default FVs always {\em first}!].
\begin{code}
-fiExpr to_drop (_, AnnCase scrut case_bndr alts)
+fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
= mkCoLets' drop_here1 $
mkCoLets' drop_here2 $
- Case (fiExpr scrut_drops scrut) case_bndr
+ Case (fiExpr scrut_drops scrut) case_bndr ty
(zipWith fi_alt alts_drops_s alts)
where
-- Float into the scrut and alts-considered-together just like App
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)
+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#
-- 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...
+noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs) -- We'd just float right back out again...
+
+is_one_shot b = isId b && isOneShotBndr b
\end{code}
-- E -> ...not mentioning x...
n_alts = length used_in_flags
- n_used_alts = length [() | True <- 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