\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,
idAppIsBottom, idAppIsCheap,
+ -- Expr transformation
etaReduceExpr, exprEtaExpandArity,
-- Size
import VarSet
import VarEnv
import Name ( isLocallyDefined, hashName )
-import Literal ( Literal, hashLiteral, literalType )
+import Literal ( Literal, hashLiteral, literalType, litIsDupable )
import DataCon ( DataCon, dataConRepArity )
import PrimOp ( primOpOkForSpeculation, primOpIsCheap,
primOpIsDupable )
)
import TysWiredIn ( boolTy, stringTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
-import Unique ( buildIdKey, augmentIdKey )
-import Util ( zipWithEqual, mapAccumL )
import Maybes ( maybeToBool )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
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
+ IsOneShotLambda -> mkUsgTy UsOnce
+ 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
applications. Note that primop Ids aren't considered
trivial unless
-
@exprIsBottom@ is true of expressions that are guaranteed to diverge
\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)
-- Hence "generous" arity
exprEtaExpandArity e
- = go e
+ = go e `max` 0 -- Never go -ve!
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 (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
projects / ghc-hetmet.git / blobdiff