#include "HsVersions.h"
-import CmdLineOpts ( opt_D_verbose_core2core )
+import CmdLineOpts ( DynFlags, DynFlag(..) )
import CoreSyn
import CoreUtils ( exprIsValue, exprIsDupable )
-import CoreLint ( beginPass, endPass )
+import CoreLint ( showPass, endPass )
import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf )
import Id ( isOneShotLambda )
-import Var ( Id, idType, isTyVar )
+import Var ( Id, idType )
import Type ( isUnLiftedType )
import VarSet
-import Util ( zipEqual, zipWithEqual )
+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 (_, AnnLam b body)
= case collect [b] body of
(bndrs, real_body)
- | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
+-- | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
+-- [July 01: I'm experiment with getting the full laziness
+-- pass to floats bindings out past big lambdas (instead of the simplifier)
+-- so I don't want the float-in pass to just push them right back in.
+-- I'm going to try just dumping all bindings outside lambdas.]
| 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
+-- is_ok bndr = isTyVar bndr || isOneShotLambda bndr
\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@(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}
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
-- 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