mkPiType,
-- Taking expressions apart
- findDefault, findAlt,
+ findDefault, findAlt, hasDefault,
-- Properties of expressions
exprType, coreAltsType,
exprIsValue,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsAtom,
idAppIsBottom, idAppIsCheap,
- exprArity,
+ exprArity,
-- Expr transformation
etaReduce, etaExpand,
import Name ( hashName )
import Literal ( hashLiteral, literalType, litIsDupable )
import DataCon ( DataCon, dataConRepArity )
-import PrimOp ( primOpOkForSpeculation, primOpIsCheap,
- primOpIsDupable )
+import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo,
mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
- isDataConId_maybe, isPrimOpId_maybe, mkSysLocal, hasNoBinding
+ isDataConId_maybe, mkSysLocal, hasNoBinding
)
import IdInfo ( LBVarInfo(..),
GlobalIdDetails(..),
import Demand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
- splitForAllTy_maybe, splitNewType_maybe
+ splitForAllTy_maybe, isForAllTy, eqType
)
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
-import Maybes ( maybeToBool )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
\end{code}
mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
- = ASSERT( from_ty == to_ty2 )
+ = ASSERT( from_ty `eqType` to_ty2 )
mkCoerce to_ty from_ty2 expr
mkCoerce to_ty from_ty expr
- | to_ty == from_ty = expr
- | otherwise = ASSERT( from_ty == exprType expr )
- Note (Coerce to_ty from_ty) expr
+ | to_ty `eqType` from_ty = expr
+ | otherwise = ASSERT( from_ty `eqType` exprType expr )
+ Note (Coerce to_ty from_ty) expr
\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}
%* *
%************************************************************************
+The default alternative must be first, if it exists at all.
+This makes it easy to find, though it makes matching marginally harder.
\begin{code}
+hasDefault :: [CoreAlt] -> Bool
+hasDefault ((DEFAULT,_,_) : alts) = True
+hasDefault _ = False
+
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)
+findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
+findDefault alts = (alts, Nothing)
findAlt :: AltCon -> [CoreAlt] -> CoreAlt
findAlt con alts
- = go alts
+ = case alts of
+ (deflt@(DEFAULT,_,_):alts) -> go alts deflt
+ other -> go alts panic_deflt
+
where
- go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
- go (alt : alts) | matches alt = alt
- | otherwise = go alts
+ panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
- matches (DEFAULT, _, _) = True
- matches (con1, _, _) = con == con1
+ go [] deflt = deflt
+ go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
+ | otherwise = ASSERT( not (con1 == DEFAULT) )
+ go alts deflt
\end{code}
| otherwise = True
exprIsTrivial (Type _) = True
exprIsTrivial (Lit lit) = True
-exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
+exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
exprIsTrivial (Note _ e) = exprIsTrivial e
-exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
+exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
exprIsTrivial other = False
exprIsAtom :: CoreExpr -> Bool
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 (Lam x e) = isRuntimeVar x || exprIsCheap e
exprIsCheap (Case e _ alts) = exprIsCheap e &&
and [exprIsCheap rhs | (_,_,rhs) <- alts]
-- Experimentally, treat (case x of ...) as cheap
-- because it certainly doesn't need to be shared!
go (App f a) n_args args_cheap
- | isTypeArg a = go f n_args args_cheap
- | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
+ | not (isRuntimeArg a) = go f n_args args_cheap
+ | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
go other n_args args_cheap = False
other -> False
go (App f a) n_args args_ok
- | isTypeArg a = go f n_args args_ok
- | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
+ | not (isRuntimeArg a) = go f n_args args_ok
+ | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
go other n_args args_ok = False
\end{code}
\end{code}
@exprIsValue@ returns true for expressions that are certainly *already*
-evaluated to WHNF. This is used to decide wether it's ok to change
+evaluated to WHNF. This is used to decide whether it's ok to change
case x of _ -> e ===> e
and to decide whether it's safe to discard a `seq`
exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
-- copying them
exprIsValue (Lit l) = True
-exprIsValue (Lam b e) = isId b || exprIsValue e
+exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
exprIsValue (Note _ e) = exprIsValue e
exprIsValue other_expr
= go other_expr 0
go (Var f) n_args = idAppIsValue f n_args
go (App f a) n_args
- | isTypeArg a = go f n_args
- | otherwise = go f (n_args + 1)
+ | not (isRuntimeArg a) = go f n_args
+ | otherwise = go f (n_args + 1)
go (Note _ f) n_args = go f n_args
\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)
| Just con <- isDataConId_maybe fun,
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}
%************************************************************************
--
-- 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 extra Bool returned by go1
+--
+-- 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 -> ...
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
- -- th iinfo here
+ -- the idinfo here
-- Lambdas; increase arity
go1 (Lam x e) | isId x = isOneShotLambda x : go1 e
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
-- giving just
-- f = \x -> e
-- A Bad Idea
-
-min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
-min_zero (x:xs) = go x xs
- where
- go 0 xs = 0 -- Nothing beats zero
- go min [] = min
- go min (x:xs) | x < min = go x xs
- | otherwise = go min xs
-
\end{code}
-- 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
+ | 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
+ -- may be. So we eagerly eta expand any big lambdas, and just
+ -- cross our fingers about possible loss of sharing in the
+ -- ILX case.
+ -- The Right Thing is probably to make 'arity' include
+ -- type variables throughout the compiler. (ToDo.)
+ not (isForAllTy ty)
+ -- Saturated, so nothing to do
= expr
| otherwise -- An unsaturated constructor or primop; eta expand it
(us1, us2) = splitUniqSupply us
uniq = uniqFromSupply us1
- ; Nothing ->
-
- case splitNewType_maybe ty of {
- Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
-
- Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
- }}}
+ ; Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
+ }}
+\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) | exprIsCheap a = go f - 1
+ -- Important! f (fac x) does not have arity 2,
+ -- even if f does!
+ go (Var v) = idArity v
+ go _ = 0
\end{code}
cheapEqExpr (Var v1) (Var v2) = v1==v2
cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
-cheapEqExpr (Type t1) (Type t2) = t1 == t2
+cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
cheapEqExpr (App f1 a1) (App f2 a2)
= f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
\begin{code}
eqExpr :: CoreExpr -> CoreExpr -> Bool
-- Works ok at more general type, but only needed at CoreExpr
+ -- Used in rule matching, so when we find a type we use
+ -- eqTcType, which doesn't look through newtypes
+ -- [And it doesn't risk falling into a black hole either.]
eqExpr e1 e2
= eq emptyVarEnv e1 e2
where
env' = extendVarEnv env v1 v2
eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
- eq env (Type t1) (Type t2) = t1 == t2
+ eq env (Type t1) (Type t2) = t1 `eqType` t2
eq env e1 e2 = False
eq_list env [] [] = True
eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
- eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
+ eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
eq_note env InlineCall InlineCall = True
eq_note env other1 other2 = False
\end{code}