exprIsValue,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsAtom,
idAppIsBottom, idAppIsCheap,
- exprArity,
- -- Expr transformation
- etaReduce, etaExpand,
- exprArity, exprEtaExpandArity,
+
+ -- Arity and eta expansion
+ manifestArity, exprArity,
+ exprEtaExpandArity, etaExpand,
-- 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 Literal ( hashLiteral, literalType, litIsDupable, isZeroLit )
import DataCon ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon )
-import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
+import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo,
mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
- isDataConId_maybe, mkSysLocal, hasNoBinding, isDataConId, isBottomingId
+ isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId
)
import IdInfo ( LBVarInfo(..),
GlobalIdDetails(..),
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 )
@exprIsBottom@ is true of expressions that are guaranteed to diverge
+There used to be a gruesome test for (hasNoBinding v) in the
+Var case:
+ exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
+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.
+But now constructor workers are not "have-no-binding" Ids. And
+completely un-applied primops and foreign-call Ids are sufficiently
+rare that I plan to allow them to be duplicated and put up with
+saturating them.
+
\begin{code}
-exprIsTrivial (Var v)
- | 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 (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
-exprIsTrivial (Note _ e) = exprIsTrivial e
-exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
-exprIsTrivial other = False
+exprIsTrivial (Var v) = True -- See notes above
+exprIsTrivial (Type _) = True
+exprIsTrivial (Lit lit) = True
+exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
+exprIsTrivial (Note _ e) = exprIsTrivial e
+exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
+exprIsTrivial other = False
exprIsAtom :: CoreExpr -> Bool
-- Used to decide whether to let-binding an STG argument
\begin{code}
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation (Lit _) = True
+exprOkForSpeculation (Type _) = True
exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
exprOkForSpeculation other_expr
- = go other_expr 0 True
+ = case collectArgs other_expr of
+ (Var f, args) -> spec_ok (globalIdDetails f) args
+ other -> False
+
where
- go (Var f) n_args args_ok
- = 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
-
- PrimOpId op -> primOpOkForSpeculation op && args_ok
+ spec_ok (DataConId _) args
+ = True -- The strictness of the constructor has already
+ -- been expressed by its "wrapper", so we don't need
+ -- to take the arguments into account
+
+ spec_ok (PrimOpId op) args
+ | isDivOp op, -- Special case for dividing operations that fail
+ [arg1, Lit lit] <- args -- only if the divisor is zero
+ = not (isZeroLit lit) && exprOkForSpeculation arg1
+ -- Often there is a literal divisor, and this
+ -- can get rid of a thunk in an inner looop
+
+ | otherwise
+ = primOpOkForSpeculation op &&
+ all exprOkForSpeculation args
-- A bit conservative: we don't really need
-- to care about lazy arguments, but this is easy
- other -> False
-
- go (App f a) n_args 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
+ spec_ok other args = False
+
+isDivOp :: PrimOp -> Bool
+-- True of dyadic operators that can fail
+-- only if the second arg is zero
+-- This function probably belongs in PrimOp, or even in
+-- an automagically generated file.. but it's such a
+-- special case I thought I'd leave it here for now.
+isDivOp IntQuotOp = True
+isDivOp IntRemOp = True
+isDivOp WordQuotOp = True
+isDivOp WordRemOp = True
+isDivOp IntegerQuotRemOp = True
+isDivOp IntegerDivModOp = True
+isDivOp FloatDivOp = True
+isDivOp DoubleDivOp = True
+isDivOp other = False
\end{code}
%* *
%************************************************************************
-@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
+eta_expand n us (Note note@(Coerce _ ty) e) _
+ = Note note (eta_expand n us e ty)
+
+ -- Use mkNote so that _scc_s get pushed inside any lambdas that
+ -- are generated as part of the eta expansion. We rely on this
+ -- behaviour in CorePrep, when we eta expand an already-prepped RHS.
+eta_expand n us (Note note e) ty
+ = mkNote note (eta_expand n us e ty)
+
+ -- Short cut for the case where there already
+ -- is a lambda; no point in gratuitously adding more
+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