\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,
+ exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe,
rhsIsStatic,
import VarEnv
import Name ( hashName, isDllName )
import Literal ( hashLiteral, literalType, litIsDupable,
- litIsTrivial, isZeroLit, isLitLitLit )
+ litIsTrivial, isZeroLit )
import DataCon ( DataCon, dataConRepArity, dataConArgTys,
- isExistentialDataCon, dataConTyCon, dataConName )
+ isExistentialDataCon, dataConTyCon )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo,
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
)
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)
mkSCC :: CostCentre -> Expr b -> Expr b
-- Note: Nested SCC's *are* preserved for the benefit of
-- cost centre stack profiling
- -- Note2: We throw away an SCC on a single variable. If the
- -- variable is a value, then there is no work to do in
- -- evaluating it, and if it is a thunk, then it will be
- -- attributed to its own CCS anyhow.
mkSCC cc (Lit lit) = Lit lit
-mkSCC cc (Var v) = Var v
mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
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
\end{code}
; 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
}}}
%* *
%************************************************************************
-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.
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 (Lit lit) = True
is_static in_arg other_expr = go other_expr 0
where
projects / ghc-hetmet.git / blobdiff