#include "HsVersions.h"
-import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand, exprOkForSpeculation )
+import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
import VarSet
import VarEnv
import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
- setIdType, isPrimOpId_maybe, isFCallId, isLocalId,
- hasNoBinding, idNewStrictness
+ setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
+ hasNoBinding, idNewStrictness, setIdArity
)
import HscTypes ( ModDetails(..) )
+import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNotTopLevel,
+ RecFlag(..), isNonRec
+ )
import UniqSupply
import Maybes
import OrdList
corePrepPgm dflags mod_details
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
- let new_binds = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details))
- endPass dflags "CorePrep" Opt_D_dump_sat new_binds
+
+ let floats = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details))
+ new_binds = foldrOL get [] floats
+ get (FloatLet b) bs = b:bs
+ get b bs = pprPanic "corePrepPgm" (ppr b)
+
+ endPass dflags "CorePrep" Opt_D_dump_prep new_binds
return (mod_details { md_binds = new_binds })
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
- dumpIfSet_dyn dflags Opt_D_dump_sat "CorePrep"
+ dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
(ppr new_expr)
return new_expr
| FloatCase Id CoreExpr Bool
-- The bool indicates "ok-for-speculation"
+instance Outputable FloatingBind where
+ ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
+ ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
+
type CloneEnv = IdEnv Id -- Clone local Ids
-allLazy :: OrdList FloatingBind -> Bool
-allLazy floats = foldrOL check True floats
- where
- check (FloatLet _) y = y
- check (FloatCase _ _ ok_for_spec) y = ok_for_spec && y
+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 = 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
+ -- an unboxed binding to the top level
-- ---------------------------------------------------------------------------
-- Bindings
-- ---------------------------------------------------------------------------
-corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind]
-corePrepTopBinds env [] = returnUs []
+corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM (OrdList FloatingBind)
+corePrepTopBinds env [] = returnUs nilOL
corePrepTopBinds env (bind : binds)
- = corePrepBind env bind `thenUs` \ (env', floats) ->
- ASSERT( allLazy floats )
- corePrepTopBinds env' binds `thenUs` \ binds' ->
- returnUs (foldrOL add binds' floats)
- where
- add (FloatLet bind) binds = bind : binds
+ = corePrepTopBind env bind `thenUs` \ (env', bind') ->
+ corePrepTopBinds env' binds `thenUs` \ binds' ->
+ returnUs (bind' `appOL` binds')
+-- NB: we do need to float out of top-level bindings
+-- Consider x = length [True,False]
+-- We want to get
+-- s1 = False : []
+-- s2 = True : s1
+-- x = length s2
-corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
--- Used for non-top-level bindings
-- We return a *list* of bindings, because we may start with
-- x* = f (g y)
-- where x is demanded, in which case we want to finish with
-- x* = f a
-- And then x will actually end up case-bound
+corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
+corePrepTopBind env (NonRec bndr 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') ->
- cloneBndr env bndr `thenUs` \ (env', bndr') ->
- mkNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
+ = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
+ corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
+ cloneBndr env bndr `thenUs` \ (env', bndr') ->
+ mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
returnUs (env', floats')
-corePrepBind env (Rec pairs)
- -- Don't bother to try to float bindings out of RHSs
- -- (compare mkNonRec, which does try)
- = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
- mapUs (corePrepAnExpr env') rhss `thenUs` \ rhss' ->
- returnUs (env', unitOL (FloatLet (Rec (bndrs' `zip` rhss'))))
+corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
+
+--------------------------------
+corePrepRecPairs :: TopLevelFlag -> CloneEnv
+ -> [(Id,CoreExpr)] -- Recursive bindings
+ -> 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 Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
+ returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
where
- (bndrs, rhss) = unzip pairs
+ -- 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 -> RecFlag
+ -> CloneEnv -> (Id, CoreExpr)
+ -> UniqSM (OrdList FloatingBind, CoreExpr)
+-- Used for top-level bindings, and local recursive bindings
+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 needs_binding arg'
- then returnUs (floats, arg')
- else newVar (exprType arg') `thenUs` \ v ->
- mkNonRec v dem floats arg' `thenUs` \ floats' ->
- returnUs (floats', Var v)
-
-needs_binding | opt_RuntimeTypes = exprIsAtom
- | otherwise = exprIsTrivial
+ 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)
-- version that doesn't consider an scc annotation to be trivial.
exprIsTrivial (Var v)
-- non-variable fun, better let-bind it
collect_args fun depth
- = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun) ->
- newVar ty `thenUs` \ fn_id ->
- mkNonRec fn_id onceDem fun_floats fun `thenUs` \ floats ->
+ = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
+ newVar ty (exprArity fun') `thenUs` \ fn_id ->
+ mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
where
ty = exprType fun
maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
maybeSaturate fn expr n_args ty
| hasNoBinding fn = saturate_it
- | otherwise = returnUs expr
+ | otherwise = returnUs expr
where
fn_arity = idArity fn
excess_arity = fn_arity - n_args
- saturate_it = getUs `thenUs` \ us ->
- returnUs (etaExpand excess_arity (uniqsFromSupply us) expr ty)
+ saturate_it = getUniquesUs `thenUs` \ us ->
+ returnUs (etaExpand excess_arity us expr ty)
-- ---------------------------------------------------------------------------
-- Precipitating the floating bindings
-- ---------------------------------------------------------------------------
--- mkNonRec is used for both top level and local bindings
-mkNonRec :: Id -> RhsDemand -- Lhs: id with demand
- -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
- -> UniqSM (OrdList FloatingBind)
-mkNonRec bndr dem floats rhs
- | exprIsValue rhs && allLazy floats -- Notably constructor applications
- = -- Why the test for allLazy? You might think that the only
- -- floats we can get out of a value are eta expansions
- -- e.g. C $wJust ==> let s = \x -> $wJust x in C s
- -- Here we want to float the s binding.
- --
- -- But if the programmer writes this:
- -- f x = case x of { (a,b) -> \y -> a }
- -- then the strictness analyser may say that f has strictness "S"
- -- Later the eta expander will transform to
- -- f x y = case x of { (a,b) -> a }
- -- So now f has arity 2. Now CorePrep may see
- -- v = f E
- -- so the E argument will turn into a FloatCase.
- -- Indeed we should end up with
- -- v = case E of { r -> f r }
- -- That is, we should not float, even though (f r) is a value
- --
- -- Similarly, given
+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 is_rec bndr (floats, rhs)
+ | isTopLevel top_lvl || exprIsValue 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
- returnUs (floats `snocOL` FloatLet (NonRec bndr rhs))
+ --
+ -- Finally, eta-expand the RHS, for the benefit of the code gen
+ returnUs (floats, rhs)
- | isUnLiftedType bndr_rep_ty || isStrict dem
+ | otherwise
+ -- Don't float; the RHS isn't a value
+ = mkBinds floats rhs `thenUs` \ rhs' ->
+ returnUs (nilOL, rhs')
+
+-- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
+mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
+ -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
+ -> UniqSM (OrdList FloatingBind)
+
+mkLocalNonRec bndr dem floats rhs
+ | isUnLiftedType (idType bndr) || isStrict dem
-- It's a strict let, or the binder is unlifted,
-- so we definitely float all the bindings
- = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
- returnUs (floats `snocOL` FloatCase bndr rhs (exprOkForSpeculation rhs))
+ = ASSERT( not (isUnboxedTupleType (idType bndr)) )
+ let -- Don't make a case for a value binding,
+ -- even if it's strict. Otherwise we get
+ -- case (\x -> e) of ...!
+ float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
+ | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
+ in
+ returnUs (floats `snocOL` float)
| otherwise
- -- Don't float
- = mkBinds floats rhs `thenUs` \ rhs' ->
- returnUs (unitOL (FloatLet (NonRec bndr rhs')))
-
- where
- bndr_rep_ty = repType (idType bndr)
+ = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
+ returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
mkBinds binds body
mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
+etaExpandRhs bndr rhs
+ = -- Eta expand to match the arity claimed by the binder
+ -- Remember, after CorePrep we 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
+ --
+ getUniquesUs `thenUs` \ us ->
+ returnUs (etaExpand (idArity bndr) us rhs (idType bndr))
+
-- ---------------------------------------------------------------------------
-- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
-- We arrange that they only show up as the RHS of a let(rec)
deLam expr
| null bndrs = returnUs expr
- | otherwise = case tryEta bndrs body of
- Just no_lam_result -> returnUs no_lam_result
- Nothing -> newVar (exprType expr) `thenUs` \ fn ->
- returnUs (Let (NonRec fn expr) (Var fn))
+ | otherwise
+ = case tryEta bndrs body of
+ Just no_lam_result -> returnUs no_lam_result
+ Nothing -> newVar (exprType expr) (exprArity expr) `thenUs` \ fn ->
+ returnUs (Let (NonRec fn expr) (Var fn))
where
(bndrs,body) = collectBinders expr
cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
cloneBndr env bndr
- | isId bndr && isLocalId bndr -- Top level things, which we don't want
- -- to clone, have become GlobalIds by now
+ | isGlobalId bndr -- Top level things, which we don't want
+ = returnUs (env, bndr) -- to clone, have become GlobalIds by now
+
+ | otherwise
= getUniqueUs `thenUs` \ uniq ->
let
bndr' = setVarUnique bndr uniq
in
returnUs (extendVarEnv env bndr bndr', bndr')
- | otherwise = returnUs (env, bndr)
-
------------------------------------------------------------------------------
-- Cloning ccall Ids; each must have a unique name,
-- to give the code generator a handle to hang it on
-- Generating new binders
-- ---------------------------------------------------------------------------
-newVar :: Type -> UniqSM Id
-newVar ty
- = getUniqueUs `thenUs` \ uniq ->
- seqType ty `seq`
- returnUs (mkSysLocal SLIT("sat") uniq ty)
+newVar :: Type -> Arity -> UniqSM Id
+-- We're creating a new let binder, and we must give
+-- it the right arity for the benefit of the code generator.
+newVar ty arity
+ = seqType ty `seq`
+ getUniqueUs `thenUs` \ uniq ->
+ returnUs (mkSysLocal SLIT("sat") uniq ty
+ `setIdArity` arity)
\end{code}