hasNoBinding, idNewStrictness, setIdArity
)
import HscTypes ( ModDetails(..) )
-import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel )
+import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNotTopLevel,
+ RecFlag(..), isNonRec
+ )
import UniqSupply
import Maybes
import OrdList
type CloneEnv = IdEnv Id -- Clone local Ids
-allLazy :: OrdList FloatingBind -> Bool
-allLazy floats
+allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
+allLazy top_lvl is_rec floats
= foldrOL check True floats
where
+ unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec
+
check (FloatLet _) y = y
- check (FloatCase _ _ ok_for_spec) y = ok_for_spec && y
+ check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
-- The ok-for-speculation flag says that it's safe to
-- float this Case out of a let, and thereby do it more eagerly
-- We need the top-level flag because it's never ok to float
corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
corePrepTopBind env (NonRec bndr rhs)
- = cloneBndr env bndr `thenUs` \ (env', bndr') ->
- corePrepRhs TopLevel env (bndr, rhs) `thenUs` \ (floats, rhs') ->
+ = cloneBndr env bndr `thenUs` \ (env', bndr') ->
+ corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
-- This one is used for *local* bindings
corePrepBind env (NonRec bndr rhs)
- = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
+ = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
+ corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
- mkLocalNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
+ mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
returnUs (env', floats')
corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
-> UniqSM (CloneEnv, OrdList FloatingBind)
-- Used for all recursive bindings, top level and otherwise
corePrepRecPairs lvl env pairs
- = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
- mapAndUnzipUs (corePrepRhs lvl env') pairs `thenUs` \ (floats_s, rhss') ->
- returnUs (env', concatOL floats_s `snocOL` FloatLet (Rec (bndrs' `zip` rhss')))
+ = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
+ mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
+ returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
+ where
+ -- Flatten all the floats, and the currrent
+ -- group into a single giant Rec
+ flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
+
+ get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
+ get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
--------------------------------
-corePrepRhs :: TopLevelFlag -> CloneEnv -> (Id, CoreExpr)
+corePrepRhs :: TopLevelFlag -> RecFlag
+ -> CloneEnv -> (Id, CoreExpr)
-> UniqSM (OrdList FloatingBind, CoreExpr)
-- Used for top-level bindings, and local recursive bindings
-corePrepRhs top_lvl env (bndr, rhs)
- = corePrepExprFloat env rhs `thenUs` \ floats_w_rhs ->
- floatRhs top_lvl bndr floats_w_rhs
+corePrepRhs top_lvl is_rec env (bndr, rhs)
+ = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
+ corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
+ floatRhs top_lvl is_rec bndr floats_w_rhs
-- ---------------------------------------------------------------------------
-> UniqSM (OrdList FloatingBind, CoreArg)
corePrepArg env arg dem
= corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
- if no_binding_needed arg'
+ if exprIsTrivial arg'
then returnUs (floats, arg')
else newVar (exprType arg') (exprArity arg') `thenUs` \ v ->
mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
returnUs (floats', Var v)
-no_binding_needed | opt_RuntimeTypes = exprIsAtom
- | otherwise = exprIsTrivial
-
-- version that doesn't consider an scc annotation to be trivial.
exprIsTrivial (Var v)
| hasNoBinding v = idArity v == 0
-- Precipitating the floating bindings
-- ---------------------------------------------------------------------------
-floatRhs :: TopLevelFlag -> Id
+floatRhs :: TopLevelFlag -> RecFlag
+ -> Id
-> (OrdList FloatingBind, CoreExpr) -- Rhs: let binds in body
-> UniqSM (OrdList FloatingBind, -- Floats out of this bind
CoreExpr) -- Final Rhs
-floatRhs top_lvl bndr (floats, rhs)
+floatRhs top_lvl is_rec bndr (floats, rhs)
| isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or
- allLazy floats -- at top level
+ allLazy top_lvl is_rec floats -- at top level
= -- Why the test for allLazy?
-- v = f (x `divInt#` y)
-- we don't want to float the case, even if f has arity 2,
-- because floating the case would make it evaluated too early
--
-- Finally, eta-expand the RHS, for the benefit of the code gen
- etaExpandRhs bndr rhs `thenUs` \ rhs' ->
- returnUs (floats, rhs')
+ returnUs (floats, rhs)
| otherwise
-- Don't float; the RHS isn't a value
= mkBinds floats rhs `thenUs` \ rhs' ->
- etaExpandRhs bndr rhs' `thenUs` \ rhs'' ->
- returnUs (nilOL, rhs'')
+ returnUs (nilOL, rhs')
-- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
returnUs (floats `snocOL` float)
| otherwise
- = floatRhs NotTopLevel bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
+ = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
-- an SCC note - we're now careful in etaExpand to make sure the
-- SCC is pushed inside any new lambdas that are generated.
--
+ -- NB3: It's important to do eta expansion, and *then* ANF-ising
+ -- f = /\a -> g (h 3) -- h has arity 2
+ -- If we ANF first we get
+ -- f = /\a -> let s = h 3 in g s
+ -- and now eta expansion gives
+ -- f = /\a -> \ y -> (let s = h 3 in g s) y
+ -- which is horrible.
+ -- Eta expanding first gives
+ -- f = /\a -> \y -> let s = h 3 in g s y
+ --
getUniquesUs `thenUs` \ us ->
returnUs (etaExpand (idArity bndr) us rhs (idType bndr))
projects / ghc-hetmet.git / blobdiff