\begin{code}
module CoreUtils (
-- Construction
- mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
+ mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
bindNonRec, needsCaseBinding,
mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
-- Taking expressions apart
- findDefault, findAlt, hasDefault,
+ findDefault, findAlt,
-- Properties of expressions
- exprType, coreAltsType,
- exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
+ exprType, coreAltType,
+ exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
- exprIsConApp_maybe, exprIsAtom,
- idAppIsBottom, idAppIsCheap, rhsIsNonUpd,
+ exprIsConApp_maybe, exprIsBottom,
+ rhsIsStatic,
-- Arity and eta expansion
manifestArity, exprArity,
hashExpr,
-- Equality
- cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg,
-
- -- Cross-DLL references
- isCrossDllConApp,
+ cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
) where
#include "HsVersions.h"
import PprCore ( pprCoreExpr )
import Var ( Var, isId, isTyVar )
import VarEnv
-import Name ( hashName, isDllName )
+import Name ( hashName )
+import Packages ( isDllName )
+import CmdLineOpts ( DynFlags )
import Literal ( hashLiteral, literalType, litIsDupable,
- litIsTrivial, isZeroLit, isLitLitLit )
+ litIsTrivial, isZeroLit, Literal( MachLabel ) )
import DataCon ( DataCon, dataConRepArity, dataConArgTys,
- isExistentialDataCon, dataConTyCon, dataConName )
+ isVanillaDataCon, dataConTyCon )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo,
- isOneShotLambda, isDataConWorkId_maybe, mkSysLocal,
+ isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
isDataConWorkId, isBottomingId
)
import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
splitFunTy,
applyTys, isUnLiftedType, seqType, mkTyVarTy,
- splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
+ splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
splitTyConApp_maybe, eqType, funResultTy, applyTy,
funResultTy, applyTy
)
import TyCon ( tyConArity )
+-- gaw 2004
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
import BasicTypes ( Arity )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast )
-import TysPrim ( statePrimTyCon )
\end{code}
exprType (Var var) = idType var
exprType (Lit lit) = literalType lit
exprType (Let _ body) = exprType body
-exprType (Case _ _ alts) = coreAltsType alts
+-- gaw 2004
+exprType (Case _ _ ty alts) = ty
exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
exprType (Note other_note e) = exprType e
exprType (Lam binder expr) = mkPiType binder (exprType expr)
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
-coreAltsType :: [CoreAlt] -> Type
-coreAltsType ((_,_,rhs) : _) = exprType rhs
+coreAltType :: CoreAlt -> Type
+coreAltType (_,_,rhs) = exprType rhs
\end{code}
@mkPiType@ makes a (->) type or a forall type, depending on whether
mkNote removes redundant coercions, and SCCs where possible
\begin{code}
+#ifdef UNUSED
mkNote :: Note -> CoreExpr -> CoreExpr
mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
mkNote (SCC cc) expr = mkSCC cc expr
mkNote InlineMe expr = mkInlineMe expr
mkNote note expr = Note note expr
+#endif
-- Slide InlineCall in around the function
-- No longer necessary I think (SLPJ Apr 99)
-- 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
- | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
+-- gaw 2004
+ | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
| otherwise = Let (NonRec bndr rhs) body
needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse guard then_expr else_expr
- = Case guard (mkWildId boolTy)
+-- gaw 2004
+-- Not going to be refining, so okay to take the type of the "then" clause
+ = Case guard (mkWildId boolTy) (exprType then_expr)
[ (DataAlt trueDataCon, [], then_expr),
(DataAlt falseDataCon, [], else_expr) ]
\end{code}
This makes it easy to find, though it makes matching marginally harder.
\begin{code}
-hasDefault :: [CoreAlt] -> Bool
-hasDefault ((DEFAULT,_,_) : alts) = True
-hasDefault _ = False
-
findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
findDefault alts = (alts, Nothing)
rare that I plan to allow them to be duplicated and put up with
saturating them.
+SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
+ a) it really generates code, (and a heap object when it's
+ a function arg) to capture the cost centre
+ b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
+
\begin{code}
exprIsTrivial (Var v) = True -- See notes above
exprIsTrivial (Type _) = True
exprIsTrivial (Lit lit) = litIsTrivial lit
exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
-exprIsTrivial (Note _ e) = exprIsTrivial e
+exprIsTrivial (Note (SCC _) e) = False -- See notes above
+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}
\begin{code}
exprIsCheap :: CoreExpr -> Bool
-exprIsCheap (Lit lit) = True
-exprIsCheap (Type _) = True
-exprIsCheap (Var _) = True
-exprIsCheap (Note InlineMe e) = True
-exprIsCheap (Note _ e) = exprIsCheap e
-exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
-exprIsCheap (Case e _ alts) = exprIsCheap e &&
+exprIsCheap (Lit lit) = True
+exprIsCheap (Type _) = True
+exprIsCheap (Var _) = True
+exprIsCheap (Note InlineMe e) = True
+exprIsCheap (Note _ e) = exprIsCheap e
+exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
+-- gaw 2004
+exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
and [exprIsCheap rhs | (_,_,rhs) <- alts]
-- Experimentally, treat (case x of ...) as cheap
-- (and case __coerce x etc.)
-- counts as WHNF
| otherwise = case globalIdDetails id of
DataConWorkId _ -> True
- RecordSelId _ -> True -- I'm experimenting with making record selection
+ 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
exprIsBottom e = go 0 e
where
-- n is the number of args
- go n (Note _ e) = go n e
- go n (Let _ e) = go n e
- go n (Case e _ _) = go 0 e -- Just check the scrut
- go n (App e _) = go (n+1) e
- go n (Var v) = idAppIsBottom v n
- go n (Lit _) = False
- go n (Lam _ _) = False
+ go n (Note _ e) = go n e
+ go n (Let _ e) = go n e
+-- gaw 2004
+ go n (Case e _ _ _) = go 0 e -- Just check the scrut
+ go n (App e _) = go (n+1) e
+ go n (Var v) = idAppIsBottom v n
+ go n (Lit _) = False
+ go n (Lam _ _) = False
idAppIsBottom :: Id -> Int -> Bool
idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
case splitTyConApp_maybe to_ty of {
Nothing -> Nothing ;
- Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
- | isExistentialDataCon dc -> Nothing
- | otherwise ->
+ Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
+ | not (isVanillaDataCon dc) -> Nothing
+ | otherwise ->
-- Type constructor must match
-- We knock out existentials to keep matters simple(r)
let
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.
+one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
3. Dealing with bottom
-- | otherwise = ATop
arityType (Var v)
- = mk (idArity v)
+ = mk (idArity v) (arg_tys (idType v))
where
- mk :: Arity -> ArityType
- mk 0 | isBottomingId v = ABot
- | otherwise = ATop
- mk n = AFun False (mk (n-1))
-
- -- When the type of the Id encodes one-shot-ness,
- -- use the idinfo here
+ mk :: Arity -> [Type] -> ArityType
+ -- The argument types are only to steer the "state hack"
+ -- Consider case x of
+ -- True -> foo
+ -- False -> \(s:RealWorld) -> e
+ -- where foo has arity 1. Then we want the state hack to
+ -- apply to foo too, so we can eta expand the case.
+ mk 0 tys | isBottomingId v = ABot
+ | otherwise = ATop
+ mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
+ mk n [] = AFun False (mk (n-1) [])
+
+ arg_tys :: Type -> [Type] -- Ignore for-alls
+ arg_tys ty
+ | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
+ | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
+ | otherwise = []
-- Lambdas; increase arity
-arityType (Lam x e) | isId x = AFun (isOneShotLambda x || isStateHack x) (arityType e)
+arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
| otherwise = arityType e
-- Applications; decrease arity
-- Case/Let; keep arity if either the expression is cheap
-- or it's a 1-shot lambda
-arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
+ -- The former is not really right for Haskell
+ -- f x = case x of { (a,b) -> \y. e }
+ -- ===>
+ -- f x y = case x of { (a,b) -> e }
+ -- The difference is observable using 'seq'
+-- gaw 2004
+arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
xs@(AFun one_shot _) | one_shot -> xs
xs | exprIsCheap scrut -> xs
| otherwise -> ATop
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
; Nothing ->
-- Given this:
- -- newtype T = MkT (Int -> Int)
+ -- newtype T = MkT ([T] -> Int)
-- Consider eta-expanding this
-- eta_expand 1 e T
-- We want to get
- -- coerce T (\x::Int -> (coerce (Int->Int) e) x)
+ -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
+ -- Only try this for recursive newtypes; the non-recursive kind
+ -- are transparent anyway
- case splitNewType_maybe ty of {
+ case splitRecNewType_maybe ty of {
Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
- Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
+ Nothing -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
}}}
\end{code}
where
env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
eq_rhs (_,r1) (_,r2) = eq env' r1 r2
- eq env (Case e1 v1 a1)
- (Case e2 v2 a2) = eq env e1 e2 &&
+-- gaw 2004
+ eq env (Case e1 v1 t1 a1)
+ (Case e2 v2 t2 a2) = eq env e1 e2 &&
+ t1 `eqType` t2 &&
equalLength a1 a2 &&
and (zipWith (eq_alt env') a1 a2)
where
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) = v `seq` 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) = noteSize n + exprSize e
-exprSize (Type t) = seqType t `seq` 1
+exprSize (Var v) = v `seq` 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
+-- gaw 2004
+exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + 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
hash_expr (Note _ e) = hash_expr e
hash_expr (Let (NonRec b r) e) = hashId b
hash_expr (Let (Rec ((b,r):_)) e) = hashId b
-hash_expr (Case _ b _) = hashId b
+-- gaw 2004
+hash_expr (Case _ b _ _) = hashId b
hash_expr (App f e) = hash_expr f * fast_hash_expr e
hash_expr (Var v) = hashId v
hash_expr (Lit lit) = hashLiteral lit
%************************************************************************
%* *
-\subsection{Cross-DLL references}
+\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).
+Top-level constructor applications can usually be allocated
+statically, but they can't if the constructor, or any of the
+arguments, come from another DLL (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
+rhsIsStatic :: DynFlags -> 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)
--
--
-- 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 []
+
+rhsIsStatic dflags rhs = is_static False rhs
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.
+ 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)
+ = case lit of
+ MachLabel _ _ -> False
+ other -> True
+ -- A MachLabel (foreign import "&foo") in an argument
+ -- prevents a constructor application from being static. The
+ -- reason is that it might give rise to unresolvable symbols
+ -- in the object file: under Linux, references to "weak"
+ -- symbols from the data segment give rise to "unresolvable
+ -- relocation" errors at link time This might be due to a bug
+ -- in the linker, but we'll work around it here anyway.
+ -- SDM 24/2/2004
+
+ is_static in_arg other_expr = go other_expr 0
+ where
+ go (Var f) n_val_args
+ | not (isDllName dflags (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}