\begin{code}
module CoreUtils (
-- Construction
- mkNote, mkInlineMe, mkSCC, mkCoerce,
- bindNonRec, mkIfThenElse, mkAltExpr,
- mkPiType,
+ mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
+ bindNonRec, needsCaseBinding,
+ mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
-- Taking expressions apart
- findDefault, findAlt, hasDefault,
+ findDefault, findAlt, isDefaultAlt,
-- Properties of expressions
- exprType, coreAltsType,
- exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
- exprIsValue,exprOkForSpeculation, exprIsBig,
- exprIsConApp_maybe, exprIsAtom,
- idAppIsBottom, idAppIsCheap,
- exprArity,
+ exprType, coreAltType,
+ exprIsDupable, exprIsTrivial, exprIsCheap,
+ exprIsHNF,exprOkForSpeculation, exprIsBig,
+ exprIsConApp_maybe, exprIsBottom,
+ rhsIsStatic,
- -- Expr transformation
- etaReduce, etaExpand,
- exprArity, exprEtaExpandArity,
+ -- Arity and eta expansion
+ manifestArity, exprArity,
+ exprEtaExpandArity, etaExpand,
-- Size
coreBindsSize,
hashExpr,
-- Equality
- cheapEqExpr, eqExpr, applyTypeToArgs
+ cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg
) where
#include "HsVersions.h"
-import GlaExts -- For `xori`
+import GLAEXTS -- For `xori`
import CoreSyn
import CoreFVs ( exprFreeVars )
import PprCore ( pprCoreExpr )
-import Var ( Var, isId, isTyVar )
-import VarSet
+import Var ( Var )
+import VarSet ( unionVarSet )
import VarEnv
import Name ( hashName )
-import Literal ( hashLiteral, literalType, litIsDupable )
-import DataCon ( DataCon, dataConRepArity )
-import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
-import Id ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo,
- mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
- isDataConId_maybe, mkSysLocal, hasNoBinding
+import Packages ( HomeModules )
+#if mingw32_TARGET_OS
+import Packages ( isDllName )
+#endif
+import Literal ( hashLiteral, literalType, litIsDupable,
+ litIsTrivial, isZeroLit, Literal( MachLabel ) )
+import DataCon ( DataCon, dataConRepArity, dataConArgTys,
+ isVanillaDataCon, dataConTyCon )
+import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
+import Id ( Id, idType, globalIdDetails, idNewStrictness,
+ mkWildId, idArity, idName, idUnfolding, idInfo,
+ isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
+ isDataConWorkId, isBottomingId
)
-import IdInfo ( LBVarInfo(..),
- GlobalIdDetails(..),
- megaSeqIdInfo )
-import Demand ( appIsBottom )
-import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
- applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
- splitForAllTy_maybe, isForAllTy, eqType
+import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
+import NewDemand ( appIsBottom )
+import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
+ splitFunTy, tcEqTypeX,
+ applyTys, isUnLiftedType, seqType, mkTyVarTy,
+ splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
+ splitTyConApp_maybe, coreEqType, funResultTy, applyTy
)
+import TyCon ( tyConArity )
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
-import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
+import BasicTypes ( Arity )
+import Unique ( Unique )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
+import Util ( equalLength, lengthAtLeast, foldl2 )
\end{code}
exprType (Var var) = idType var
exprType (Lit lit) = literalType lit
exprType (Let _ body) = exprType body
-exprType (Case _ _ alts) = coreAltsType alts
-exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
+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 e@(App _ _)
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
case of a term variable.
\begin{code}
-mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work...
-mkPiType v ty | isId v = (case idLBVarInfo v of
- LBVarInfo u -> mkUTy u
- otherwise -> id) $
- mkFunTy (idType v) ty
- | isTyVar v = mkForAllTy v ty
+mkPiType :: Var -> Type -> Type -- The more polymorphic version
+mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
+
+mkPiTypes vs ty = foldr mkPiType ty vs
+
+mkPiType v ty
+ | isId v = mkFunTy (idType v) ty
+ | otherwise = mkForAllTy v ty
\end{code}
\begin{code}
--- The first argument is just for debugging
+applyTypeToArg :: Type -> CoreExpr -> Type
+applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
+applyTypeToArg fun_ty other_arg = funResultTy fun_ty
+
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
+-- A more efficient version of applyTypeToArg
+-- when we have several args
+-- The first argument is just for debugging
applyTypeToArgs e op_ty [] = op_ty
applyTypeToArgs e op_ty (Type ty : args)
= -- Accumulate type arguments so we can instantiate all at once
- applyTypeToArgs e (applyTys op_ty tys) rest_args
+ go [ty] args
where
- (tys, rest_args) = go [ty] args
- go tys (Type ty : args) = go (ty:tys) args
- go tys rest_args = (reverse tys, rest_args)
+ go rev_tys (Type ty : args) = go (ty:rev_tys) args
+ go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
+ where
+ op_ty' = applyTys op_ty (reverse rev_tys)
applyTypeToArgs e op_ty (other_arg : args)
= case (splitFunTy_maybe op_ty) of
mkNote removes redundant coercions, and SCCs where possible
\begin{code}
+#ifdef UNUSED
mkNote :: Note -> CoreExpr -> CoreExpr
-mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr
+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)
\begin{code}
-mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
+mkCoerce :: Type -> CoreExpr -> CoreExpr
+mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
-mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
- = ASSERT( from_ty `eqType` to_ty2 )
- mkCoerce to_ty from_ty2 expr
+mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
+mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
+ = ASSERT( from_ty `coreEqType` to_ty2 )
+ mkCoerce2 to_ty from_ty2 expr
-mkCoerce to_ty from_ty expr
- | to_ty `eqType` from_ty = expr
- | otherwise = ASSERT( from_ty `eqType` exprType expr )
+mkCoerce2 to_ty from_ty expr
+ | to_ty `coreEqType` from_ty = expr
+ | otherwise = ASSERT( from_ty `coreEqType` exprType expr )
Note (Coerce to_ty from_ty) expr
\end{code}
-- 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
- | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
- | otherwise = Let (NonRec bndr rhs) body
+ | 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)
+ -- Make a case expression instead of a let
+ -- These can arise either from the desugarer,
+ -- or from beta reductions: (\x.e) (x +# y)
\end{code}
\begin{code}
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse guard then_expr else_expr
- = Case guard (mkWildId boolTy)
- [ (DataAlt trueDataCon, [], then_expr),
- (DataAlt falseDataCon, [], else_expr) ]
+-- Not going to be refining, so okay to take the type of the "then" clause
+ = Case guard (mkWildId boolTy) (exprType then_expr)
+ [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
+ (DataAlt trueDataCon, [], then_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)
= case alts of
(deflt@(DEFAULT,_,_):alts) -> go alts deflt
other -> go alts panic_deflt
-
where
panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
- go [] deflt = deflt
- go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
- | otherwise = ASSERT( not (con1 == DEFAULT) )
- go alts deflt
+ go [] deflt = deflt
+ go (alt@(con1,_,_) : alts) deflt
+ = case con `cmpAltCon` con1 of
+ LT -> deflt -- Missed it already; the alts are in increasing order
+ EQ -> alt
+ GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
+
+isDefaultAlt :: CoreAlt -> Bool
+isDefaultAlt (DEFAULT, _, _) = True
+isDefaultAlt other = False
\end{code}
@exprIsBottom@ is true of expressions that are guaranteed to diverge
+There used to be a gruesome test for (hasNoBinding v) in the
+Var case:
+ exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
+The idea here is that a constructor worker, like $wJust, is
+really short for (\x -> $wJust x), becuase $wJust has no binding.
+So it should be treated like a lambda. Ditto unsaturated primops.
+But now constructor workers are not "have-no-binding" Ids. And
+completely un-applied primops and foreign-call Ids are sufficiently
+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)
- | hasNoBinding v = idArity v == 0
- -- WAS: | Just op <- isPrimOpId_maybe v = primOpIsDupable op
- -- The idea here is that a constructor worker, like $wJust, is
- -- really short for (\x -> $wJust x), becuase $wJust has no binding.
- -- So it should be treated like a lambda.
- -- Ditto unsaturated primops.
- -- This came up when dealing with eta expansion/reduction for
- -- x = $wJust
- -- Here we want to eta-expand. This looks like an optimisation,
- -- but it's important (albeit tiresome) that CoreSat doesn't increase
- -- anything's arity
- | otherwise = True
-exprIsTrivial (Type _) = True
-exprIsTrivial (Lit lit) = True
-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
+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 (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}
\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
+exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
and [exprIsCheap rhs | (_,_,rhs) <- alts]
-- Experimentally, treat (case x of ...) as cheap
-- (and case __coerce x etc.)
| n_val_args == 0 = True -- Just a type application of
-- 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
-
- PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
- -- that return a type variable, since the result
- -- might be applied to something, but I'm not going
- -- to bother to check the number of args
- other -> n_val_args < idArity id
+ | otherwise
+ = case globalIdDetails id of
+ DataConWorkId _ -> True
+ RecordSelId _ _ -> n_val_args == 1 -- I'm experimenting with making record selection
+ ClassOpId _ -> n_val_args == 1 -- look cheap, so we will substitute it inside a
+ -- lambda. Particularly for dictionary field selection.
+ -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
+ -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
+
+ PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
+ -- that return a type variable, since the result
+ -- might be applied to something, but I'm not going
+ -- to bother to check the number of args
+ other -> n_val_args < idArity id
\end{code}
exprOkForSpeculation returns True of an expression that it is
\begin{code}
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation (Lit _) = True
+exprOkForSpeculation (Type _) = True
exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
exprOkForSpeculation other_expr
- = go other_expr 0 True
+ = case collectArgs other_expr of
+ (Var f, args) -> spec_ok (globalIdDetails f) args
+ other -> False
+
where
- go (Var f) n_args args_ok
- = case globalIdDetails f of
- DataConId _ -> True -- The strictness of the constructor has already
- -- been expressed by its "wrapper", so we don't need
- -- to take the arguments into account
-
- PrimOpId op -> primOpOkForSpeculation op && args_ok
+ 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
+
+ spec_ok (PrimOpId op) args
+ | isDivOp op, -- Special case for dividing operations that fail
+ [arg1, Lit lit] <- args -- only if the divisor is zero
+ = not (isZeroLit lit) && exprOkForSpeculation arg1
+ -- Often there is a literal divisor, and this
+ -- can get rid of a thunk in an inner looop
+
+ | otherwise
+ = primOpOkForSpeculation op &&
+ all exprOkForSpeculation args
-- A bit conservative: we don't really need
-- to care about lazy arguments, but this is easy
- other -> False
-
- go (App f a) n_args args_ok
- | not (isRuntimeArg a) = go f n_args args_ok
- | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
-
- go other n_args args_ok = False
+ spec_ok other args = False
+
+isDivOp :: PrimOp -> Bool
+-- True of dyadic operators that can fail
+-- only if the second arg is zero
+-- This function probably belongs in PrimOp, or even in
+-- an automagically generated file.. but it's such a
+-- special case I thought I'd leave it here for now.
+isDivOp IntQuotOp = True
+isDivOp IntRemOp = True
+isDivOp WordQuotOp = True
+isDivOp WordRemOp = True
+isDivOp IntegerQuotRemOp = True
+isDivOp IntegerDivModOp = True
+isDivOp FloatDivOp = True
+isDivOp DoubleDivOp = True
+isDivOp other = False
\end{code}
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
+ 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 (Type _) = False
idAppIsBottom :: Id -> Int -> Bool
-idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
+idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
\end{code}
-@exprIsValue@ returns true for expressions that are certainly *already*
-evaluated to WHNF. This is used to decide wether it's ok to change
+@exprIsHNF@ returns true for expressions that are certainly *already*
+evaluated to *head* normal form. This is used to decide whether it's ok
+to change
+
case x of _ -> e ===> e
and to decide whether it's safe to discard a `seq`
So, it does *not* treat variables as evaluated, unless they say they are.
But it *does* treat partial applications and constructor applications
-as values, even if their arguments are non-trivial;
+as values, even if their arguments are non-trivial, provided the argument
+type is lifted;
e.g. (:) (f x) (map f xs) is a value
map (...redex...) is a value
Because `seq` on such things completes immediately
-A possible worry: constructors with unboxed args:
+For unlifted argument types, we have to be careful:
C (f x :: Int#)
Suppose (f x) diverges; then C (f x) is not a value. True, but
this form is illegal (see the invariants in CoreSyn). Args of unboxed
type must be ok-for-speculation (or trivial).
\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 other_expr
- = go other_expr 0
- where
- go (Var f) n_args = idAppIsValue f n_args
-
- go (App f a) n_args
- | not (isRuntimeArg a) = go f n_args
- | otherwise = go f (n_args + 1)
-
- go (Note _ f) n_args = go f n_args
-
- go other n_args = False
-
-idAppIsValue :: Id -> Int -> Bool
-idAppIsValue id n_val_args
- = case globalIdDetails id of
- DataConId _ -> True
- PrimOpId _ -> n_val_args < idArity id
- other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
- | otherwise -> n_val_args < idArity id
+exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
+exprIsHNF (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...
+
+exprIsHNF (Lit l) = True
+exprIsHNF (Type ty) = True -- Types are honorary Values;
+ -- we don't mind copying them
+exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
+exprIsHNF (Note _ e) = exprIsHNF e
+exprIsHNF (App e (Type _)) = exprIsHNF e
+exprIsHNF (App e a) = app_is_value e [a]
+exprIsHNF 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
+ (arg_ty, res_ty) = splitFunTy fun_ty
\end{code}
\begin{code}
exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
-exprIsConApp_maybe (Note InlineMe expr) = exprIsConApp_maybe expr
+exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
+ = -- Maybe this is over the top, but here we try to turn
+ -- coerce (S,T) ( x, y )
+ -- effectively into
+ -- ( coerce S x, coerce T y )
+ -- This happens in anger in PrelArrExts which has a coerce
+ -- case coerce memcpy a b of
+ -- (# r, s #) -> ...
+ -- where the memcpy is in the IO monad, but the call is in
+ -- the (ST s) monad
+ case exprIsConApp_maybe expr of {
+ Nothing -> Nothing ;
+ Just (dc, args) ->
+
+ case splitTyConApp_maybe to_ty of {
+ Nothing -> Nothing ;
+ 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
+ arity = tyConArity tc
+ val_args = drop arity args
+ to_arg_tys = dataConArgTys dc tc_arg_tys
+ mk_coerce ty arg = mkCoerce ty arg
+ new_val_args = zipWith mk_coerce to_arg_tys val_args
+ in
+ ASSERT( all isTypeArg (take arity args) )
+ ASSERT( equalLength val_args to_arg_tys )
+ Just (dc, map Type tc_arg_tys ++ new_val_args)
+ }}
+
+exprIsConApp_maybe (Note _ expr)
+ = exprIsConApp_maybe expr
-- We ignore InlineMe notes in case we have
-- x = __inline_me__ (a,b)
-- All part of making sure that INLINE pragmas never hurt
-- Marcin tripped on this one when making dictionaries more inlinable
+ --
+ -- In fact, we ignore all notes. For example,
+ -- case _scc_ "foo" (C a b) of
+ -- C a b -> e
+ -- should be optimised away, but it will be only if we look
+ -- through the SCC note.
exprIsConApp_maybe expr = analyse (collectArgs expr)
where
analyse (Var fun, args)
- | Just con <- isDataConId_maybe fun,
- length args >= dataConRepArity con
+ | Just con <- isDataConWorkId_maybe fun,
+ args `lengthAtLeast` dataConRepArity con
-- Might be > because the arity excludes type args
= Just (con,args)
%* *
%************************************************************************
-@etaReduce@ trys an eta reduction at the top level of a Core Expr.
+\begin{code}
+exprEtaExpandArity :: CoreExpr -> Arity
+{- The Arity returned is the number of value args the
+ thing can be applied to without doing much work
-e.g. \ x y -> f x y ===> f
+exprEtaExpandArity is used when eta expanding
+ e ==> \xy -> e x y
-But we only do this if it gets rid of a whole lambda, not part.
-The idea is that lambdas are often quite helpful: they indicate
-head normal forms, so we don't want to chuck them away lightly.
+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
-\begin{code}
-etaReduce :: CoreExpr -> CoreExpr
- -- ToDo: we should really check that we don't turn a non-bottom
- -- lambda into a bottom variable. Sigh
+It's all a bit more subtle than it looks:
-etaReduce expr@(Lam bndr body)
- = check (reverse binders) body
- where
- (binders, body) = collectBinders expr
+1. One-shot lambdas
- check [] body
- | not (any (`elemVarSet` body_fvs) binders)
- = body -- Success!
- where
- body_fvs = exprFreeVars body
+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
- check (b : bs) (App fun arg)
- | (varToCoreExpr b `cheapEqExpr` arg)
- = check bs fun
+2. The state-transformer hack
- check _ _ = expr -- Bale out
+The one-shot lambda special cause is particularly important/useful for
+IO state transformers, where we often get
+ let x = E in \ s -> ...
-etaReduce expr = expr -- The common case
-\end{code}
-
+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.isOneShotBndr.
-\begin{code}
-exprEtaExpandArity :: CoreExpr -> (Int, Bool)
--- The Int is number of value args the thing can be
--- applied to without doing much work
--- The Bool is True iff there are enough explicit value lambdas
--- at the top to make this arity apparent
--- (but ignore it when arity==0)
-
--- 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
---
--- Consider 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 list of Bools returned by go1
--- 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
-
-exprEtaExpandArity e
- = go 0 e
- where
- go :: Int -> CoreExpr -> (Int,Bool)
- go ar (Lam x e) | isId x = go (ar+1) e
- | otherwise = go ar e
- go ar (Note n e) | ok_note n = go ar e
- go ar other = (ar + ar', ar' == 0)
- where
- ar' = length (go1 other)
-
- go1 :: CoreExpr -> [Bool]
+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.
+
+
+4. Newtypes
+
+Non-recursive newtypes are transparent, and should not get in the way.
+We do (currently) eta-expand recursive newtypes too. So if we have, say
+
+ newtype T = MkT ([T] -> Int)
+
+Suppose we have
+ e = coerce T f
+where f has arity 1. Then: etaExpandArity e = 1;
+that is, etaExpandArity looks through the coerce.
+
+When we eta-expand e to arity 1: eta_expand 1 e T
+we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
+
+HOWEVER, note that if you use coerce bogusly you can ge
+ coerce Int negate
+And since negate has arity 2, you might try to eta expand. But you can't
+decopose Int to a function type. Hence the final case in eta_expand.
+-}
+
+
+exprEtaExpandArity e = arityDepth (arityType e)
+
+-- A limited sort of function type
+data ArityType = AFun Bool ArityType -- True <=> one-shot
+ | ATop -- Know nothing
+ | ABot -- Diverges
+
+arityDepth :: ArityType -> Arity
+arityDepth (AFun _ ty) = 1 + arityDepth ty
+arityDepth ty = 0
+
+andArityType ABot at2 = at2
+andArityType ATop at2 = ATop
+andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
+andArityType at1 at2 = andArityType at2 at1
+
+arityType :: CoreExpr -> ArityType
-- (go1 e) = [b1,..,bn]
-- means expression can be rewritten \x_b1 -> ... \x_bn -> body
-- where bi is True <=> the lambda is one-shot
- go1 (Note n e) | ok_note n = go1 e
- go1 (Var v) = replicate (idArity v) False -- When the type of the Id
- -- encodes one-shot-ness, use
- -- the idinfo here
+arityType (Note n e) = arityType e
+-- Not needed any more: etaExpand is cleverer
+-- | ok_note n = arityType e
+-- | otherwise = ATop
+
+arityType (Var v)
+ = mk (idArity v) (arg_tys (idType v))
+ where
+ 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
- go1 (Lam x e) | isId x = isOneShotLambda x : go1 e
- | otherwise = go1 e
+arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
+ | otherwise = arityType e
-- Applications; decrease arity
- go1 (App f (Type _)) = go1 f
- go1 (App f a) = case go1 f of
- (one_shot : xs) | one_shot || exprIsCheap a -> xs
- other -> []
+arityType (App f (Type _)) = arityType f
+arityType (App f a) = case arityType f of
+ AFun one_shot xs | exprIsCheap a -> xs
+ other -> ATop
-- Case/Let; keep arity if either the expression is cheap
-- or it's a 1-shot lambda
- go1 (Case scrut _ alts) = case foldr1 (zipWith (&&)) [go1 rhs | (_,_,rhs) <- alts] of
- xs@(one_shot : _) | one_shot || exprIsCheap scrut -> xs
- other -> []
- go1 (Let b e) = case go1 e of
- xs@(one_shot : _) | one_shot || all exprIsCheap (rhssOfBind b) -> xs
- other -> []
-
- go1 other = []
-
- ok_note (Coerce _ _) = True
- ok_note InlineCall = True
- ok_note other = False
- -- Notice that we do not look through __inline_me__
- -- This may seem surprising, but consider
- -- f = _inline_me (\x -> e)
- -- We DO NOT want to eta expand this to
- -- f = \x -> (_inline_me (\x -> e)) x
- -- because the _inline_me gets dropped now it is applied,
- -- giving just
- -- f = \x -> e
- -- A Bad Idea
+ -- 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
+ | otherwise -> ATop
+
+arityType (Let b e) = case arityType e of
+ xs@(AFun one_shot _) | one_shot -> xs
+ xs | all exprIsCheap (rhssOfBind b) -> xs
+ | otherwise -> ATop
+
+arityType other = ATop
+
+{- NOT NEEDED ANY MORE: etaExpand is cleverer
+ok_note InlineMe = False
+ok_note other = True
+ -- Notice that we do not look through __inline_me__
+ -- This may seem surprising, but consider
+ -- f = _inline_me (\x -> e)
+ -- We DO NOT want to eta expand this to
+ -- f = \x -> (_inline_me (\x -> e)) x
+ -- because the _inline_me gets dropped now it is applied,
+ -- giving just
+ -- f = \x -> e
+ -- A Bad Idea
+-}
\end{code}
\begin{code}
-etaExpand :: Int -- Add this number of value args
- -> UniqSupply
+etaExpand :: Arity -- Result should have this number of value args
+ -> [Unique]
-> CoreExpr -> Type -- Expression and its type
-> CoreExpr
-- (etaExpand n us e ty) returns an expression with
-- the same meaning as 'e', but with arity 'n'.
-
+--
-- Given e' = etaExpand n us e ty
-- We should have
-- ty = exprType e = exprType e'
--
--- etaExpand deals with for-alls and coerces. For example:
+-- Note that SCCs are not treated specially. If we have
+-- etaExpand 2 (\x -> scc "foo" e)
+-- = (\xy -> (scc "foo" e) y)
+-- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
+
+etaExpand n us expr ty
+ | manifestArity expr >= n = expr -- The no-op case
+ | otherwise = eta_expand n us expr ty
+ where
+
+-- manifestArity sees how many leading value lambdas there are
+manifestArity :: CoreExpr -> Arity
+manifestArity (Lam v e) | isId v = 1 + manifestArity e
+ | otherwise = manifestArity e
+manifestArity (Note _ e) = manifestArity e
+manifestArity e = 0
+
+-- etaExpand deals with for-alls. For example:
-- etaExpand 1 E
--- where E :: forall a. T
--- newtype T = MkT (A -> B)
---
+-- where E :: forall a. a -> a
-- would return
--- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
+-- (/\b. \y::a -> E b y)
+--
+-- It deals with coerces too, though they are now rare
+-- so perhaps the extra code isn't worth it
-etaExpand n us expr ty
+eta_expand n us expr ty
| n == 0 &&
-- The ILX code generator requires eta expansion for type arguments
-- too, but alas the 'n' doesn't tell us how many of them there
-- may be. So we eagerly eta expand any big lambdas, and just
- -- cross our fingers about possible loss of sharing in the
- -- ILX case.
+ -- cross our fingers about possible loss of sharing in the ILX case.
-- The Right Thing is probably to make 'arity' include
-- type variables throughout the compiler. (ToDo.)
not (isForAllTy ty)
-- Saturated, so nothing to do
= expr
- | otherwise -- An unsaturated constructor or primop; eta expand it
+ -- Short cut for the case where there already
+ -- is a lambda; no point in gratuitously adding more
+eta_expand n us (Lam v body) ty
+ | isTyVar v
+ = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
+
+ | otherwise
+ = Lam v (eta_expand (n-1) us body (funResultTy ty))
+
+-- We used to have a special case that stepped inside Coerces here,
+-- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
+-- = Note note (eta_expand n us e ty)
+-- BUT this led to an infinite loop
+-- Example: newtype T = MkT (Int -> Int)
+-- eta_expand 1 (coerce (Int->Int) e)
+-- --> coerce (Int->Int) (eta_expand 1 T e)
+-- by the bogus eqn
+-- --> coerce (Int->Int) (coerce T
+-- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
+-- by the splitNewType_maybe case below
+-- and round we go
+
+eta_expand n us expr ty
= case splitForAllTy_maybe ty of {
- Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
+ Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
; Nothing ->
case splitFunTy_maybe ty of {
- Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
+ Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
where
- arg1 = mkSysLocal SLIT("eta") uniq arg_ty
- (us1, us2) = splitUniqSupply us
- uniq = uniqFromSupply us1
+ arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
+ (uniq:us2) = us
- ; Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
- }}
+ ; Nothing ->
+
+ -- Given this:
+ -- newtype T = MkT ([T] -> Int)
+ -- Consider eta-expanding this
+ -- eta_expand 1 e T
+ -- We want to get
+ -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
+ -- Only try this for recursive newtypes; the non-recursive kind
+ -- are transparent anyway
+
+ case splitRecNewType_maybe ty of {
+ Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
+ Nothing ->
+
+ -- We have an expression of arity > 0, but its type isn't a function
+ -- This *can* legitmately happen: e.g. coerce Int (\x. x)
+ -- Essentially the programmer is playing fast and loose with types
+ -- (Happy does this a lot). So we simply decline to eta-expand.
+ expr
+ }}}
\end{code}
-
exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
It tells how many things the expression can be applied to before doing
any work. It doesn't look inside cases, lets, etc. The idea is that
won't be eta-expanded.
And in any case it seems more robust to have exprArity be a bit more intelligent.
+But note that (\x y z -> f x y z)
+should have arity 3, regardless of f's arity.
\begin{code}
-exprArity :: CoreExpr -> Int
-exprArity e = go e `max` 0
+exprArity :: CoreExpr -> Arity
+exprArity e = go e
where
+ go (Var v) = idArity v
go (Lam x e) | isId x = go e + 1
| otherwise = go e
- go (Note _ e) = go e
+ go (Note n e) = go e
go (App e (Type t)) = go e
- go (App f a) | exprIsCheap a = go f - 1
- -- Important! f (fac x) does not have arity 2,
- -- even if f does!
- go (Var v) = idArity v
+ go (App f a) | exprIsCheap a = (go f - 1) `max` 0
+ -- NB: exprIsCheap a!
+ -- f (fac x) does not have arity 2,
+ -- even if f has arity 3!
+ -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
+ -- unknown, hence arity 0
go _ = 0
\end{code}
-
%************************************************************************
%* *
\subsection{Equality}
cheapEqExpr (Var v1) (Var v2) = v1==v2
cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
-cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
+cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
cheapEqExpr (App f1 a1) (App f2 a2)
= f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
\begin{code}
-eqExpr :: CoreExpr -> CoreExpr -> Bool
- -- Works ok at more general type, but only needed at CoreExpr
- -- Used in rule matching, so when we find a type we use
- -- eqTcType, which doesn't look through newtypes
- -- [And it doesn't risk falling into a black hole either.]
-eqExpr e1 e2
- = eq emptyVarEnv e1 e2
+tcEqExpr :: CoreExpr -> CoreExpr -> Bool
+-- Used in rule matching, so does *not* look through
+-- newtypes, predicate types; hence tcEqExpr
+
+tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
where
- -- The "env" maps variables in e1 to variables in ty2
- -- So when comparing lambdas etc,
- -- we in effect substitute v2 for v1 in e1 before continuing
- eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
- Just v1' -> v1' == v2
- Nothing -> v1 == v2
-
- eq env (Lit lit1) (Lit lit2) = lit1 == lit2
- eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
- eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
- eq env (Let (NonRec v1 r1) e1)
- (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
- eq env (Let (Rec ps1) e1)
- (Let (Rec ps2) e2) = length ps1 == length ps2 &&
- and (zipWith eq_rhs ps1 ps2) &&
- eq env' e1 e2
+ rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
+
+tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
+tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
+tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2
+tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
+tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
+tcEqExprX env (Let (NonRec v1 r1) e1)
+ (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
+ && tcEqExprX (rnBndr2 env v1 v2) e1 e2
+tcEqExprX env (Let (Rec ps1) e1)
+ (Let (Rec ps2) e2) = equalLength ps1 ps2
+ && and (zipWith eq_rhs ps1 ps2)
+ && tcEqExprX env' e1 e2
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 &&
- length a1 == length a2 &&
- and (zipWith (eq_alt env') a1 a2)
+ env' = foldl2 rn_bndr2 env ps2 ps2
+ rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
+ eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
+tcEqExprX env (Case e1 v1 t1 a1)
+ (Case e2 v2 t2 a2) = tcEqExprX env e1 e2
+ && tcEqTypeX env t1 t2
+ && equalLength a1 a2
+ && and (zipWith (eq_alt env') a1 a2)
where
- env' = extendVarEnv env v1 v2
+ env' = rnBndr2 env v1 v2
- eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
- eq env (Type t1) (Type t2) = t1 `eqType` t2
- eq env e1 e2 = False
+tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
+tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
+tcEqExprX env e1 e2 = False
- eq_list env [] [] = True
- eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
- eq_list env es1 es2 = False
-
- eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
- eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
-
- 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 other1 other2 = False
+eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
+
+eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
+eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2
+eq_note env InlineCall InlineCall = True
+eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
+eq_note env other1 other2 = False
\end{code}
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) = varSize v
-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
+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
noteSize InlineCall = 1
noteSize InlineMe = 1
+noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
varSize :: Var -> Int
varSize b | isTyVar b = 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
+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
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 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.
+
+\begin{code}
+rhsIsStatic :: HomeModules -> 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
+-- ("DLL" here really only refers to Windows DLLs, on other platforms,
+-- this is not necessary)
+--
+-- (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.exprIsHNF, 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 hmods rhs = is_static False rhs
+ where
+ 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
+#if mingw32_TARGET_OS
+ | not (isDllName hmods (idName f))
+#endif
+ = 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}