bindNonRec, mkIfThenElse, mkAltExpr,
mkPiType,
+ -- Taking expressions apart
+ findDefault, findAlt,
+
-- Properties of expressions
exprType, coreAltsType,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
- exprIsConApp_maybe,
+ exprIsConApp_maybe, exprIsAtom,
idAppIsBottom, idAppIsCheap,
exprArity,
-- Expr transformation
- etaReduce, exprEtaExpandArity,
--- etaExpandExpr,
+ etaReduce, etaExpand,
+ exprArity, exprEtaExpandArity,
-- Size
coreBindsSize,
import Name ( hashName )
import Literal ( hashLiteral, literalType, litIsDupable )
import DataCon ( DataCon, dataConRepArity )
-import PrimOp ( primOpOkForSpeculation, primOpIsCheap,
- primOpIsDupable )
-import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo,
- mkWildId, idArity, idName, idUnfolding, idInfo,
- isDataConId_maybe, isPrimOpId_maybe
+import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
+import Id ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo,
+ mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
+ isDataConId_maybe, mkSysLocal, hasNoBinding
)
import IdInfo ( LBVarInfo(..),
- IdFlavour(..),
+ GlobalIdDetails(..),
megaSeqIdInfo )
import Demand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
- applyTys, isUnLiftedType, seqType, mkUTy
+ applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
+ splitForAllTy_maybe, splitNewType_maybe
)
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
-import Maybes ( maybeToBool )
+import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
\end{code}
that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
not be *applied* to anything.
+We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
+bindings like
+ fw = ...
+ f = inline_me (coerce t fw)
+As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
+We want the split, so that the coerces can cancel at the call site.
+
+However, we can get left with tiresome type applications. Notably, consider
+ f = /\ a -> let t = e in (t, w)
+Then lifting the let out of the big lambda gives
+ t' = /\a -> e
+ f = /\ a -> let t = inline_me (t' a) in (t, w)
+The inline_me is to stop the simplifier inlining t' right back
+into t's RHS. In the next phase we'll substitute for t (since
+its rhs is trivial) and *then* we could get rid of the inline_me.
+But it hardly seems worth it, so I don't bother.
+
\begin{code}
-mkInlineMe e | exprIsTrivial e = e
- | otherwise = Note InlineMe e
+mkInlineMe (Var v) = Var v
+mkInlineMe e = Note InlineMe e
\end{code}
\begin{code}
mkSCC :: CostCentre -> Expr b -> Expr b
-- Note: Nested SCC's *are* preserved for the benefit of
- -- cost centre stack profiling (Durham)
-
-mkSCC cc (Lit lit) = Lit lit
-mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
-mkSCC cc expr = Note (SCC cc) expr
+ -- cost centre stack profiling
+mkSCC cc (Lit lit) = Lit lit
+mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
+mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
+mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
+mkSCC cc expr = Note (SCC cc) expr
\end{code}
(DataAlt falseDataCon, [], else_expr) ]
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Taking expressions apart}
+%* *
+%************************************************************************
+
+
+\begin{code}
+findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
+findDefault [] = ([], Nothing)
+findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
+ ([], Just rhs)
+findDefault (alt : alts) = case findDefault alts of
+ (alts', deflt) -> (alt : alts', deflt)
+
+findAlt :: AltCon -> [CoreAlt] -> CoreAlt
+findAlt con alts
+ = go alts
+ where
+ go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
+ go (alt : alts) | matches alt = alt
+ | otherwise = go alts
+
+ matches (DEFAULT, _, _) = True
+ matches (con1, _, _) = con == con1
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Figuring out things about expressions}
\begin{code}
exprIsTrivial (Var v)
- | Just op <- isPrimOpId_maybe v = primOpIsDupable op
+ | hasNoBinding v = idArity v == 0
+ -- WAS: | Just op <- isPrimOpId_maybe v = primOpIsDupable op
+ -- The idea here is that a constructor worker, like $wJust, is
+ -- really short for (\x -> $wJust x), becuase $wJust has no binding.
+ -- So it should be treated like a lambda.
+ -- Ditto unsaturated primops.
+ -- This came up when dealing with eta expansion/reduction for
+ -- x = $wJust
+ -- Here we want to eta-expand. This looks like an optimisation,
+ -- but it's important (albeit tiresome) that CoreSat doesn't increase
+ -- anything's arity
| otherwise = True
exprIsTrivial (Type _) = True
exprIsTrivial (Lit lit) = True
exprIsTrivial (Note _ e) = exprIsTrivial e
exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
exprIsTrivial other = False
+
+exprIsAtom :: CoreExpr -> Bool
+-- Used to decide whether to let-binding an STG argument
+-- when compiling to ILX => type applications are not allowed
+exprIsAtom (Var v) = True -- primOpIsDupable?
+exprIsAtom (Lit lit) = True
+exprIsAtom (Type ty) = True
+exprIsAtom (Note (SCC _) e) = False
+exprIsAtom (Note _ e) = exprIsAtom e
+exprIsAtom other = False
\end{code}
\begin{code}
-exprIsDupable (Type _) = True
-exprIsDupable (Var v) = True
-exprIsDupable (Lit lit) = litIsDupable lit
-exprIsDupable (Note _ e) = exprIsDupable e
+exprIsDupable (Type _) = True
+exprIsDupable (Var v) = True
+exprIsDupable (Lit lit) = litIsDupable lit
+exprIsDupable (Note InlineMe e) = True
+exprIsDupable (Note _ e) = exprIsDupable e
exprIsDupable expr
= go expr 0
where
exprIsCheap (Lit lit) = True
exprIsCheap (Type _) = True
exprIsCheap (Var _) = True
+exprIsCheap (Note InlineMe e) = True
exprIsCheap (Note _ e) = exprIsCheap e
exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
exprIsCheap (Case e _ alts) = exprIsCheap e &&
| n_val_args == 0 = True -- Just a type application of
-- a variable (f t1 t2 t3)
-- counts as WHNF
- | otherwise = case idFlavour id of
+ | otherwise = case globalIdDetails id of
DataConId _ -> True
RecordSelId _ -> True -- I'm experimenting with making record selection
-- look cheap, so we will substitute it inside a
= go other_expr 0 True
where
go (Var f) n_args args_ok
- = case idFlavour f of
+ = case globalIdDetails f of
DataConId _ -> True -- The strictness of the constructor has already
-- been expressed by its "wrapper", so we don't need
-- to take the arguments into account
and to decide whether it's safe to discard a `seq`
-So, it does *not* treat variables as evaluated, unless they say they are
+So, it does *not* treat variables as evaluated, unless they say they are.
+
+But it *does* treat partial applications and constructor applications
+as values, even if their arguments are non-trivial;
+ e.g. (:) (f x) (map f xs) is a value
+ map (...redex...) is a value
+Because `seq` on such things completes immediately
+
+A possible worry: constructors with unboxed args:
+ C (f x :: Int#)
+Suppose (f x) diverges; then C (f x) is not a value. True, but
+this form is illegal (see the invariants in CoreSyn). Args of unboxed
+type must be ok-for-speculation (or trivial).
\begin{code}
exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
idAppIsValue :: Id -> Int -> Bool
idAppIsValue id n_val_args
- = case idFlavour id of
+ = case globalIdDetails id of
DataConId _ -> True
PrimOpId _ -> n_val_args < idArity id
other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
\begin{code}
exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
-exprIsConApp_maybe expr
- = analyse (collectArgs expr)
+exprIsConApp_maybe (Note InlineMe expr) = exprIsConApp_maybe expr
+ -- We ignore InlineMe notes in case we have
+ -- x = __inline_me__ (a,b)
+ -- All part of making sure that INLINE pragmas never hurt
+ -- Marcin tripped on this one when making dictionaries more inlinable
+
+exprIsConApp_maybe expr = analyse (collectArgs expr)
where
analyse (Var fun, args)
- | maybeToBool maybe_con_app = maybe_con_app
- where
- maybe_con_app = case isDataConId_maybe fun of
- Just con | length args >= dataConRepArity con
- -- Might be > because the arity excludes type args
- -> Just (con, args)
- other -> Nothing
+ | Just con <- isDataConId_maybe fun,
+ length args >= dataConRepArity con
+ -- Might be > because the arity excludes type args
+ = Just (con,args)
+ -- Look through unfoldings, but only cheap ones, because
+ -- we are effectively duplicating the unfolding
analyse (Var fun, [])
- = case maybeUnfoldingTemplate (idUnfolding fun) of
- Nothing -> Nothing
- Just unf -> exprIsConApp_maybe unf
+ | let unf = idUnfolding fun,
+ isCheapUnfolding unf
+ = exprIsConApp_maybe (unfoldingTemplate unf)
analyse other = Nothing
\end{code}
-The arity of an expression (in the code-generator sense, i.e. the
-number of lambdas at the beginning).
-\begin{code}
-exprArity :: CoreExpr -> Int
-exprArity (Lam x e)
- | isTyVar x = exprArity e
- | otherwise = 1 + exprArity e
-exprArity (Note _ e)
- -- Ignore coercions. Top level sccs are removed by the final
- -- profiling pass, so we ignore those too.
- = exprArity e
-exprArity _ = 0
-\end{code}
%************************************************************************
%* *
\begin{code}
-exprEtaExpandArity :: CoreExpr -> Int -- The number of args the thing can be applied to
- -- without doing much work
+exprEtaExpandArity :: CoreExpr -> (Int, Bool)
+-- 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
--
-- case x of p -> \s -> ...
-- because for I/O ish things we really want to get that \s to the top.
-- We are prepared to evaluate x each time round the loop in order to get that
--- Hence "generous" arity
+--
+-- Consider let x = expensive in \y z -> E
+-- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
+--
+-- Hence the list of Bools returned by go1
+-- NB: this is particularly important/useful for IO state
+-- transformers, where we often get
+-- let x = E in \ s -> ...
+-- and the \s is a real-world state token abstraction. Such
+-- abstractions are almost invariably 1-shot, so we want to
+-- pull the \s out, past the let x=E.
+-- The hack is in Id.isOneShotLambda
exprEtaExpandArity e
- = go e `max` 0 -- Never go -ve!
+ = go 0 e
where
- go (Var v) = idArity v
- go (App f (Type _)) = go f
- go (App f a) | exprIsCheap a = go f - 1
- go (Lam x e) | isId x = go e + 1
- | otherwise = go e
- go (Note n e) | ok_note n = go e
- go (Case scrut _ alts)
- | exprIsCheap scrut = min_zero [go rhs | (_,_,rhs) <- alts]
- go (Let b e)
- | all exprIsCheap (rhssOfBind b) = go e
-
- go other = 0
+ 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' = length (go1 other)
+
+ go1 :: CoreExpr -> [Bool]
+ -- (go1 e) = [b1,..,bn]
+ -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
+ -- where bi is True <=> the lambda is one-shot
+
+ go1 (Note n e) | ok_note n = go1 e
+ go1 (Var v) = replicate (idArity v) False -- When the type of the Id
+ -- encodes one-shot-ness, use
+ -- the idinfo here
+
+ -- Lambdas; increase arity
+ go1 (Lam x e) | isId x = isOneShotLambda x : go1 e
+ | otherwise = go1 e
+
+ -- Applications; decrease arity
+ go1 (App f (Type _)) = go1 f
+ go1 (App f a) = case go1 f of
+ (one_shot : xs) | one_shot || exprIsCheap a -> xs
+ other -> []
+
+ -- Case/Let; keep arity if either the expression is cheap
+ -- or it's a 1-shot lambda
+ go1 (Case scrut _ alts) = case foldr1 (zipWith (&&)) [go1 rhs | (_,_,rhs) <- alts] of
+ xs@(one_shot : _) | one_shot || exprIsCheap scrut -> xs
+ other -> []
+ go1 (Let b e) = case go1 e of
+ xs@(one_shot : _) | one_shot || all exprIsCheap (rhssOfBind b) -> xs
+ other -> []
+
+ go1 other = []
ok_note (Coerce _ _) = True
ok_note InlineCall = True
ok_note other = False
-- Notice that we do not look through __inline_me__
- -- This one is a bit more surprising, but consider
+ -- This may seem surprising, but consider
-- f = _inline_me (\x -> e)
-- We DO NOT want to eta expand this to
-- f = \x -> (_inline_me (\x -> e)) x
\end{code}
-\begin{pseudocode}
+\begin{code}
etaExpand :: Int -- Add this number of value args
- -> UniquSupply
+ -> UniqSupply
-> CoreExpr -> Type -- Expression and its type
- -> CoreEpxr
+ -> 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
-- would return
-- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
--- (case x of { I# x -> /\ a -> coerce T E)
-
etaExpand n us expr ty
| n == 0 -- Saturated, so nothing to do
= expr
= case splitForAllTy_maybe ty of {
Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
- Nothing ->
+ ; Nothing ->
case splitFunTy_maybe ty of {
- Just (arg_ty, res_ty) -> Lam arg' (etaExpand (n-1) us2 (App expr (Var arg')) res_ty)
+ Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
where
- arg' = mkSysLocal SLIT("eta") uniq arg_ty
- (us1, us2) = splitUnqiSupply us
- uniq = uniqFromSupply us1
+ arg1 = mkSysLocal SLIT("eta") uniq arg_ty
+ (us1, us2) = splitUniqSupply us
+ uniq = uniqFromSupply us1
- Nothing ->
+ ; Nothing ->
case splitNewType_maybe ty of {
- Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty')
+ Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
}}}
-\end{pseudocode}
+\end{code}
+
+
+exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
+It tells how many things the expression can be applied to before doing
+any work. It doesn't look inside cases, lets, etc. The idea is that
+exprEtaExpandArity will do the hard work, leaving something that's easy
+for exprArity to grapple with. In particular, Simplify uses exprArity to
+compute the ArityInfo for the Id.
+
+Originally I thought that it was enough just to look for top-level lambdas, but
+it isn't. I've seen this
+
+ foo = PrelBase.timesInt
+
+We want foo to get arity 2 even though the eta-expander will leave it
+unchanged, in the expectation that it'll be inlined. But occasionally it
+isn't, because foo is blacklisted (used in a rule).
+
+Similarly, see the ok_note check in exprEtaExpandArity. So
+ f = __inline_me (\x -> e)
+won't be eta-expanded.
+
+And in any case it seems more robust to have exprArity be a bit more intelligent.
+
+\begin{code}
+exprArity :: CoreExpr -> Int
+exprArity e = go e `max` 0
+ where
+ go (Lam x e) | isId x = go e + 1
+ | otherwise = go e
+ go (Note _ e) = go e
+ go (App e (Type t)) = go e
+ go (App f a) = go f - 1
+ go (Var v) = idArity v
+ go _ = 0
+\end{code}
%************************************************************************