\begin{code}
module CoreUtils (
- exprType, coreAltsType,
-
-- Construction
mkNote, mkInlineMe, mkSCC, mkCoerce,
bindNonRec, mkIfThenElse, mkAltExpr,
+ mkPiType,
+ -- Properties of expressions
+ exprType, coreAltsType,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
- exprArity, exprIsConApp_maybe,
-
+ exprIsConApp_maybe, exprIsAtom,
idAppIsBottom, idAppIsCheap,
+ exprArity,
- etaReduceExpr, exprEtaExpandArity,
+ -- Expr transformation
+ etaReduce, etaExpand,
+ exprArity, exprEtaExpandArity,
-- Size
coreBindsSize,
import Var ( Var, isId, isTyVar )
import VarSet
import VarEnv
-import Name ( isLocallyDefined, hashName )
-import Literal ( Literal, hashLiteral, literalType )
+import Name ( hashName )
+import Literal ( hashLiteral, literalType, litIsDupable )
import DataCon ( DataCon, dataConRepArity )
-import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
-import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo, mkWildId,
- idArity, idName, idUnfolding, idInfo, isDataConId_maybe
-
+import PrimOp ( primOpOkForSpeculation, primOpIsCheap,
+ primOpIsDupable )
+import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo,
+ mkWildId, idArity, idName, idUnfolding, idInfo,
+ isDataConId_maybe, isPrimOpId_maybe, mkSysLocal, hasNoBinding
)
-import IdInfo ( arityLowerBound, InlinePragInfo(..),
- LBVarInfo(..),
+import IdInfo ( LBVarInfo(..),
IdFlavour(..),
megaSeqIdInfo )
import Demand ( appIsBottom )
-import Type ( Type, mkFunTy, mkForAllTy,
- splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
- isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
- applyTys, isUnLiftedType, seqType
+import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
+ applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
+ splitForAllTy_maybe, splitNewType_maybe
)
-import TysWiredIn ( boolTy, stringTy, trueDataCon, falseDataCon )
+import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
-import Unique ( buildIdKey, augmentIdKey )
-import Util ( zipWithEqual, mapAccumL )
+import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
import Maybes ( maybeToBool )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
exprType (Let _ body) = exprType body
exprType (Case _ _ alts) = coreAltsType alts
exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
-exprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (exprType e))
exprType (Note other_note e) = exprType e
-exprType (Lam binder expr)
- | isId binder = (case idLBVarInfo binder of
- IsOneShotLambda -> mkUsgTy UsOnce
- otherwise -> id) $
- idType binder `mkFunTy` exprType expr
- | isTyVar binder = mkForAllTy binder (exprType expr)
-
+exprType (Lam binder expr) = mkPiType binder (exprType expr)
exprType e@(App _ _)
= case collectArgs e of
(fun, args) -> applyTypeToArgs e (exprType fun) args
coreAltsType ((_,_,rhs) : _) = exprType rhs
\end{code}
+@mkPiType@ makes a (->) type or a forall type, depending on whether
+it is given a type variable or a term variable. We cleverly use the
+lbvarinfo field to figure out the right annotation for the arrove in
+case of a term variable.
+
+\begin{code}
+mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work...
+mkPiType v ty | isId v = (case idLBVarInfo v of
+ LBVarInfo u -> mkUTy u
+ otherwise -> id) $
+ mkFunTy (idType v) ty
+ | isTyVar v = mkForAllTy v ty
+\end{code}
+
\begin{code}
-- The first argument is just for debugging
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
applyTypeToArgs e op_ty (Type ty : args)
= -- Accumulate type arguments so we can instantiate all at once
- ASSERT2( all isNotUsgTy tys,
- ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+>
- ppr (Type ty : args) <+> text "i.e." <+> ppr tys )
applyTypeToArgs e (applyTys op_ty tys) rest_args
where
(tys, rest_args) = go [ty] args
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}
-mkCoerce :: Type -> Type -> Expr b -> Expr b
--- In (mkCoerce to_ty from_ty e), we require that from_ty = exprType e
--- But exprType is defined in CoreUtils, so we don't check the assertion
+mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
= ASSERT( from_ty == to_ty2 )
mkCoerce to_ty from_ty expr
| to_ty == from_ty = expr
- | otherwise = Note (Coerce to_ty from_ty) expr
+ | otherwise = ASSERT( from_ty == exprType expr )
+ Note (Coerce to_ty from_ty) expr
\end{code}
\begin{code}
%* *
%************************************************************************
-@exprIsTrivial@ is true of expressions we are unconditionally
- happy to duplicate; simple variables and constants,
- and type applications.
+@exprIsTrivial@ is true of expressions we are unconditionally happy to
+ duplicate; simple variables and constants, and type
+ applications. Note that primop Ids aren't considered
+ trivial unless
@exprIsBottom@ is true of expressions that are guaranteed to diverge
\begin{code}
-exprIsTrivial (Type _) = True
-exprIsTrivial (Lit lit) = True
-exprIsTrivial (Var v) = True
-exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
-exprIsTrivial (Note _ e) = exprIsTrivial e
-exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
-exprIsTrivial other = False
+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) = isTypeArg arg && exprIsTrivial e
+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 _ e) = exprIsAtom e
+exprIsAtom other = False
\end{code}
\begin{code}
exprIsDupable (Type _) = True
exprIsDupable (Var v) = True
-exprIsDupable (Lit lit) = True
+exprIsDupable (Lit lit) = litIsDupable lit
exprIsDupable (Note _ e) = exprIsDupable e
exprIsDupable expr
= go expr 0
* case e of
pi -> ei
+ (where e, and all the ei are cheap)
- where e, and all the ei are cheap; and
-
- * let x = e
- in b
-
- where e and b are cheap; and
+ * let x = e in b
+ (where e and b are cheap)
* op x1 ... xn
-
- where op is a cheap primitive operator
+ (where op is a cheap primitive operator)
* error "foo"
+ (because we are happy to substitute it inside a lambda)
Notice that a variable is considered 'cheap': we can push it inside a lambda,
because sharing will make sure it is only evaluated once.
exprIsCheap (Var _) = True
exprIsCheap (Note _ e) = exprIsCheap e
exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
-exprIsCheap (Case (Var v) _ alts) = and [exprIsCheap rhs | (_,_,rhs) <- alts]
+exprIsCheap (Case e _ alts) = exprIsCheap e &&
+ and [exprIsCheap rhs | (_,_,rhs) <- alts]
-- Experimentally, treat (case x of ...) as cheap
+ -- (and case __coerce x etc.)
-- This improves arities of overloaded functions where
-- there is only dictionary selection (no construction) involved
+exprIsCheap (Let (NonRec x _) e)
+ | isUnLiftedType (idType x) = exprIsCheap e
+ | otherwise = False
+ -- strict lets always have cheap right hand sides, and
+ -- do no allocation.
+
exprIsCheap other_expr
= go other_expr 0 True
where
|| idAppIsBottom f n_args
-- Application of a function which
- -- always gives bottom; we treat this as
- -- a WHNF, because it certainly doesn't
- -- need to be shared!
+ -- always gives bottom; we treat this 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
\end{code}
\begin{code}
-exprArity :: CoreExpr -> Int -- How many value lambdas are at the top
-exprArity (Lam b e) | isTyVar b = exprArity e
- | otherwise = 1 + exprArity e
-
-exprArity (Note note e) | ok_note note = exprArity e
- where
- ok_note (Coerce _ _) = True
- -- We *do* look through coerces when getting arities.
- -- Reason: arities are to do with *representation* and
- -- work duplication.
- ok_note InlineMe = True
- ok_note InlineCall = True
- ok_note other = False
- -- SCC and TermUsg might be over-conservative?
-
-exprArity other = 0
-\end{code}
-
-\begin{code}
exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
exprIsConApp_maybe expr
= analyse (collectArgs expr)
Just unf -> exprIsConApp_maybe unf
analyse other = Nothing
-\end{code}
+\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}
%************************************************************************
%* *
%************************************************************************
-@etaReduceExpr@ trys an eta reduction at the top level of a Core Expr.
+@etaReduce@ trys an eta reduction at the top level of a Core Expr.
e.g. \ x y -> f x y ===> f
head normal forms, so we don't want to chuck them away lightly.
\begin{code}
-etaReduceExpr :: CoreExpr -> CoreExpr
+etaReduce :: CoreExpr -> CoreExpr
-- ToDo: we should really check that we don't turn a non-bottom
-- lambda into a bottom variable. Sigh
-etaReduceExpr expr@(Lam bndr body)
+etaReduce expr@(Lam bndr body)
= check (reverse binders) body
where
(binders, body) = collectBinders expr
check _ _ = expr -- Bale out
-etaReduceExpr expr = expr -- The common case
+etaReduce expr = expr -- The common case
\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
--
-- Hence "generous" arity
exprEtaExpandArity e
- = go e
+ = go 0 e
where
- go (Var v) = idArity v
- go (App f (Type _)) = go f
- go (App f a) | exprIsCheap a = (go f - 1) `max` 0 -- Never go -ve!
- 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 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' = go1 other `max` 0
+
+ go1 (Var v) = idArity v
+ go1 (Lam x e) | isId x = go1 e + 1
+ | otherwise = go1 e
+ go1 (Note n e) | ok_note n = go1 e
+ go1 (App f (Type _)) = go1 f
+ go1 (App f a) | exprIsCheap a = go1 f - 1
+ go1 (Case scrut _ alts)
+ | exprIsCheap scrut = min_zero [go1 rhs | (_,_,rhs) <- alts]
+ go1 (Let b e)
+ | all exprIsCheap (rhssOfBind b) = go1 e
- go other = 0
+ go1 other = 0
ok_note (Coerce _ _) = True
ok_note InlineCall = True
\end{code}
+\begin{code}
+etaExpand :: Int -- Add this number of value args
+ -> UniqSupply
+ -> 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 deals with for-alls and coerces. For example:
+-- etaExpand 1 E
+-- where E :: forall a. T
+-- newtype T = MkT (A -> B)
+--
+-- 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
+
+ | otherwise -- An unsaturated constructor or primop; eta expand it
+ = case splitForAllTy_maybe ty of {
+ Just (tv,ty') -> Lam tv (etaExpand 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)
+ where
+ arg1 = mkSysLocal SLIT("eta") uniq arg_ty
+ (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
+ }}}
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Equality}
-- A measure of the size of the expressions
-- It also forces the expression pretty drastically as a side effect
exprSize (Var v) = varSize v
-exprSize (Lit lit) = 1
+exprSize (Lit lit) = lit `seq` 1
exprSize (App f a) = exprSize f + exprSize a
exprSize (Lam b e) = varSize b + exprSize e
exprSize (Let b e) = bindSize b + exprSize e
-exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
-exprSize (Note n e) = exprSize e
-exprSize (Type t) = seqType t `seq`
- 1
+exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
+exprSize (Note n e) = noteSize n + exprSize e
+exprSize (Type t) = seqType t `seq` 1
-exprsSize = foldr ((+) . exprSize) 0
+noteSize (SCC cc) = cc `seq` 1
+noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
+noteSize InlineCall = 1
+noteSize InlineMe = 1
varSize :: Var -> Int
-varSize b | isTyVar b = 1
- | otherwise = seqType (idType b) `seq`
- megaSeqIdInfo (idInfo b) `seq`
- 1
+varSize b | isTyVar b = 1
+ | otherwise = seqType (idType b) `seq`
+ megaSeqIdInfo (idInfo b) `seq`
+ 1
varsSize = foldr ((+) . varSize) 0