\begin{code}
module CoreUtils (
- exprType, coreAltsType,
-
+ -- Construction
mkNote, mkInlineMe, mkSCC, mkCoerce,
+ bindNonRec, mkIfThenElse, mkAltExpr,
+ mkPiType,
+ -- Properties of expressions
+ exprType, coreAltsType, exprArity,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
- exprArity,
-
+ exprIsConApp_maybe,
idAppIsBottom, idAppIsCheap,
+ -- Expr transformation
etaReduceExpr, exprEtaExpandArity,
+ -- Size
+ coreBindsSize,
+
+ -- Hashing
hashExpr,
+ -- Equality
cheapEqExpr, eqExpr, applyTypeToArgs
) where
#include "HsVersions.h"
-import {-# SOURCE #-} CoreUnfold ( isEvaldUnfolding )
-
import GlaExts -- For `xori`
import CoreSyn
import CoreFVs ( exprFreeVars )
import PprCore ( pprCoreExpr )
-import Var ( isId, isTyVar )
+import Var ( Var, isId, isTyVar )
import VarSet
import VarEnv
import Name ( isLocallyDefined, hashName )
-import Literal ( Literal, hashLiteral, literalType )
-import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
+import Literal ( Literal, hashLiteral, literalType, litIsDupable )
+import DataCon ( DataCon, dataConRepArity )
+import PrimOp ( primOpOkForSpeculation, primOpIsCheap,
+ primOpIsDupable )
import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo,
- idArity, idName, idUnfolding, idInfo
+ mkWildId, idArity, idName, idUnfolding, idInfo,
+ isDataConId_maybe, isPrimOpId_maybe
)
import IdInfo ( arityLowerBound, InlinePragInfo(..),
LBVarInfo(..),
IdFlavour(..),
- appIsBottom
- )
+ megaSeqIdInfo )
+import Demand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy,
splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
- applyTys, isUnLiftedType
+ applyTys, isUnLiftedType, seqType
)
+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
\end{code}
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
%************************************************************************
%* *
-\subsection{Attaching notes
+\subsection{Attaching notes}
%* *
%************************************************************************
\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}
%************************************************************************
%* *
+\subsection{Other expression construction}
+%* *
+%************************************************************************
+
+\begin{code}
+bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
+-- (bindNonRec x r b) produces either
+-- let x = r in b
+-- or
+-- case r of x { _DEFAULT_ -> b }
+--
+-- depending on whether x is unlifted or not
+-- It's used by the desugarer to avoid building bindings
+-- that give Core Lint a heart attack. Actually the simplifier
+-- deals with them perfectly well.
+bindNonRec bndr rhs body
+ | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
+ | otherwise = Let (NonRec bndr rhs) body
+\end{code}
+
+\begin{code}
+mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
+ -- This guy constructs the value that the scrutinee must have
+ -- when you are in one particular branch of a case
+mkAltExpr (DataAlt con) args inst_tys
+ = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
+mkAltExpr (LitAlt lit) [] []
+ = Lit lit
+
+mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
+mkIfThenElse guard then_expr else_expr
+ = Case guard (mkWildId boolTy)
+ [ (DataAlt trueDataCon, [], then_expr),
+ (DataAlt falseDataCon, [], else_expr) ]
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Figuring out things about expressions}
%* *
%************************************************************************
-@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)
+ | Just op <- isPrimOpId_maybe v = primOpIsDupable op
+ | 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
\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
exprArity other = 0
\end{code}
+\begin{code}
+exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
+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
+
+ analyse (Var fun, [])
+ = case maybeUnfoldingTemplate (idUnfolding fun) of
+ Nothing -> Nothing
+ Just unf -> exprIsConApp_maybe unf
+
+ analyse other = Nothing
+\end{code}
+
%************************************************************************
%* *
-- 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
eq_note env other1 other2 = False
\end{code}
+
+%************************************************************************
+%* *
+\subsection{The size of an expression}
+%* *
+%************************************************************************
+
+\begin{code}
+coreBindsSize :: [CoreBind] -> Int
+coreBindsSize bs = foldr ((+) . bindSize) 0 bs
+
+exprSize :: CoreExpr -> Int
+ -- 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) = 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) = noteSize n + exprSize e
+exprSize (Type t) = seqType t `seq` 1
+
+noteSize (SCC cc) = cc `seq` 1
+noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
+noteSize InlineCall = 1
+noteSize InlineMe = 1
+noteSize (TermUsg usg) = usg `seq` 1
+
+exprsSize = foldr ((+) . exprSize) 0
+
+varSize :: Var -> Int
+varSize b | isTyVar b = 1
+ | otherwise = seqType (idType b) `seq`
+ megaSeqIdInfo (idInfo b) `seq`
+ 1
+
+varsSize = foldr ((+) . varSize) 0
+
+bindSize (NonRec b e) = varSize b + exprSize e
+bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
+
+pairSize (b,e) = varSize b + exprSize e
+
+altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Hashing}
projects / ghc-hetmet.git / blobdiff