#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
setIdType, isPrimOpId_maybe, isFCallId, isLocalId,
hasNoBinding, idNewStrictness
)
-import BasicTypes( TopLevelFlag(..), isNotTopLevel )
import HscTypes ( ModDetails(..) )
import UniqSupply
import Maybes
| 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 :: TopLevelFlag -> OrdList FloatingBind -> Bool
-allLazy top_lvl floats
+allLazy :: OrdList FloatingBind -> Bool
+allLazy floats
= foldrOL check True floats
where
check (FloatLet _) y = y
- check (FloatCase _ _ ok_for_spec) y = isNotTopLevel top_lvl && ok_for_spec && y
+ check (FloatCase _ _ ok_for_spec) y = 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
corePrepTopBinds env [] = returnUs []
corePrepTopBinds env (bind : binds)
- = corePrepBind TopLevel env bind `thenUs` \ (env', floats) ->
- ASSERT( allLazy TopLevel floats )
+ = corePrepTopBind env bind `thenUs` \ (env', bind') ->
corePrepTopBinds env' binds `thenUs` \ binds' ->
- returnUs (foldrOL add binds' floats)
+ returnUs (bind' : binds')
+
+-- From top level bindings we don't get any floats
+-- (a) it isn't necessary because the mkAtomicArgs in Simplify
+-- has already done all the floating necessary
+-- (b) floating would give rise to top-level LocaIds, generated
+-- by CorePrep.newVar. That breaks the invariant that
+-- after CorePrep all top-level vars are GlobalIds
+
+corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, CoreBind)
+corePrepTopBind env (NonRec bndr rhs)
+ = corePrepRhs env (bndr, rhs) `thenUs` \ rhs' ->
+ cloneBndr env bndr `thenUs` \ (env', bndr') ->
+ returnUs (env', NonRec bndr' rhs')
+
+corePrepTopBind env (Rec pairs)
+ = corePrepRecPairs env pairs `thenUs` \ (env', pairs') ->
+ returnUs (env, Rec pairs')
+
+corePrepRecPairs env pairs
+ = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
+ mapUs (corePrepRhs env') pairs `thenUs` \ rhss' ->
+ returnUs (env', bndrs' `zip` rhss')
where
- add (FloatLet bind) binds = bind : binds
+ bndrs = map fst pairs
+
+corePrepRhs :: CloneEnv -> (Id, CoreExpr) -> UniqSM CoreExpr
+corePrepRhs env (bndr, rhs)
+-- Prepare the RHS and eta expand it.
+-- No nonsense about floating
+ = corePrepAnExpr env rhs `thenUs` \ rhs' ->
+ getUniquesUs `thenUs` \ us ->
+ returnUs (etaExpand (exprArity rhs') us rhs' (idType bndr))
-corePrepBind :: TopLevelFlag -> CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
+corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
+-- This one is used for *local* 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
-corePrepBind top_lvl env (NonRec bndr rhs)
+corePrepBind env (NonRec bndr rhs)
= corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
- mkNonRec top_lvl bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
+ mkLocalNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
returnUs (env', floats')
-corePrepBind top_lvl env (Rec pairs)
+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'))))
- where
- (bndrs, rhss) = unzip pairs
-
+ = corePrepRecPairs env pairs `thenUs` \ (env', pairs') ->
+ returnUs (env', unitOL (FloatLet (Rec pairs')))
-- ---------------------------------------------------------------------------
-- Making arguments atomic (function args & constructor args)
= corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
if needs_binding arg'
then returnUs (floats, arg')
- else newVar (exprType arg') `thenUs` \ v ->
- mkNonRec NotTopLevel v dem floats arg' `thenUs` \ floats' ->
+ else newVar (exprType arg') `thenUs` \ v ->
+ mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
returnUs (floats', Var v)
needs_binding | opt_RuntimeTypes = exprIsAtom
= returnUs (nilOL, expr)
corePrepExprFloat env (Let bind body)
- = corePrepBind NotTopLevel env bind `thenUs` \ (env', new_binds) ->
- corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
+ = corePrepBind env bind `thenUs` \ (env', new_binds) ->
+ corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
returnUs (new_binds `appOL` floats, new_body)
corePrepExprFloat env (Note n@(SCC _) expr)
-- non-variable fun, better let-bind it
collect_args fun depth
- = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun) ->
- newVar ty `thenUs` \ fn_id ->
- mkNonRec NotTopLevel fn_id onceDem fun_floats fun `thenUs` \ floats ->
+ = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun) ->
+ newVar ty `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 :: TopLevelFlag
- -> Id -> RhsDemand -- Lhs: id with demand
- -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
- -> UniqSM (OrdList FloatingBind)
-mkNonRec top_lvl bndr dem floats rhs
- | exprIsValue rhs && allLazy top_lvl floats -- Notably constructor applications
+-- mkLocalNonRec is used only for local bindings
+mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
+ -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
+ -> UniqSM (OrdList FloatingBind)
+
+mkLocalNonRec 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
-- 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
+ -- NB: 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.
+ --
+ getUniquesUs `thenUs` \ us ->
+ let
+ rhs' = etaExpand (exprArity rhs) us rhs bndr_ty
+ in
+ returnUs (floats `snocOL` FloatLet (NonRec bndr rhs'))
| isUnLiftedType bndr_rep_ty || isStrict dem
-- It's a strict let, or the binder is unlifted,
returnUs (floats `snocOL` FloatCase bndr rhs (exprOkForSpeculation rhs))
| otherwise
- -- Don't float
+ -- Don't float; the RHS isn't a value
= mkBinds floats rhs `thenUs` \ rhs' ->
returnUs (unitOL (FloatLet (NonRec bndr rhs')))
where
- bndr_rep_ty = repType (idType bndr)
+ bndr_ty = idType bndr
+ bndr_rep_ty = repType bndr_ty
mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
mkBinds binds body
exprArity,
-- Expr transformation
- etaReduce, etaExpand,
- exprArity, exprEtaExpandArity,
+ etaExpand, exprArity, exprEtaExpandArity,
-- Size
coreBindsSize,
import GlaExts -- For `xori`
import CoreSyn
-import CoreFVs ( exprFreeVars )
import PprCore ( pprCoreExpr )
import Var ( Var, isId, isTyVar )
-import VarSet
import VarEnv
import Name ( hashName )
import Literal ( hashLiteral, literalType, litIsDupable )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
- splitTyConApp_maybe, eqType
+ splitTyConApp_maybe, eqType, funResultTy, applyTy
)
import TyCon ( tyConArity )
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
%* *
%************************************************************************
-@etaReduce@ trys an eta reduction at the top level of a Core Expr.
-
-e.g. \ x y -> f x y ===> f
-
-But we only do this if it gets rid of a whole lambda, not part.
-The idea is that lambdas are often quite helpful: they indicate
-head normal forms, so we don't want to chuck them away lightly.
-
-\begin{code}
-etaReduce :: CoreExpr -> CoreExpr
- -- ToDo: we should really check that we don't turn a non-bottom
- -- lambda into a bottom variable. Sigh
-
-etaReduce expr@(Lam bndr body)
- = check (reverse binders) body
- where
- (binders, body) = collectBinders expr
-
- check [] body
- | not (any (`elemVarSet` body_fvs) binders)
- = body -- Success!
- where
- body_fvs = exprFreeVars body
-
- check (b : bs) (App fun arg)
- | (varToCoreExpr b `cheapEqExpr` arg)
- = check bs fun
-
- check _ _ = expr -- Bale out
-
-etaReduce expr = expr -- The common case
-\end{code}
-
-
\begin{code}
-exprEtaExpandArity :: CoreExpr -> (Int, Bool)
+exprEtaExpandArity :: CoreExpr -> Arity
-- The Int is number of value args the thing can be
-- applied to without doing much work
--- The Bool is True iff there are enough explicit value lambdas
--- at the top to make this arity apparent
--- (but ignore it when arity==0)
-
+--
-- This is used when eta expanding
-- e ==> \xy -> e x y
--
-- Hence the ABot/ATop in ArityType
-exprEtaExpandArity e
- = go 0 e
- where
- go :: Int -> CoreExpr -> (Int,Bool)
- go ar (Lam x e) | isId x = go (ar+1) e
- | otherwise = go ar e
- go ar (Note n e) | ok_note n = go ar e
- go ar other = (ar + ar', ar' == 0)
- where
- ar' = arityDepth (arityType other)
+exprEtaExpandArity e = arityDepth (arityType e)
-- A limited sort of function type
data ArityType = AFun Bool ArityType -- True <=> one-shot
-- means expression can be rewritten \x_b1 -> ... \x_bn -> body
-- where bi is True <=> the lambda is one-shot
-arityType (Note n e)
- | ok_note n = arityType e
- | otherwise = ATop
+arityType (Note n e) = arityType e
+-- Not needed any more: etaExpand is cleverer
+-- | ok_note n = arityType e
+-- | otherwise = ATop
arityType (Var v)
= mk (idArity v)
arityType other = ATop
+{- NOT NEEDED ANY MORE: etaExpand is cleverer
ok_note InlineMe = False
ok_note other = True
-- Notice that we do not look through __inline_me__
-- giving just
-- f = \x -> e
-- A Bad Idea
-
+-}
\end{code}
\begin{code}
-etaExpand :: Int -- Add this number of value args
+etaExpand :: Arity -- Result should have this number of value args
-> [Unique]
-> CoreExpr -> Type -- Expression and its type
-> CoreExpr
-- (etaExpand n us e ty) returns an expression with
-- the same meaning as 'e', but with arity 'n'.
-
+--
-- Given e' = etaExpand n us e ty
-- We should have
-- ty = exprType e = exprType e'
---
+
+etaExpand n us expr ty
+ | manifestArity expr >= n = expr -- The no-op case
+ | otherwise = eta_expand n us expr ty
+ where
+
+-- manifestArity sees how many leading value lambdas there are
+manifestArity :: CoreExpr -> Arity
+manifestArity (Lam v e) | isId v = 1 + manifestArity e
+ | otherwise = manifestArity e
+manifestArity (Note _ e) = manifestArity e
+manifestArity e = 0
+
-- etaExpand deals with for-alls. For example:
-- etaExpand 1 E
-- where E :: forall a. a -> a
-- It deals with coerces too, though they are now rare
-- so perhaps the extra code isn't worth it
-etaExpand n us expr ty
+eta_expand n us expr ty
| n == 0 &&
-- The ILX code generator requires eta expansion for type arguments
-- too, but alas the 'n' doesn't tell us how many of them there
-- Saturated, so nothing to do
= expr
- | otherwise -- An unsaturated constructor or primop; eta expand it
+ -- Short cut for the case where there already
+ -- is a lambda; no point in gratuitously adding more
+eta_expand n us (Note note@(Coerce _ ty) e) _
+ = Note note (eta_expand n us e ty)
+
+eta_expand n us (Note note e) ty
+ = Note note (eta_expand n us e ty)
+
+eta_expand n us (Lam v body) ty
+ | isTyVar v
+ = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
+
+ | otherwise
+ = Lam v (eta_expand (n-1) us body (funResultTy ty))
+
+eta_expand n us expr ty
= case splitForAllTy_maybe ty of {
- Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
+ Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
; Nothing ->
case splitFunTy_maybe ty of {
- Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
+ Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
where
arg1 = mkSysLocal SLIT("eta") uniq arg_ty
(uniq:us2) = us
; Nothing ->
case splitNewType_maybe ty of {
- Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
+ Just ty' -> mkCoerce ty ty' (eta_expand n us (mkCoerce ty' ty expr) ty') ;
Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
}}}
\end{code}
should have arity 3, regardless of f's arity.
\begin{code}
-exprArity :: CoreExpr -> Int
+exprArity :: CoreExpr -> Arity
exprArity e = go e
where
go (Var v) = idArity v
projects / ghc-hetmet.git / commitdiff