\begin{code}
module CoreUtils (
-- Construction
- mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
+ mkInlineMe, mkSCC, mkCoerce,
bindNonRec, needsCaseBinding,
mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
import CoreSyn
import CoreFVs ( exprFreeVars )
import PprCore ( pprCoreExpr )
-import Var ( Var )
+import Var ( Var, TyVar, isCoVar, tyVarKind )
import VarSet ( unionVarSet )
import VarEnv
import Name ( hashName )
-import Packages ( HomeModules )
#if mingw32_TARGET_OS
import Packages ( isDllName )
#endif
import Literal ( hashLiteral, literalType, litIsDupable,
litIsTrivial, isZeroLit, Literal( MachLabel ) )
-import DataCon ( DataCon, dataConRepArity, dataConInstArgTys,
- isVanillaDataCon, dataConTyCon )
+import DataCon ( DataCon, dataConRepArity,
+ isVanillaDataCon, dataConTyCon, dataConRepArgTys,
+ dataConUnivTyVars, dataConExTyVars )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo,
isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
- isDataConWorkId, isBottomingId
+ isDataConWorkId, isBottomingId, isDictId
)
import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
import NewDemand ( appIsBottom )
splitFunTy, tcEqTypeX,
applyTys, isUnLiftedType, seqType, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
- splitTyConApp_maybe, coreEqType, funResultTy, applyTy
+ splitTyConApp_maybe, coreEqType, funResultTy, applyTy,
+ substTyWith
)
+import Coercion ( Coercion, mkTransCoercion, coercionKind,
+ splitNewTypeRepCo_maybe, mkSymCoercion, mkLeftCoercion,
+ mkRightCoercion, decomposeCo, coercionKindTyConApp,
+ splitCoercionKind )
import TyCon ( tyConArity )
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
import BasicTypes ( Arity )
+import PackageConfig ( PackageId )
import Unique ( Unique )
import Outputable
+import DynFlags ( DynFlags, DynFlag(Opt_DictsCheap), dopt )
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast, foldl2 )
\end{code}
exprType (Lit lit) = literalType lit
exprType (Let _ body) = exprType body
exprType (Case _ _ ty alts) = ty
-exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
+exprType (Cast e co)
+ = let (_, ty) = coercionKind co in ty
exprType (Note other_note e) = exprType e
exprType (Lam binder expr) = mkPiType binder (exprType expr)
exprType e@(App _ _)
applyTypeToArgs e op_ty (other_arg : args)
= case (splitFunTy_maybe op_ty) of
Just (_, res_ty) -> applyTypeToArgs e res_ty args
- Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
+ Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e $$ ppr op_ty)
\end{code}
\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)
--- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
--- mkNote InlineCall (Var v) = Note InlineCall (Var v)
--- mkNote InlineCall expr = expr
\end{code}
Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
\begin{code}
-mkCoerce :: Type -> CoreExpr -> CoreExpr
-mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) 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
-
-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
+mkCoerce :: Coercion -> CoreExpr -> CoreExpr
+mkCoerce co (Cast expr co2)
+ = ASSERT(let { (from_ty, to_ty) = coercionKind co;
+ (from_ty2, to_ty2) = coercionKind co2} in
+ from_ty `coreEqType` to_ty2 )
+ mkCoerce (mkTransCoercion co2 co) expr
+
+mkCoerce co expr
+ = let (from_ty, to_ty) = coercionKind co in
+-- if to_ty `coreEqType` from_ty
+-- then expr
+-- else
+ ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindTyConApp co))
+ (Cast expr co)
\end{code}
\begin{code}
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
+mkSCC cc (Cast e co) = Cast (mkSCC cc e) co -- Move _scc_ inside cast
mkSCC cc expr = Note (SCC cc) expr
\end{code}
-- This guy constructs the value that the scrutinee must have
-- when you are in one particular branch of a case
mkAltExpr (DataAlt con) args inst_tys
- = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
+ = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
mkAltExpr (LitAlt lit) [] []
= Lit lit
exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
exprIsTrivial (Note (SCC _) e) = False -- See notes above
exprIsTrivial (Note _ e) = exprIsTrivial e
+exprIsTrivial (Cast e co) = exprIsTrivial e
exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
exprIsTrivial other = False
\end{code}
exprIsDupable (Lit lit) = litIsDupable lit
exprIsDupable (Note InlineMe e) = True
exprIsDupable (Note _ e) = exprIsDupable e
+exprIsDupable (Cast e co) = exprIsDupable e
exprIsDupable expr
= go expr 0
where
\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 &&
- and [exprIsCheap rhs | (_,_,rhs) <- alts]
+exprIsCheap (Lit lit) = True
+exprIsCheap (Type _) = True
+exprIsCheap (Var _) = True
+exprIsCheap (Note InlineMe e) = True
+exprIsCheap (Note _ e) = exprIsCheap e
+exprIsCheap (Cast e co) = 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.)
-- This improves arities of overloaded functions where
exprIsCheap (Let (NonRec x _) e)
| isUnLiftedType (idType x) = exprIsCheap e
| otherwise = False
- -- strict lets always have cheap right hand sides, and
- -- do no allocation.
+ -- strict lets always have cheap right hand sides,
+ -- and do no allocation.
-exprIsCheap other_expr
- = go other_expr 0 True
+exprIsCheap other_expr -- Applications and variables
+ = go other_expr []
where
- go (Var f) n_args args_cheap
- = (idAppIsCheap f n_args && args_cheap)
- -- A constructor, cheap primop, or partial application
-
- || idAppIsBottom f n_args
+ -- Accumulate value arguments, then decide
+ go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
+ | otherwise = go f val_args
+
+ go (Var f) [] = True -- Just a type application of a variable
+ -- (f t1 t2 t3) counts as WHNF
+ go (Var f) args
+ = case globalIdDetails f of
+ RecordSelId {} -> go_sel args
+ ClassOpId _ -> go_sel args
+ PrimOpId op -> go_primop op args
+
+ DataConWorkId _ -> go_pap args
+ other | length args < idArity f -> go_pap args
+
+ other -> isBottomingId f
-- Application of a function which
-- always gives bottom; we treat this as cheap
-- because it certainly doesn't need to be shared!
- go (App f a) n_args args_cheap
- | not (isRuntimeArg a) = go f n_args args_cheap
- | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
-
- go other n_args args_cheap = False
-
-idAppIsCheap :: Id -> Int -> Bool
-idAppIsCheap id n_val_args
- | n_val_args == 0 = True -- Just a type application of
- -- a variable (f t1 t2 t3)
- -- counts as WHNF
- | 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
+ go other args = False
+
+ --------------
+ go_pap args = all exprIsTrivial args
+ -- For constructor applications and primops, check that all
+ -- the args are trivial. We don't want to treat as cheap, say,
+ -- (1:2:3:4:5:[])
+ -- We'll put up with one constructor application, but not dozens
+
+ --------------
+ go_primop op args = primOpIsCheap op && all exprIsCheap args
+ -- 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
+
+ --------------
+ go_sel [arg] = exprIsCheap arg -- I'm experimenting with making record selection
+ go_sel other = False -- 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)
\end{code}
exprOkForSpeculation returns True of an expression that it is
without raising an exception,
without causing a side effect (e.g. writing a mutable variable)
+NB: if exprIsHNF e, then exprOkForSpecuation e
+
E.G.
let x = case y# +# 1# of { r# -> I# r# }
in E
\begin{code}
exprOkForSpeculation :: CoreExpr -> Bool
-exprOkForSpeculation (Lit _) = True
-exprOkForSpeculation (Type _) = True
-exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
-exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
+exprOkForSpeculation (Lit _) = True
+exprOkForSpeculation (Type _) = True
+exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
+exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
+exprOkForSpeculation (Cast e co) = exprOkForSpeculation e
exprOkForSpeculation other_expr
= case collectArgs other_expr of
(Var f, args) -> spec_ok (globalIdDetails f) args
where
-- n is the number of args
go n (Note _ e) = go n e
+ go n (Cast e co) = 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
-- we don't mind copying them
exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
exprIsHNF (Note _ e) = exprIsHNF e
+exprIsHNF (Cast e co) = 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
+ | 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)
\end{code}
\begin{code}
+-- deep applies a TyConApp coercion as a substitution to a reflexive coercion
+-- deepCast t [a1,...,an] co corresponds to deep(t, [a1,...,an], co) from
+-- FC paper
+deepCast :: Type -> [TyVar] -> Coercion -> Coercion
+deepCast ty tyVars co
+ = ASSERT( let {(lty, rty) = coercionKind co;
+ Just (tc1, lArgs) = splitTyConApp_maybe lty;
+ Just (tc2, rArgs) = splitTyConApp_maybe rty}
+ in
+ tc1 == tc2 && length lArgs == length rArgs &&
+ length lArgs == length tyVars )
+ substTyWith tyVars coArgs ty
+ where
+ -- coArgs = [right (left (left co)), right (left co), right co]
+ coArgs = decomposeCo (length tyVars) co
+
exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
-exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
+-- Returns (Just (dc, [x1..xn])) if the argument expression is
+-- a constructor application of the form (dc x1 .. xn)
+
+exprIsConApp_maybe (Cast expr co)
= -- Maybe this is over the top, but here we try to turn
-- coerce (S,T) ( x, y )
-- effectively into
case exprIsConApp_maybe expr of {
Nothing -> Nothing ;
Just (dc, args) ->
+
+ let (from_ty, to_ty) = coercionKind co in
case splitTyConApp_maybe to_ty of {
Nothing -> Nothing ;
Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
- | not (isVanillaDataCon dc) -> Nothing
+ -- | not (isVanillaDataCon dc) -> Nothing
| otherwise ->
- -- Type constructor must match
- -- We knock out existentials to keep matters simple(r)
+ -- Type constructor must match datacon
+
+ case splitTyConApp_maybe from_ty of {
+ Nothing -> Nothing ;
+ Just (tc', tc_arg_tys') | tc /= tc' -> Nothing
+ -- Both sides of coercion must have the same type constructor
+ | otherwise ->
+
let
- arity = tyConArity tc
- val_args = drop arity args
- to_arg_tys = dataConInstArgTys dc tc_arg_tys
- mk_coerce ty arg = mkCoerce ty arg
- new_val_args = zipWith mk_coerce to_arg_tys val_args
+ -- here we do the PushC reduction rule as described in the FC paper
+ arity = tyConArity tc
+ n_ex_tvs = length dc_ex_tyvars
+
+ (univ_args, rest) = splitAt arity args
+ (ex_args, val_args) = splitAt n_ex_tvs rest
+
+ arg_tys = dataConRepArgTys dc
+ dc_tyvars = dataConUnivTyVars dc
+ dc_ex_tyvars = dataConExTyVars dc
+
+ deep arg_ty = deepCast arg_ty dc_tyvars co
+
+ -- first we appropriately cast the value arguments
+ arg_cos = map deep arg_tys
+ new_val_args = zipWith mkCoerce (map deep arg_tys) val_args
+
+ -- then we cast the existential coercion arguments
+ orig_tvs = dc_tyvars ++ dc_ex_tyvars
+ gammas = decomposeCo arity co
+ new_tys = gammas ++ (map (\ (Type t) -> t) ex_args)
+ theta = substTyWith orig_tvs new_tys
+ cast_ty tv (Type ty)
+ | isCoVar tv
+ , (ty1, ty2) <- splitCoercionKind (tyVarKind tv)
+ = Type $ mkTransCoercion (mkSymCoercion (theta ty1))
+ (mkTransCoercion ty (theta ty2))
+ | otherwise
+ = Type ty
+ new_ex_args = zipWith cast_ty dc_ex_tyvars ex_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)
- }}
+ ASSERT( equalLength val_args arg_tys )
+ Just (dc, map Type tc_arg_tys ++ new_ex_args ++ new_val_args)
+ }}}
exprIsConApp_maybe (Note _ expr)
= exprIsConApp_maybe expr
%************************************************************************
\begin{code}
-exprEtaExpandArity :: CoreExpr -> Arity
+exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
{- The Arity returned is the number of value args the
thing can be applied to without doing much work
-}
-exprEtaExpandArity e = arityDepth (arityType e)
+exprEtaExpandArity dflags e = arityDepth (arityType dflags e)
-- A limited sort of function type
data ArityType = AFun Bool ArityType -- True <=> one-shot
andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
andArityType at1 at2 = andArityType at2 at1
-arityType :: CoreExpr -> ArityType
+arityType :: DynFlags -> 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
-arityType (Note n e) = arityType e
+arityType dflags (Note n e) = arityType dflags e
-- Not needed any more: etaExpand is cleverer
--- | ok_note n = arityType e
+-- | ok_note n = arityType dflags e
-- | otherwise = ATop
-arityType (Var v)
+arityType dflags (Cast e co) = arityType dflags e
+
+arityType dflags (Var v)
= mk (idArity v) (arg_tys (idType v))
where
mk :: Arity -> [Type] -> ArityType
-- 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 0 tys | isBottomingId v = ABot
+ | (ty:tys) <- tys, isStateHackType ty = AFun True ATop
+ | otherwise = ATop
mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
mk n [] = AFun False (mk (n-1) [])
| otherwise = []
-- Lambdas; increase arity
-arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
- | otherwise = arityType e
+arityType dflags (Lam x e)
+ | isId x = AFun (isOneShotBndr x) (arityType dflags e)
+ | otherwise = arityType dflags e
-- Applications; decrease arity
-arityType (App f (Type _)) = arityType f
-arityType (App f a) = case arityType f of
- AFun one_shot xs | exprIsCheap a -> xs
- other -> ATop
+arityType dflags (App f (Type _)) = arityType dflags f
+arityType dflags (App f a) = case arityType dflags 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
-- ===>
-- 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
+arityType dflags (Case scrut _ _ alts)
+ = case foldr1 andArityType [arityType dflags rhs | (_,_,rhs) <- alts] of
+ xs | exprIsCheap scrut -> xs
+ xs@(AFun one_shot _) | one_shot -> AFun True ATop
+ other -> ATop
+
+arityType dflags (Let b e)
+ = case arityType dflags e of
+ xs | cheap_bind b -> xs
+ xs@(AFun one_shot _) | one_shot -> AFun True ATop
+ other -> ATop
+ where
+ cheap_bind (NonRec b e) = is_cheap (b,e)
+ cheap_bind (Rec prs) = all is_cheap prs
+ is_cheap (b,e) = (dopt Opt_DictsCheap dflags && isDictId b)
+ || exprIsCheap e
+ -- If the experimental -fdicts-cheap flag is on, we eta-expand through
+ -- dictionary bindings. This improves arities. Thereby, it also
+ -- means that full laziness is less prone to floating out the
+ -- application of a function to its dictionary arguments, which
+ -- can thereby lose opportunities for fusion. Example:
+ -- foo :: Ord a => a -> ...
+ -- foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
+ -- -- So foo has arity 1
+ --
+ -- f = \x. foo dInt $ bar x
+ --
+ -- The (foo DInt) is floated out, and makes ineffective a RULE
+ -- foo (bar x) = ...
+ --
+ -- One could go further and make exprIsCheap reply True to any
+ -- dictionary-typed expression, but that's more work.
+
+arityType dflags other = ATop
{- NOT NEEDED ANY MORE: etaExpand is cleverer
ok_note InlineMe = False
etaExpand n us expr ty
| manifestArity expr >= n = expr -- The no-op case
- | otherwise = eta_expand n us expr ty
+ | otherwise
+ = eta_expand n us expr ty
where
-- manifestArity sees how many leading value lambdas there are
manifestArity (Lam v e) | isId v = 1 + manifestArity e
| otherwise = manifestArity e
manifestArity (Note _ e) = manifestArity e
+manifestArity (Cast e _) = manifestArity e
manifestArity e = 0
-- etaExpand deals with for-alls. For example:
-- and round we go
eta_expand n us expr ty
- = case splitForAllTy_maybe ty of {
+ = ASSERT2 (exprType expr `coreEqType` ty, ppr (exprType expr) $$ ppr ty)
+ case splitForAllTy_maybe ty of {
Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
; Nothing ->
-- 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') ;
+ case splitNewTypeRepCo_maybe ty of {
+ Just(ty1,co) ->
+ mkCoerce co (eta_expand n us (mkCoerce (mkSymCoercion co) expr) ty1) ;
Nothing ->
-- We have an expression of arity > 0, but its type isn't a function
go (Lam x e) | isId x = go e + 1
| otherwise = go e
go (Note n e) = go e
+ go (Cast e _) = go e
go (App e (Type t)) = go e
go (App f a) | exprIsCheap a = (go f - 1) `max` 0
-- NB: exprIsCheap a!
env' = rnBndr2 env v1 v2
tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
+tcEqExprX env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && tcEqExprX env e1 e2
tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
tcEqExprX env e1 e2 = 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 (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 (Cast e co) = (seqType co `seq` 1) + exprSize e
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
\begin{code}
hashExpr :: CoreExpr -> Int
+-- Two expressions that hash to the same Int may be equal (but may not be)
+-- Two expressions that hash to the different Ints are definitely unequal
+--
+-- But "unequal" here means "not identical"; two alpha-equivalent
+-- expressions may hash to the different Ints
+--
+-- The emphasis is on a crude, fast hash, rather than on high precision
+
hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
| otherwise = hash
where
hash = abs (hash_expr e) -- Negative numbers kill UniqFM
hash_expr (Note _ e) = hash_expr e
+hash_expr (Cast e co) = 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
and 'exectute' it rather than allocating it statically.
\begin{code}
-rhsIsStatic :: HomeModules -> CoreExpr -> Bool
+rhsIsStatic :: PackageId -> 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.
-- 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
+rhsIsStatic this_pkg rhs = is_static False rhs
where
is_static :: Bool -- True <=> in a constructor argument; must be atomic
-> CoreExpr -> Bool
is_static in_arg (Note (SCC _) e) = False
is_static in_arg (Note _ e) = is_static in_arg e
+ is_static in_arg (Cast e co) = is_static in_arg e
is_static in_arg (Lit lit)
= case lit of
where
go (Var f) n_val_args
#if mingw32_TARGET_OS
- | not (isDllName hmods (idName f))
+ | not (isDllName this_pkg (idName f))
#endif
= saturated_data_con f n_val_args
|| (in_arg && n_val_args == 0)
go (Note (SCC _) f) n_val_args = False
go (Note _ f) n_val_args = go f n_val_args
+ go (Cast e co) n_val_args = go e n_val_args
go other n_val_args = False
projects / ghc-hetmet.git / blobdiff