exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsAtom,
- idAppIsBottom, idAppIsCheap,
-
+ idAppIsBottom, idAppIsCheap, rhsIsNonUpd,
-- Arity and eta expansion
manifestArity, exprArity,
hashExpr,
-- Equality
- cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
+ cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg,
+
+ -- Cross-DLL references
+ isCrossDllConApp,
) where
#include "HsVersions.h"
import PprCore ( pprCoreExpr )
import Var ( Var, isId, isTyVar )
import VarEnv
-import Name ( hashName )
-import Literal ( hashLiteral, literalType, litIsDupable, isZeroLit )
-import DataCon ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon )
+import Name ( hashName, isDllName )
+import Literal ( hashLiteral, literalType, litIsDupable,
+ litIsTrivial, isZeroLit, isLitLitLit )
+import DataCon ( DataCon, dataConRepArity, dataConArgTys,
+ isExistentialDataCon, dataConTyCon, dataConName )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
- mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
- isDataConWorkId_maybe, mkSysLocal, isDataConWorkId, isBottomingId
+ mkWildId, idArity, idName, idUnfolding, idInfo,
+ isOneShotLambda, isDataConWorkId_maybe, mkSysLocal,
+ isDataConWorkId, isBottomingId
)
-import IdInfo ( GlobalIdDetails(..),
- megaSeqIdInfo )
+import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
import NewDemand ( appIsBottom )
-import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
+import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
+ splitFunTy,
applyTys, isUnLiftedType, seqType, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
splitTyConApp_maybe, eqType, funResultTy, applyTy,
\begin{code}
exprIsTrivial (Var v) = True -- See notes above
exprIsTrivial (Type _) = True
-exprIsTrivial (Lit lit) = True
+exprIsTrivial (Lit lit) = litIsTrivial lit
exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
exprIsTrivial (Note _ e) = exprIsTrivial e
exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
| otherwise = case globalIdDetails id of
DataConWorkId _ -> True
RecordSelId _ -> True -- I'm experimenting with making record selection
- -- look cheap, so we will substitute it inside a
+ ClassOpId _ -> True -- look cheap, so we will substitute it inside a
-- lambda. Particularly for dictionary field selection
PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
\begin{code}
exprEtaExpandArity :: CoreExpr -> Arity
--- The Int is number of value args the thing can be
--- applied to without doing much work
---
--- This is used when eta expanding
--- e ==> \xy -> e x y
---
--- It returns 1 (or more) to:
--- case x of p -> \s -> ...
--- because for I/O ish things we really want to get that \s to the top.
--- We are prepared to evaluate x each time round the loop in order to get that
-
--- It's all a bit more subtle than it looks. Consider one-shot lambdas
--- 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 ArityType returned by arityType
-
--- NB: this is particularly important/useful for IO state
--- transformers, where we often get
--- let x = E in \ s -> ...
--- and the \s is a real-world state token abstraction. Such
--- abstractions are almost invariably 1-shot, so we want to
--- pull the \s out, past the let x=E.
--- The hack is in Id.isOneShotLambda
---
--- Consider also
--- f = \x -> error "foo"
--- Here, arity 1 is fine. But if it is
--- f = \x -> case e of
--- True -> error "foo"
--- False -> \y -> x+y
--- then we want to get arity 2.
--- Hence the ABot/ATop in ArityType
+{- The Arity returned is the number of value args the
+ thing can be applied to without doing much work
+
+exprEtaExpandArity is used when eta expanding
+ e ==> \xy -> e x y
+
+It returns 1 (or more) to:
+ case x of p -> \s -> ...
+because for I/O ish things we really want to get that \s to the top.
+We are prepared to evaluate x each time round the loop in order to get that
+
+It's all a bit more subtle than it looks:
+
+1. One-shot lambdas
+
+Consider one-shot lambdas
+ 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 ArityType returned by arityType
+
+2. The state-transformer hack
+
+The one-shot lambda special cause is particularly important/useful for
+IO state transformers, where we often get
+ let x = E in \ s -> ...
+
+and the \s is a real-world state token abstraction. Such abstractions
+are almost invariably 1-shot, so we want to pull the \s out, past the
+let x=E, even if E is expensive. So we treat state-token lambdas as
+one-shot even if they aren't really. The hack is in Id.isOneShotLambda.
+
+3. Dealing with bottom
+
+Consider also
+ f = \x -> error "foo"
+Here, arity 1 is fine. But if it is
+ f = \x -> case x of
+ True -> error "foo"
+ False -> \y -> x+y
+then we want to get arity 2. Tecnically, this isn't quite right, because
+ (f True) `seq` 1
+should diverge, but it'll converge if we eta-expand f. Nevertheless, we
+do so; it improves some programs significantly, and increasing convergence
+isn't a bad thing. Hence the ABot/ATop in ArityType.
+
+Actually, the situation is worse. Consider
+ f = \x -> case x of
+ True -> \y -> x+y
+ False -> \y -> x-y
+Can we eta-expand here? At first the answer looks like "yes of course", but
+consider
+ (f bot) `seq` 1
+This should diverge! But if we eta-expand, it won't. Again, we ignore this
+"problem", because being scrupulous would lose an important transformation for
+many programs.
+-}
exprEtaExpandArity e = arityDepth (arityType e)
eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
eq_note env InlineCall InlineCall = True
+ eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
eq_note env other1 other2 = False
\end{code}
noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
noteSize InlineCall = 1
noteSize InlineMe = 1
+noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
varSize :: Var -> Int
varSize b | isTyVar b = 1
hashId :: Id -> Int
hashId id = hashName (idName id)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Cross-DLL references}
+%* *
+%************************************************************************
+
+Top-level constructor applications can usually be allocated
+statically, but they can't if
+ a) the constructor, or any of the arguments, come from another DLL
+ b) any of the arguments are LitLits
+(because we can't refer to static labels in other DLLs).
+
+If this happens we simply make the RHS into an updatable thunk,
+and 'exectute' it rather than allocating it statically.
+
+We also catch lit-lit arguments here, because those cannot be used in
+static constructors either. (litlits are deprecated, so I'm not going
+to bother cleaning up this infelicity --SDM).
+
+\begin{code}
+isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
+isCrossDllConApp con args =
+ isDllName (dataConName con) || any isCrossDllArg args
+
+isCrossDllArg :: CoreExpr -> Bool
+-- True if somewhere in the expression there's a cross-DLL reference
+isCrossDllArg (Type _) = False
+isCrossDllArg (Var v) = isDllName (idName v)
+isCrossDllArg (Note _ e) = isCrossDllArg e
+isCrossDllArg (Lit lit) = isLitLitLit lit
+isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2
+ -- must be a type app
+isCrossDllArg (Lam v e) = isCrossDllArg e
+ -- must be a type lam
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Determining non-updatable right-hand-sides}
+%* *
+%************************************************************************
+
+\begin{code}
+rhsIsNonUpd :: CoreExpr -> Bool
+-- True => Value-lambda, saturated constructor
+-- This is a bit like CoreUtils.exprIsValue, with the following differences:
+-- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
+--
+-- b) (C x xs), where C is a contructors is updatable if the application is
+-- dynamic
+--
+-- c) don't look through unfolding of f in (f x).
+--
+-- When opt_RuntimeTypes is on, we keep type lambdas and treat
+-- them as making the RHS re-entrant (non-updatable).
+--
+rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e
+rhsIsNonUpd (Note (SCC _) e) = False
+rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
+rhsIsNonUpd other_expr
+ = go other_expr 0 []
+ where
+ go (Var f) n_args args = idAppIsNonUpd f n_args args
+
+ go (App f a) n_args args
+ | isTypeArg a = go f n_args args
+ | otherwise = go f (n_args + 1) (a:args)
+
+ go (Note (SCC _) f) n_args args = False
+ go (Note _ f) n_args args = go f n_args args
+
+ go other n_args args = False
+
+idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
+idAppIsNonUpd id n_val_args args
+ -- saturated constructors are not updatable
+ | Just con <- isDataConWorkId_maybe id,
+ n_val_args == dataConRepArity con,
+ not (isCrossDllConApp con args),
+ all exprIsAtom args
+ = True
+ -- NB. args sometimes not atomic. eg.
+ -- x = D# (1.0## /## 2.0##)
+ -- can't float because /## can fail.
+
+ | otherwise = False
+ -- Historical note: we used to make partial applications
+ -- non-updatable, so they behaved just like PAPs, but this
+ -- doesn't work too well with eval/apply so it is disabled
+ -- now.
+\end{code}
projects / ghc-hetmet.git / blobdiff