#include "HsVersions.h"
-import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand )
+import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
isUnLiftedType, isUnboxedTupleType, repType,
- uaUTy, usOnce, usMany, seqType )
-import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) )
-import PrimOp ( PrimOp(..), setCCallUnique )
-import Var ( Var, Id, setVarUnique, globalIdDetails, setGlobalIdDetails )
+ uaUTy, usOnce, usMany, eqUsage, seqType )
+import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
+import PrimOp ( PrimOp(..) )
+import Var ( Var, Id, setVarUnique )
import VarSet
import VarEnv
-import Id ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity,
- setIdType, isPrimOpId_maybe, isLocalId, modifyIdInfo,
- hasNoBinding
+import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
+ setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
+ hasNoBinding, idNewStrictness, setIdArity
)
-import IdInfo ( GlobalIdDetails(..) )
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
-- ---------------------------------------------------------------------------
data FloatingBind = FloatLet CoreBind
- | FloatCase Id CoreExpr
+ | FloatCase Id CoreExpr Bool
+ -- The bool indicates "ok-for-speculation"
-type CloneEnv = IdEnv Id -- Clone local Ids
+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
-allLazy :: OrdList FloatingBind -> Bool
-allLazy floats = foldOL check True floats
- where
- check (FloatLet _) y = y
- check (FloatCase _ _) y = False
-
-corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind]
-corePrepTopBinds env [] = returnUs []
+type CloneEnv = IdEnv Id -- Clone local Ids
-corePrepTopBinds env (bind : binds)
- = corePrepBind env bind `thenUs` \ (env', floats) ->
- ASSERT( allLazy floats )
- corePrepTopBinds env' binds `thenUs` \ binds' ->
- returnUs (foldOL add binds' floats)
+allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
+allLazy top_lvl is_rec floats
+ = foldrOL check True floats
where
- add (FloatLet bind) binds = bind : binds
+ 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
-- ---------------------------------------------------------------------------
-corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
--- Used for non-top-level bindings
+corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM (OrdList FloatingBind)
+corePrepTopBinds env [] = returnUs nilOL
+
+corePrepTopBinds env (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
+
-- 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_KeepStgTypes = 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)
+ | hasNoBinding v = idArity v == 0
+ | otherwise = True
+exprIsTrivial (Type _) = True
+exprIsTrivial (Lit lit) = True
+exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
+exprIsTrivial (Note (SCC _) e) = False
+exprIsTrivial (Note _ e) = exprIsTrivial e
+exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
+exprIsTrivial other = False
-- ---------------------------------------------------------------------------
-- Dealing with expressions
= collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
let
(ss1, ss_rest) = case ss of
- (ss1:ss_rest) -> (ss1, ss_rest)
- [] -> (wwLazy, [])
+ (ss1:ss_rest) -> (ss1, ss_rest)
+ [] -> (lazyDmd, [])
(arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
splitFunTy_maybe fun_ty
in
let v2 = lookupVarEnv env v1 `orElse` v1 in
returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
where
- stricts = case idStrictness v of
- StrictnessInfo demands _
+ stricts = case idNewStrictness v of
+ StrictSig (DmdType _ demands _)
| depth >= length demands -> demands
| otherwise -> []
- other -> []
-- If depth < length demands, then we have too few args to
-- satisfy strictness info so we have to ignore all the
-- strictness info, e.g. + (error "urk")
-- 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 ->
+ 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 || isStrictDem 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)
+ = 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
| isNilOL binds = returnUs body
| otherwise = deLam body `thenUs` \ body' ->
- returnUs (foldOL mk_bind body' binds)
+ returnUs (foldrOL mk_bind body' binds)
where
- mk_bind (FloatCase bndr rhs) body = mkCase rhs bndr [(DEFAULT, [], body)]
- mk_bind (FloatLet bind) body = Let bind 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)
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
\begin{code}
-mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts
+mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
+ -- DEFAULT alt is always first
= case isPrimOpId_maybe fn of
Just ParOp -> Case scrut bndr [deflt_alt]
Just SeqOp -> Case arg new_bndr [deflt_alt]
other -> Case scrut bndr alts
where
- (deflt_alt@(_,_,rhs) : _) = [alt | alt@(DEFAULT,_,_) <- alts]
-
-- The binder shouldn't be used in the expression!
new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
setIdType bndr (exprType arg)
\begin{code}
data RhsDemand
- = RhsDemand { isStrictDem :: Bool, -- True => used at least once
+ = RhsDemand { isStrict :: Bool, -- True => used at least once
isOnceDem :: Bool -- True => used at most once
}
mkDem :: Demand -> Bool -> RhsDemand
-mkDem strict once = RhsDemand (isStrict strict) once
+mkDem strict once = RhsDemand (isStrictDmd strict) once
mkDemTy :: Demand -> Type -> RhsDemand
-mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
+mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
isOnceTy :: Type -> Bool
isOnceTy ty
once
where
u = uaUTy ty
- once | u == usOnce = True
- | u == usMany = False
- | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
+ once | u `eqUsage` usOnce = True
+ | u `eqUsage` usMany = False
+ | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
bdrDem :: Id -> RhsDemand
-bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
+bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
safeDem, onceDem :: RhsDemand
safeDem = RhsDemand False False -- always safe to use this
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 ConstantIds 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
fiddleCCall :: Id -> UniqSM Id
fiddleCCall id
- = case globalIdDetails id of
- PrimOpId (CCallOp ccall) ->
- -- Make a guaranteed unique name for a dynamic ccall.
- getUniqueUs `thenUs` \ uniq ->
- returnUs (setGlobalIdDetails id
- (PrimOpId (CCallOp (setCCallUnique ccall uniq))))
- other -> returnUs id
+ | isFCallId id = getUniqueUs `thenUs` \ uniq ->
+ returnUs (id `setVarUnique` uniq)
+ | otherwise = returnUs id
------------------------------------------------------------------------------
-- 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}
projects / ghc-hetmet.git / blobdiff