2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 mkNote, mkInlineMe, mkSCC, mkCoerce,
10 bindNonRec, mkIfThenElse, mkAltExpr,
13 -- Taking expressions apart
16 -- Properties of expressions
17 exprType, coreAltsType,
18 exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
19 exprIsValue,exprOkForSpeculation, exprIsBig,
20 exprIsConApp_maybe, exprIsAtom,
21 idAppIsBottom, idAppIsCheap,
24 -- Expr transformation
26 exprArity, exprEtaExpandArity,
35 cheapEqExpr, eqExpr, applyTypeToArgs
38 #include "HsVersions.h"
41 import GlaExts -- For `xori`
44 import CoreFVs ( exprFreeVars )
45 import PprCore ( pprCoreExpr )
46 import Var ( Var, isId, isTyVar )
49 import Name ( hashName )
50 import Literal ( hashLiteral, literalType, litIsDupable )
51 import DataCon ( DataCon, dataConRepArity )
52 import PrimOp ( primOpOkForSpeculation, primOpIsCheap,
54 import Id ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo,
55 mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
56 isDataConId_maybe, isPrimOpId_maybe, mkSysLocal, hasNoBinding
58 import IdInfo ( LBVarInfo(..),
61 import Demand ( appIsBottom )
62 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
63 applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
64 splitForAllTy_maybe, splitNewType_maybe
66 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
67 import CostCentre ( CostCentre )
68 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
69 import Maybes ( maybeToBool )
71 import TysPrim ( alphaTy ) -- Debugging only
75 %************************************************************************
77 \subsection{Find the type of a Core atom/expression}
79 %************************************************************************
82 exprType :: CoreExpr -> Type
84 exprType (Var var) = idType var
85 exprType (Lit lit) = literalType lit
86 exprType (Let _ body) = exprType body
87 exprType (Case _ _ alts) = coreAltsType alts
88 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
89 exprType (Note other_note e) = exprType e
90 exprType (Lam binder expr) = mkPiType binder (exprType expr)
92 = case collectArgs e of
93 (fun, args) -> applyTypeToArgs e (exprType fun) args
95 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
97 coreAltsType :: [CoreAlt] -> Type
98 coreAltsType ((_,_,rhs) : _) = exprType rhs
101 @mkPiType@ makes a (->) type or a forall type, depending on whether
102 it is given a type variable or a term variable. We cleverly use the
103 lbvarinfo field to figure out the right annotation for the arrove in
104 case of a term variable.
107 mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work...
108 mkPiType v ty | isId v = (case idLBVarInfo v of
109 LBVarInfo u -> mkUTy u
111 mkFunTy (idType v) ty
112 | isTyVar v = mkForAllTy v ty
116 -- The first argument is just for debugging
117 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
118 applyTypeToArgs e op_ty [] = op_ty
120 applyTypeToArgs e op_ty (Type ty : args)
121 = -- Accumulate type arguments so we can instantiate all at once
122 applyTypeToArgs e (applyTys op_ty tys) rest_args
124 (tys, rest_args) = go [ty] args
125 go tys (Type ty : args) = go (ty:tys) args
126 go tys rest_args = (reverse tys, rest_args)
128 applyTypeToArgs e op_ty (other_arg : args)
129 = case (splitFunTy_maybe op_ty) of
130 Just (_, res_ty) -> applyTypeToArgs e res_ty args
131 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
136 %************************************************************************
138 \subsection{Attaching notes}
140 %************************************************************************
142 mkNote removes redundant coercions, and SCCs where possible
145 mkNote :: Note -> CoreExpr -> CoreExpr
146 mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr
147 mkNote (SCC cc) expr = mkSCC cc expr
148 mkNote InlineMe expr = mkInlineMe expr
149 mkNote note expr = Note note expr
151 -- Slide InlineCall in around the function
152 -- No longer necessary I think (SLPJ Apr 99)
153 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
154 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
155 -- mkNote InlineCall expr = expr
158 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
159 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
160 not be *applied* to anything.
162 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
165 f = inline_me (coerce t fw)
166 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
167 We want the split, so that the coerces can cancel at the call site.
169 However, we can get left with tiresome type applications. Notably, consider
170 f = /\ a -> let t = e in (t, w)
171 Then lifting the let out of the big lambda gives
173 f = /\ a -> let t = inline_me (t' a) in (t, w)
174 The inline_me is to stop the simplifier inlining t' right back
175 into t's RHS. In the next phase we'll substitute for t (since
176 its rhs is trivial) and *then* we could get rid of the inline_me.
177 But it hardly seems worth it, so I don't bother.
180 mkInlineMe (Var v) = Var v
181 mkInlineMe e = Note InlineMe e
187 mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
189 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
190 = ASSERT( from_ty == to_ty2 )
191 mkCoerce to_ty from_ty2 expr
193 mkCoerce to_ty from_ty expr
194 | to_ty == from_ty = expr
195 | otherwise = ASSERT( from_ty == exprType expr )
196 Note (Coerce to_ty from_ty) expr
200 mkSCC :: CostCentre -> Expr b -> Expr b
201 -- Note: Nested SCC's *are* preserved for the benefit of
202 -- cost centre stack profiling
203 mkSCC cc (Lit lit) = Lit lit
204 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
205 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
206 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
207 mkSCC cc expr = Note (SCC cc) expr
211 %************************************************************************
213 \subsection{Other expression construction}
215 %************************************************************************
218 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
219 -- (bindNonRec x r b) produces either
222 -- case r of x { _DEFAULT_ -> b }
224 -- depending on whether x is unlifted or not
225 -- It's used by the desugarer to avoid building bindings
226 -- that give Core Lint a heart attack. Actually the simplifier
227 -- deals with them perfectly well.
228 bindNonRec bndr rhs body
229 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
230 | otherwise = Let (NonRec bndr rhs) body
234 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
235 -- This guy constructs the value that the scrutinee must have
236 -- when you are in one particular branch of a case
237 mkAltExpr (DataAlt con) args inst_tys
238 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
239 mkAltExpr (LitAlt lit) [] []
242 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
243 mkIfThenElse guard then_expr else_expr
244 = Case guard (mkWildId boolTy)
245 [ (DataAlt trueDataCon, [], then_expr),
246 (DataAlt falseDataCon, [], else_expr) ]
250 %************************************************************************
252 \subsection{Taking expressions apart}
254 %************************************************************************
258 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
259 findDefault [] = ([], Nothing)
260 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
262 findDefault (alt : alts) = case findDefault alts of
263 (alts', deflt) -> (alt : alts', deflt)
265 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
269 go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
270 go (alt : alts) | matches alt = alt
271 | otherwise = go alts
273 matches (DEFAULT, _, _) = True
274 matches (con1, _, _) = con == con1
278 %************************************************************************
280 \subsection{Figuring out things about expressions}
282 %************************************************************************
284 @exprIsTrivial@ is true of expressions we are unconditionally happy to
285 duplicate; simple variables and constants, and type
286 applications. Note that primop Ids aren't considered
289 @exprIsBottom@ is true of expressions that are guaranteed to diverge
293 exprIsTrivial (Var v)
294 | hasNoBinding v = idArity v == 0
295 -- WAS: | Just op <- isPrimOpId_maybe v = primOpIsDupable op
296 -- The idea here is that a constructor worker, like $wJust, is
297 -- really short for (\x -> $wJust x), becuase $wJust has no binding.
298 -- So it should be treated like a lambda.
299 -- Ditto unsaturated primops.
300 -- This came up when dealing with eta expansion/reduction for
302 -- Here we want to eta-expand. This looks like an optimisation,
303 -- but it's important (albeit tiresome) that CoreSat doesn't increase
306 exprIsTrivial (Type _) = True
307 exprIsTrivial (Lit lit) = True
308 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
309 exprIsTrivial (Note _ e) = exprIsTrivial e
310 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
311 exprIsTrivial other = False
313 exprIsAtom :: CoreExpr -> Bool
314 -- Used to decide whether to let-binding an STG argument
315 -- when compiling to ILX => type applications are not allowed
316 exprIsAtom (Var v) = True -- primOpIsDupable?
317 exprIsAtom (Lit lit) = True
318 exprIsAtom (Type ty) = True
319 exprIsAtom (Note (SCC _) e) = False
320 exprIsAtom (Note _ e) = exprIsAtom e
321 exprIsAtom other = False
325 @exprIsDupable@ is true of expressions that can be duplicated at a modest
326 cost in code size. This will only happen in different case
327 branches, so there's no issue about duplicating work.
329 That is, exprIsDupable returns True of (f x) even if
330 f is very very expensive to call.
332 Its only purpose is to avoid fruitless let-binding
333 and then inlining of case join points
337 exprIsDupable (Type _) = True
338 exprIsDupable (Var v) = True
339 exprIsDupable (Lit lit) = litIsDupable lit
340 exprIsDupable (Note InlineMe e) = True
341 exprIsDupable (Note _ e) = exprIsDupable e
345 go (Var v) n_args = True
346 go (App f a) n_args = n_args < dupAppSize
349 go other n_args = False
352 dupAppSize = 4 -- Size of application we are prepared to duplicate
355 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
356 it is obviously in weak head normal form, or is cheap to get to WHNF.
357 [Note that that's not the same as exprIsDupable; an expression might be
358 big, and hence not dupable, but still cheap.]
360 By ``cheap'' we mean a computation we're willing to:
361 push inside a lambda, or
362 inline at more than one place
363 That might mean it gets evaluated more than once, instead of being
364 shared. The main examples of things which aren't WHNF but are
369 (where e, and all the ei are cheap)
372 (where e and b are cheap)
375 (where op is a cheap primitive operator)
378 (because we are happy to substitute it inside a lambda)
380 Notice that a variable is considered 'cheap': we can push it inside a lambda,
381 because sharing will make sure it is only evaluated once.
384 exprIsCheap :: CoreExpr -> Bool
385 exprIsCheap (Lit lit) = True
386 exprIsCheap (Type _) = True
387 exprIsCheap (Var _) = True
388 exprIsCheap (Note InlineMe e) = True
389 exprIsCheap (Note _ e) = exprIsCheap e
390 exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
391 exprIsCheap (Case e _ alts) = exprIsCheap e &&
392 and [exprIsCheap rhs | (_,_,rhs) <- alts]
393 -- Experimentally, treat (case x of ...) as cheap
394 -- (and case __coerce x etc.)
395 -- This improves arities of overloaded functions where
396 -- there is only dictionary selection (no construction) involved
397 exprIsCheap (Let (NonRec x _) e)
398 | isUnLiftedType (idType x) = exprIsCheap e
400 -- strict lets always have cheap right hand sides, and
403 exprIsCheap other_expr
404 = go other_expr 0 True
406 go (Var f) n_args args_cheap
407 = (idAppIsCheap f n_args && args_cheap)
408 -- A constructor, cheap primop, or partial application
410 || idAppIsBottom f n_args
411 -- Application of a function which
412 -- always gives bottom; we treat this as cheap
413 -- because it certainly doesn't need to be shared!
415 go (App f a) n_args args_cheap
416 | isTypeArg a = go f n_args args_cheap
417 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
419 go other n_args args_cheap = False
421 idAppIsCheap :: Id -> Int -> Bool
422 idAppIsCheap id n_val_args
423 | n_val_args == 0 = True -- Just a type application of
424 -- a variable (f t1 t2 t3)
426 | otherwise = case globalIdDetails id of
428 RecordSelId _ -> True -- I'm experimenting with making record selection
429 -- look cheap, so we will substitute it inside a
430 -- lambda. Particularly for dictionary field selection
432 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
433 -- that return a type variable, since the result
434 -- might be applied to something, but I'm not going
435 -- to bother to check the number of args
436 other -> n_val_args < idArity id
439 exprOkForSpeculation returns True of an expression that it is
441 * safe to evaluate even if normal order eval might not
442 evaluate the expression at all, or
444 * safe *not* to evaluate even if normal order would do so
448 the expression guarantees to terminate,
450 without raising an exception,
451 without causing a side effect (e.g. writing a mutable variable)
454 let x = case y# +# 1# of { r# -> I# r# }
457 case y# +# 1# of { r# ->
462 We can only do this if the (y+1) is ok for speculation: it has no
463 side effects, and can't diverge or raise an exception.
466 exprOkForSpeculation :: CoreExpr -> Bool
467 exprOkForSpeculation (Lit _) = True
468 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
469 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
470 exprOkForSpeculation other_expr
471 = go other_expr 0 True
473 go (Var f) n_args args_ok
474 = case globalIdDetails f of
475 DataConId _ -> True -- The strictness of the constructor has already
476 -- been expressed by its "wrapper", so we don't need
477 -- to take the arguments into account
479 PrimOpId op -> primOpOkForSpeculation op && args_ok
480 -- A bit conservative: we don't really need
481 -- to care about lazy arguments, but this is easy
485 go (App f a) n_args args_ok
486 | isTypeArg a = go f n_args args_ok
487 | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
489 go other n_args args_ok = False
494 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
495 exprIsBottom e = go 0 e
497 -- n is the number of args
498 go n (Note _ e) = go n e
499 go n (Let _ e) = go n e
500 go n (Case e _ _) = go 0 e -- Just check the scrut
501 go n (App e _) = go (n+1) e
502 go n (Var v) = idAppIsBottom v n
504 go n (Lam _ _) = False
506 idAppIsBottom :: Id -> Int -> Bool
507 idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
510 @exprIsValue@ returns true for expressions that are certainly *already*
511 evaluated to WHNF. This is used to decide wether it's ok to change
512 case x of _ -> e ===> e
514 and to decide whether it's safe to discard a `seq`
516 So, it does *not* treat variables as evaluated, unless they say they are.
518 But it *does* treat partial applications and constructor applications
519 as values, even if their arguments are non-trivial;
520 e.g. (:) (f x) (map f xs) is a value
521 map (...redex...) is a value
522 Because `seq` on such things completes immediately
524 A possible worry: constructors with unboxed args:
526 Suppose (f x) diverges; then C (f x) is not a value. True, but
527 this form is illegal (see the invariants in CoreSyn). Args of unboxed
528 type must be ok-for-speculation (or trivial).
531 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
532 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
534 exprIsValue (Lit l) = True
535 exprIsValue (Lam b e) = isId b || exprIsValue e
536 exprIsValue (Note _ e) = exprIsValue e
537 exprIsValue other_expr
540 go (Var f) n_args = idAppIsValue f n_args
543 | isTypeArg a = go f n_args
544 | otherwise = go f (n_args + 1)
546 go (Note _ f) n_args = go f n_args
548 go other n_args = False
550 idAppIsValue :: Id -> Int -> Bool
551 idAppIsValue id n_val_args
552 = case globalIdDetails id of
554 PrimOpId _ -> n_val_args < idArity id
555 other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
556 | otherwise -> n_val_args < idArity id
557 -- A worry: what if an Id's unfolding is just itself:
558 -- then we could get an infinite loop...
562 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
563 exprIsConApp_maybe (Note InlineMe expr) = exprIsConApp_maybe expr
564 exprIsConApp_maybe expr = analyse (collectArgs expr)
566 analyse (Var fun, args)
567 | Just con <- isDataConId_maybe fun,
568 length args >= dataConRepArity con
569 -- Might be > because the arity excludes type args
572 -- Look through unfoldings, but only cheap ones, because
573 -- we are effectively duplicating the unfolding
574 analyse (Var fun, [])
575 | let unf = idUnfolding fun,
577 = exprIsConApp_maybe (unfoldingTemplate unf)
579 analyse other = Nothing
584 %************************************************************************
586 \subsection{Eta reduction and expansion}
588 %************************************************************************
590 @etaReduce@ trys an eta reduction at the top level of a Core Expr.
592 e.g. \ x y -> f x y ===> f
594 But we only do this if it gets rid of a whole lambda, not part.
595 The idea is that lambdas are often quite helpful: they indicate
596 head normal forms, so we don't want to chuck them away lightly.
599 etaReduce :: CoreExpr -> CoreExpr
600 -- ToDo: we should really check that we don't turn a non-bottom
601 -- lambda into a bottom variable. Sigh
603 etaReduce expr@(Lam bndr body)
604 = check (reverse binders) body
606 (binders, body) = collectBinders expr
609 | not (any (`elemVarSet` body_fvs) binders)
612 body_fvs = exprFreeVars body
614 check (b : bs) (App fun arg)
615 | (varToCoreExpr b `cheapEqExpr` arg)
618 check _ _ = expr -- Bale out
620 etaReduce expr = expr -- The common case
625 exprEtaExpandArity :: CoreExpr -> (Int, Bool)
626 -- The Int is number of value args the thing can be
627 -- applied to without doing much work
628 -- The Bool is True iff there are enough explicit value lambdas
629 -- at the top to make this arity apparent
630 -- (but ignore it when arity==0)
632 -- This is used when eta expanding
633 -- e ==> \xy -> e x y
635 -- It returns 1 (or more) to:
636 -- case x of p -> \s -> ...
637 -- because for I/O ish things we really want to get that \s to the top.
638 -- We are prepared to evaluate x each time round the loop in order to get that
640 -- Consider let x = expensive in \y z -> E
641 -- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
643 -- Hence the list of Bools returned by go1
644 -- NB: this is particularly important/useful for IO state
645 -- transformers, where we often get
646 -- let x = E in \ s -> ...
647 -- and the \s is a real-world state token abstraction. Such
648 -- abstractions are almost invariably 1-shot, so we want to
649 -- pull the \s out, past the let x=E.
650 -- The hack is in Id.isOneShotLambda
655 go :: Int -> CoreExpr -> (Int,Bool)
656 go ar (Lam x e) | isId x = go (ar+1) e
657 | otherwise = go ar e
658 go ar (Note n e) | ok_note n = go ar e
659 go ar other = (ar + ar', ar' == 0)
661 ar' = length (go1 other)
663 go1 :: CoreExpr -> [Bool]
664 -- (go1 e) = [b1,..,bn]
665 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
666 -- where bi is True <=> the lambda is one-shot
668 go1 (Note n e) | ok_note n = go1 e
669 go1 (Var v) = replicate (idArity v) False -- When the type of the Id
670 -- encodes one-shot-ness, use
673 -- Lambdas; increase arity
674 go1 (Lam x e) | isId x = isOneShotLambda x : go1 e
677 -- Applications; decrease arity
678 go1 (App f (Type _)) = go1 f
679 go1 (App f a) = case go1 f of
680 (one_shot : xs) | one_shot || exprIsCheap a -> xs
683 -- Case/Let; keep arity if either the expression is cheap
684 -- or it's a 1-shot lambda
685 go1 (Case scrut _ alts) = case foldr1 (zipWith (&&)) [go1 rhs | (_,_,rhs) <- alts] of
686 xs@(one_shot : _) | one_shot || exprIsCheap scrut -> xs
688 go1 (Let b e) = case go1 e of
689 xs@(one_shot : _) | one_shot || all exprIsCheap (rhssOfBind b) -> xs
694 ok_note (Coerce _ _) = True
695 ok_note InlineCall = True
696 ok_note other = False
697 -- Notice that we do not look through __inline_me__
698 -- This may seem surprising, but consider
699 -- f = _inline_me (\x -> e)
700 -- We DO NOT want to eta expand this to
701 -- f = \x -> (_inline_me (\x -> e)) x
702 -- because the _inline_me gets dropped now it is applied,
707 min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
708 min_zero (x:xs) = go x xs
710 go 0 xs = 0 -- Nothing beats zero
712 go min (x:xs) | x < min = go x xs
713 | otherwise = go min xs
719 etaExpand :: Int -- Add this number of value args
721 -> CoreExpr -> Type -- Expression and its type
723 -- (etaExpand n us e ty) returns an expression with
724 -- the same meaning as 'e', but with arity 'n'.
726 -- Given e' = etaExpand n us e ty
728 -- ty = exprType e = exprType e'
730 -- etaExpand deals with for-alls and coerces. For example:
732 -- where E :: forall a. T
733 -- newtype T = MkT (A -> B)
736 -- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
738 etaExpand n us expr ty
739 | n == 0 -- Saturated, so nothing to do
742 | otherwise -- An unsaturated constructor or primop; eta expand it
743 = case splitForAllTy_maybe ty of {
744 Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
748 case splitFunTy_maybe ty of {
749 Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
751 arg1 = mkSysLocal SLIT("eta") uniq arg_ty
752 (us1, us2) = splitUniqSupply us
753 uniq = uniqFromSupply us1
757 case splitNewType_maybe ty of {
758 Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
760 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
765 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
766 It tells how many things the expression can be applied to before doing
767 any work. It doesn't look inside cases, lets, etc. The idea is that
768 exprEtaExpandArity will do the hard work, leaving something that's easy
769 for exprArity to grapple with. In particular, Simplify uses exprArity to
770 compute the ArityInfo for the Id.
772 Originally I thought that it was enough just to look for top-level lambdas, but
773 it isn't. I've seen this
775 foo = PrelBase.timesInt
777 We want foo to get arity 2 even though the eta-expander will leave it
778 unchanged, in the expectation that it'll be inlined. But occasionally it
779 isn't, because foo is blacklisted (used in a rule).
781 Similarly, see the ok_note check in exprEtaExpandArity. So
782 f = __inline_me (\x -> e)
783 won't be eta-expanded.
785 And in any case it seems more robust to have exprArity be a bit more intelligent.
788 exprArity :: CoreExpr -> Int
789 exprArity e = go e `max` 0
791 go (Lam x e) | isId x = go e + 1
794 go (App e (Type t)) = go e
795 go (App f a) = go f - 1
796 go (Var v) = idArity v
801 %************************************************************************
803 \subsection{Equality}
805 %************************************************************************
807 @cheapEqExpr@ is a cheap equality test which bales out fast!
808 True => definitely equal
809 False => may or may not be equal
812 cheapEqExpr :: Expr b -> Expr b -> Bool
814 cheapEqExpr (Var v1) (Var v2) = v1==v2
815 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
816 cheapEqExpr (Type t1) (Type t2) = t1 == t2
818 cheapEqExpr (App f1 a1) (App f2 a2)
819 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
821 cheapEqExpr _ _ = False
823 exprIsBig :: Expr b -> Bool
824 -- Returns True of expressions that are too big to be compared by cheapEqExpr
825 exprIsBig (Lit _) = False
826 exprIsBig (Var v) = False
827 exprIsBig (Type t) = False
828 exprIsBig (App f a) = exprIsBig f || exprIsBig a
829 exprIsBig other = True
834 eqExpr :: CoreExpr -> CoreExpr -> Bool
835 -- Works ok at more general type, but only needed at CoreExpr
837 = eq emptyVarEnv e1 e2
839 -- The "env" maps variables in e1 to variables in ty2
840 -- So when comparing lambdas etc,
841 -- we in effect substitute v2 for v1 in e1 before continuing
842 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
843 Just v1' -> v1' == v2
846 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
847 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
848 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
849 eq env (Let (NonRec v1 r1) e1)
850 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
851 eq env (Let (Rec ps1) e1)
852 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
853 and (zipWith eq_rhs ps1 ps2) &&
856 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
857 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
858 eq env (Case e1 v1 a1)
859 (Case e2 v2 a2) = eq env e1 e2 &&
860 length a1 == length a2 &&
861 and (zipWith (eq_alt env') a1 a2)
863 env' = extendVarEnv env v1 v2
865 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
866 eq env (Type t1) (Type t2) = t1 == t2
869 eq_list env [] [] = True
870 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
871 eq_list env es1 es2 = False
873 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
874 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
876 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
877 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
878 eq_note env InlineCall InlineCall = True
879 eq_note env other1 other2 = False
883 %************************************************************************
885 \subsection{The size of an expression}
887 %************************************************************************
890 coreBindsSize :: [CoreBind] -> Int
891 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
893 exprSize :: CoreExpr -> Int
894 -- A measure of the size of the expressions
895 -- It also forces the expression pretty drastically as a side effect
896 exprSize (Var v) = varSize v
897 exprSize (Lit lit) = lit `seq` 1
898 exprSize (App f a) = exprSize f + exprSize a
899 exprSize (Lam b e) = varSize b + exprSize e
900 exprSize (Let b e) = bindSize b + exprSize e
901 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
902 exprSize (Note n e) = noteSize n + exprSize e
903 exprSize (Type t) = seqType t `seq` 1
905 noteSize (SCC cc) = cc `seq` 1
906 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
907 noteSize InlineCall = 1
908 noteSize InlineMe = 1
910 varSize :: Var -> Int
911 varSize b | isTyVar b = 1
912 | otherwise = seqType (idType b) `seq`
913 megaSeqIdInfo (idInfo b) `seq`
916 varsSize = foldr ((+) . varSize) 0
918 bindSize (NonRec b e) = varSize b + exprSize e
919 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
921 pairSize (b,e) = varSize b + exprSize e
923 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
927 %************************************************************************
931 %************************************************************************
934 hashExpr :: CoreExpr -> Int
935 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
938 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
940 hash_expr (Note _ e) = hash_expr e
941 hash_expr (Let (NonRec b r) e) = hashId b
942 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
943 hash_expr (Case _ b _) = hashId b
944 hash_expr (App f e) = hash_expr f * fast_hash_expr e
945 hash_expr (Var v) = hashId v
946 hash_expr (Lit lit) = hashLiteral lit
947 hash_expr (Lam b _) = hashId b
948 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
950 fast_hash_expr (Var v) = hashId v
951 fast_hash_expr (Lit lit) = hashLiteral lit
952 fast_hash_expr (App f (Type _)) = fast_hash_expr f
953 fast_hash_expr (App f a) = fast_hash_expr a
954 fast_hash_expr (Lam b _) = hashId b
955 fast_hash_expr other = 1
958 hashId id = hashName (idName id)