--- ---------------------------------------------------------------------------
--- Precipitating the floating bindings
--- ---------------------------------------------------------------------------
-
-floatRhs :: TopLevelFlag -> RecFlag
- -> Id
- -> (Floats, CoreExpr) -- Rhs: let binds in body
- -> UniqSM (Floats, -- Floats out of this bind
- CoreExpr) -- Final Rhs
-
-floatRhs top_lvl is_rec _bndr (floats, rhs)
- | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or
- 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
- return (floats, rhs)
-
- | otherwise = do
- -- Don't float; the RHS isn't a value
- rhs' <- mkBinds floats rhs
- return (emptyFloats, rhs')
-
--- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
-mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
- -> Floats -> CoreExpr -- Rhs: let binds in body
- -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding,
- -- to record that it's been evaluated
-
-mkLocalNonRec bndr dem floats rhs
- | isUnLiftedType (idType bndr)
- -- If this is an unlifted binding, we always make a case for it.
- = ASSERT( not (isUnboxedTupleType (idType bndr)) )
- let
- float = FloatCase bndr rhs (exprOkForSpeculation rhs)
- in
- return (addFloat floats float, evald_bndr)
-
- | isStrict dem
- -- It's a strict let so we definitely float all the bindings
- = let -- Don't make a case for a value binding,
- -- even if it's strict. Otherwise we get
- -- case (\x -> e) of ...!
- float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
- | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
- in
- return (addFloat floats float, evald_bndr)
-
- | otherwise
- = do (floats', rhs') <- floatRhs NotTopLevel NonRecursive bndr (floats, rhs)
- return (addFloat floats' (FloatLet (NonRec bndr rhs')),
- if exprIsHNF rhs' then evald_bndr else bndr)
-
- where
- evald_bndr = bndr `setIdUnfolding` evaldUnfolding
- -- Record if the binder is evaluated
-
-
-mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
-mkBinds (Floats _ binds) body
- | isNilOL binds = return body
- | otherwise = do body' <- deLam body
- -- Lambdas are not allowed as the body of a 'let'
- return (foldrOL mk_bind body' binds)
- where
- mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
- mk_bind (FloatLet bind) body = Let bind body
-
-etaExpandRhs :: CoreBndr -> CoreExpr -> UniqSM CoreExpr
-etaExpandRhs bndr rhs = do
- -- Eta expand to match the arity claimed by the binder
- -- Remember, CorePrep must not change arity
- --
- -- Eta expansion might not have happened already,
- -- because it is done by the simplifier only when
- -- there at least one lambda already.
- --
- -- NB1:we could refrain when the RHS is trivial (which can happen
- -- for exported things). This would reduce the amount of code
- -- generated (a little) and make things a little words for
- -- code compiled without -O. The case in point is data constructor
- -- wrappers.
- --
- -- NB2: we have to be careful that the result of etaExpand doesn't
- -- invalidate any of the assumptions that CorePrep is attempting
- -- to establish. One possible cause is eta expanding inside of
- -- 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
- --
- us <- getUniquesM
- let eta_rhs = etaExpand arity us rhs (idType bndr)
-
- ASSERT2( manifestArity eta_rhs == arity, (ppr bndr <+> ppr arity <+> ppr (exprArity rhs))
- $$ ppr rhs $$ ppr eta_rhs )
- -- Assertion checks that eta expansion was successful
- return eta_rhs
- where
- -- For a GlobalId, take the Arity from the Id.
- -- It was set in CoreTidy and must not change
- -- For all others, just expand at will
- arity | isGlobalId bndr = idArity bndr
- | otherwise = exprArity rhs