\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, Literal( MachLabel ) )
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,
- 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 Outputable
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast )
-import TysPrim ( statePrimTyCon )
\end{code}
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)
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)
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
+ -- 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'
arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
xs@(AFun one_shot _) | one_shot -> xs
xs | exprIsCheap scrut -> xs
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}
%* *
%************************************************************************
-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)
+ = 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
projects / ghc-hetmet.git / blobdiff