exprType, coreAltsType,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
- exprIsConApp_maybe, exprIsAtom,
- idAppIsBottom, idAppIsCheap,
-
+ exprIsConApp_maybe,
+ rhsIsStatic,
-- Arity and eta expansion
manifestArity, exprArity,
#include "HsVersions.h"
-import GlaExts -- For `xori`
+import GLAEXTS -- For `xori`
import CoreSyn
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,
- isDataConId_maybe, mkSysLocal, isDataConId, 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,
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast )
+import TysPrim ( statePrimTyCon )
\end{code}
\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
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 (SCC _) e) = False
-exprIsAtom (Note _ e) = exprIsAtom e
-exprIsAtom other = False
\end{code}
-- a variable (f t1 t2 t3)
-- counts as WHNF
| otherwise = case globalIdDetails id of
- DataConId _ -> True
- RecordSelId _ -> True -- I'm experimenting with making record selection
- -- look cheap, so we will substitute it inside a
- -- lambda. Particularly for dictionary field selection
+ DataConWorkId _ -> True
+ RecordSelId _ -> True -- I'm experimenting with making record selection
+ 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
-- that return a type variable, since the result
other -> False
where
- spec_ok (DataConId _) args
+ spec_ok (DataConWorkId _) 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
\begin{code}
exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
-exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
- -- copying them
-exprIsValue (Lit l) = True
-exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
-exprIsValue (Note _ e) = exprIsValue e
-exprIsValue (Var v) = idArity v > 0 || isEvaldUnfolding (idUnfolding v)
- -- The idArity case catches data cons and primops that
- -- don't have unfoldings
+exprIsValue (Var v) -- NB: There are no value args at this point
+ = isDataConWorkId v -- Catches nullary constructors,
+ -- so that [] and () are values, for example
+ || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
+ || isEvaldUnfolding (idUnfolding v)
+ -- Check the thing's unfolding; it might be bound to a value
-- A worry: what if an Id's unfolding is just itself:
-- then we could get an infinite loop...
-exprIsValue other_expr
- | (Var fun, args) <- collectArgs other_expr,
- isDataConId fun || valArgCount args < idArity fun
- = check (idType fun) args
- | otherwise
- = False
+
+exprIsValue (Lit l) = True
+exprIsValue (Type ty) = True -- Types are honorary Values;
+ -- we don't mind copying them
+exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
+exprIsValue (Note _ e) = exprIsValue e
+exprIsValue (App e (Type _)) = exprIsValue e
+exprIsValue (App e a) = app_is_value e [a]
+exprIsValue other = False
+
+-- There is at least one value argument
+app_is_value (Var fun) args
+ | isDataConWorkId fun -- Constructor apps are values
+ || idArity fun > valArgCount args -- Under-applied function
+ = check_args (idType fun) args
+app_is_value (App f a) as = app_is_value f (a:as)
+app_is_value other as = False
+
+ -- 'check_args' checks that unlifted-type args
+ -- are in fact guaranteed non-divergent
+check_args fun_ty [] = True
+check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
+ Just (_, ty) -> check_args ty args
+check_args fun_ty (arg : args)
+ | isUnLiftedType arg_ty = exprOkForSpeculation arg
+ | otherwise = check_args res_ty args
where
- -- 'check' checks that unlifted-type args are in
- -- fact guaranteed non-divergent
- check fun_ty [] = True
- check fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
- Just (_, ty) -> check ty args
- check fun_ty (arg : args)
- | isUnLiftedType arg_ty = exprOkForSpeculation arg
- | otherwise = check res_ty args
- where
- (arg_ty, res_ty) = splitFunTy fun_ty
+ (arg_ty, res_ty) = splitFunTy fun_ty
\end{code}
\begin{code}
exprIsConApp_maybe expr = analyse (collectArgs expr)
where
analyse (Var fun, args)
- | Just con <- isDataConId_maybe fun,
+ | Just con <- isDataConWorkId_maybe fun,
args `lengthAtLeast` dataConRepArity con
-- Might be > because the arity excludes type args
= Just (con,args)
\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)
-- use the idinfo here
-- Lambdas; increase arity
-arityType (Lam x e) | isId x = AFun (isOneShotLambda x) (arityType e)
+arityType (Lam x e) | isId x = AFun (isOneShotLambda x || isStateHack x) (arityType e)
| otherwise = arityType e
-- Applications; decrease arity
arityType (App f (Type _)) = arityType f
arityType (App f a) = case arityType f of
- AFun one_shot xs | one_shot -> xs
- | exprIsCheap a -> xs
+ AFun one_shot xs | exprIsCheap a -> xs
other -> ATop
-- Case/Let; keep arity if either the expression is cheap
arityType other = ATop
+isStateHack id = case splitTyConApp_maybe (idType id) of
+ Just (tycon,_) | tycon == statePrimTyCon -> True
+ other -> False
+
+ -- The last clause is a gross hack. It claims that
+ -- every function over realWorldStatePrimTy is a one-shot
+ -- function. This is pretty true in practice, and makes a big
+ -- difference. For example, consider
+ -- a `thenST` \ r -> ...E...
+ -- The early full laziness pass, if it doesn't know that r is one-shot
+ -- will pull out E (let's say it doesn't mention r) to give
+ -- let lvl = E in a `thenST` \ r -> ...lvl...
+ -- When `thenST` gets inlined, we end up with
+ -- let lvl = E in \s -> case a s of (r, s') -> ...lvl...
+ -- and we don't re-inline E.
+ --
+ -- It would be better to spot that r was one-shot to start with, but
+ -- I don't want to rely on that.
+ --
+ -- Another good example is in fill_in in PrelPack.lhs. We should be able to
+ -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
+
{- NOT NEEDED ANY MORE: etaExpand is cleverer
ok_note InlineMe = False
ok_note other = True
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{Determining non-updatable right-hand-sides}
+%* *
+%************************************************************************
+
+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.
+
+\begin{code}
+rhsIsStatic :: CoreExpr -> Bool
+-- This function is called only on *top-level* right-hand sides
+-- Returns True if the RHS can be allocated statically, with
+-- no thunks involved at all.
+--
+-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
+-- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
+-- update flag on it.
+--
+-- The basic idea is that rhsIsStatic returns True only if the RHS is
+-- (a) a value lambda
+-- (b) a saturated constructor application with static args
+--
+-- BUT watch out for
+-- (i) Any cross-DLL references kill static-ness completely
+-- because they must be 'executed' not statically allocated
+--
+-- (ii) We treat partial applications as redexes, because in fact we
+-- make a thunk for them that runs and builds a PAP
+-- at run-time. The only appliations that are treated as
+-- static are *saturated* applications of constructors.
+
+-- We used to try to be clever with nested structures like this:
+-- ys = (:) w ((:) w [])
+-- on the grounds that CorePrep will flatten ANF-ise it later.
+-- But supporting this special case made the function much more
+-- complicated, because the special case only applies if there are no
+-- enclosing type lambdas:
+-- ys = /\ a -> Foo (Baz ([] a))
+-- Here the nested (Baz []) won't float out to top level in CorePrep.
+--
+-- But in fact, even without -O, nested structures at top level are
+-- flattened by the simplifier, so we don't need to be super-clever here.
+--
+-- Examples
+--
+-- f = \x::Int. x+7 TRUE
+-- p = (True,False) TRUE
+--
+-- d = (fst p, False) FALSE because there's a redex inside
+-- (this particular one doesn't happen but...)
+--
+-- h = D# (1.0## /## 2.0##) FALSE (redex again)
+-- n = /\a. Nil a TRUE
+--
+-- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
+--
+--
+-- 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).
+
+rhsIsStatic rhs = is_static False rhs
+
+is_static :: Bool -- True <=> in a constructor argument; must be atomic
+ -> CoreExpr -> Bool
+
+is_static False (Lam b e) = isRuntimeVar b || is_static False e
+
+is_static in_arg (Note (SCC _) e) = False
+is_static in_arg (Note _ e) = is_static in_arg e
+
+is_static in_arg (Lit lit) = not (isLitLitLit lit)
+ -- lit-lit arguments cannot be used in static constructors either.
+ -- (litlits are deprecated, so I'm not going to bother cleaning up this infelicity --SDM).
+
+is_static in_arg other_expr = go other_expr 0
+ where
+ go (Var f) n_val_args
+ | not (isDllName (idName f))
+ = saturated_data_con f n_val_args
+ || (in_arg && n_val_args == 0)
+ -- A naked un-applied variable is *not* deemed a static RHS
+ -- E.g. f = g
+ -- Reason: better to update so that the indirection gets shorted
+ -- out, and the true value will be seen
+ -- NB: if you change this, you'll break the invariant that THUNK_STATICs
+ -- are always updatable. If you do so, make sure that non-updatable
+ -- ones have enough space for their static link field!
+
+ go (App f a) n_val_args
+ | isTypeArg a = go f n_val_args
+ | not in_arg && is_static True a = go f (n_val_args + 1)
+ -- The (not in_arg) checks that we aren't in a constructor argument;
+ -- if we are, we don't allow (value) applications of any sort
+ --
+ -- NB. In case you wonder, args are sometimes not atomic. eg.
+ -- x = D# (1.0## /## 2.0##)
+ -- can't float because /## can fail.
+
+ go (Note (SCC _) f) n_val_args = False
+ go (Note _ f) n_val_args = go f n_val_args
+
+ go other n_val_args = False
+
+ saturated_data_con f n_val_args
+ = case isDataConWorkId_maybe f of
+ Just dc -> n_val_args == dataConRepArity dc
+ Nothing -> False
+\end{code}
projects / ghc-hetmet.git / blobdiff