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 (Durham)
204 mkSCC cc (Lit lit) = Lit lit
205 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
206 mkSCC cc expr = Note (SCC cc) expr
210 %************************************************************************
212 \subsection{Other expression construction}
214 %************************************************************************
217 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
218 -- (bindNonRec x r b) produces either
221 -- case r of x { _DEFAULT_ -> b }
223 -- depending on whether x is unlifted or not
224 -- It's used by the desugarer to avoid building bindings
225 -- that give Core Lint a heart attack. Actually the simplifier
226 -- deals with them perfectly well.
227 bindNonRec bndr rhs body
228 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
229 | otherwise = Let (NonRec bndr rhs) body
233 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
234 -- This guy constructs the value that the scrutinee must have
235 -- when you are in one particular branch of a case
236 mkAltExpr (DataAlt con) args inst_tys
237 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
238 mkAltExpr (LitAlt lit) [] []
241 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
242 mkIfThenElse guard then_expr else_expr
243 = Case guard (mkWildId boolTy)
244 [ (DataAlt trueDataCon, [], then_expr),
245 (DataAlt falseDataCon, [], else_expr) ]
249 %************************************************************************
251 \subsection{Taking expressions apart}
253 %************************************************************************
257 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
258 findDefault [] = ([], Nothing)
259 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
261 findDefault (alt : alts) = case findDefault alts of
262 (alts', deflt) -> (alt : alts', deflt)
264 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
268 go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
269 go (alt : alts) | matches alt = alt
270 | otherwise = go alts
272 matches (DEFAULT, _, _) = True
273 matches (con1, _, _) = con == con1
277 %************************************************************************
279 \subsection{Figuring out things about expressions}
281 %************************************************************************
283 @exprIsTrivial@ is true of expressions we are unconditionally happy to
284 duplicate; simple variables and constants, and type
285 applications. Note that primop Ids aren't considered
288 @exprIsBottom@ is true of expressions that are guaranteed to diverge
292 exprIsTrivial (Var v)
293 | hasNoBinding v = idArity v == 0
294 -- WAS: | Just op <- isPrimOpId_maybe v = primOpIsDupable op
295 -- The idea here is that a constructor worker, like $wJust, is
296 -- really short for (\x -> $wJust x), becuase $wJust has no binding.
297 -- So it should be treated like a lambda.
298 -- Ditto unsaturated primops.
299 -- This came up when dealing with eta expansion/reduction for
301 -- Here we want to eta-expand. This looks like an optimisation,
302 -- but it's important (albeit tiresome) that CoreSat doesn't increase
305 exprIsTrivial (Type _) = True
306 exprIsTrivial (Lit lit) = True
307 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
308 exprIsTrivial (Note _ e) = exprIsTrivial e
309 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
310 exprIsTrivial other = False
312 exprIsAtom :: CoreExpr -> Bool
313 -- Used to decide whether to let-binding an STG argument
314 -- when compiling to ILX => type applications are not allowed
315 exprIsAtom (Var v) = True -- primOpIsDupable?
316 exprIsAtom (Lit lit) = True
317 exprIsAtom (Type ty) = True
318 exprIsAtom (Note (SCC _) e) = False
319 exprIsAtom (Note _ e) = exprIsAtom e
320 exprIsAtom other = False
324 @exprIsDupable@ is true of expressions that can be duplicated at a modest
325 cost in code size. This will only happen in different case
326 branches, so there's no issue about duplicating work.
328 That is, exprIsDupable returns True of (f x) even if
329 f is very very expensive to call.
331 Its only purpose is to avoid fruitless let-binding
332 and then inlining of case join points
336 exprIsDupable (Type _) = True
337 exprIsDupable (Var v) = True
338 exprIsDupable (Lit lit) = litIsDupable lit
339 exprIsDupable (Note _ e) = exprIsDupable e
343 go (Var v) n_args = True
344 go (App f a) n_args = n_args < dupAppSize
347 go other n_args = False
350 dupAppSize = 4 -- Size of application we are prepared to duplicate
353 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
354 it is obviously in weak head normal form, or is cheap to get to WHNF.
355 [Note that that's not the same as exprIsDupable; an expression might be
356 big, and hence not dupable, but still cheap.]
358 By ``cheap'' we mean a computation we're willing to:
359 push inside a lambda, or
360 inline at more than one place
361 That might mean it gets evaluated more than once, instead of being
362 shared. The main examples of things which aren't WHNF but are
367 (where e, and all the ei are cheap)
370 (where e and b are cheap)
373 (where op is a cheap primitive operator)
376 (because we are happy to substitute it inside a lambda)
378 Notice that a variable is considered 'cheap': we can push it inside a lambda,
379 because sharing will make sure it is only evaluated once.
382 exprIsCheap :: CoreExpr -> Bool
383 exprIsCheap (Lit lit) = True
384 exprIsCheap (Type _) = True
385 exprIsCheap (Var _) = True
386 exprIsCheap (Note _ e) = exprIsCheap e
387 exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
388 exprIsCheap (Case e _ alts) = exprIsCheap e &&
389 and [exprIsCheap rhs | (_,_,rhs) <- alts]
390 -- Experimentally, treat (case x of ...) as cheap
391 -- (and case __coerce x etc.)
392 -- This improves arities of overloaded functions where
393 -- there is only dictionary selection (no construction) involved
394 exprIsCheap (Let (NonRec x _) e)
395 | isUnLiftedType (idType x) = exprIsCheap e
397 -- strict lets always have cheap right hand sides, and
400 exprIsCheap other_expr
401 = go other_expr 0 True
403 go (Var f) n_args args_cheap
404 = (idAppIsCheap f n_args && args_cheap)
405 -- A constructor, cheap primop, or partial application
407 || idAppIsBottom f n_args
408 -- Application of a function which
409 -- always gives bottom; we treat this as cheap
410 -- because it certainly doesn't need to be shared!
412 go (App f a) n_args args_cheap
413 | isTypeArg a = go f n_args args_cheap
414 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
416 go other n_args args_cheap = False
418 idAppIsCheap :: Id -> Int -> Bool
419 idAppIsCheap id n_val_args
420 | n_val_args == 0 = True -- Just a type application of
421 -- a variable (f t1 t2 t3)
423 | otherwise = case globalIdDetails id of
425 RecordSelId _ -> True -- I'm experimenting with making record selection
426 -- look cheap, so we will substitute it inside a
427 -- lambda. Particularly for dictionary field selection
429 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
430 -- that return a type variable, since the result
431 -- might be applied to something, but I'm not going
432 -- to bother to check the number of args
433 other -> n_val_args < idArity id
436 exprOkForSpeculation returns True of an expression that it is
438 * safe to evaluate even if normal order eval might not
439 evaluate the expression at all, or
441 * safe *not* to evaluate even if normal order would do so
445 the expression guarantees to terminate,
447 without raising an exception,
448 without causing a side effect (e.g. writing a mutable variable)
451 let x = case y# +# 1# of { r# -> I# r# }
454 case y# +# 1# of { r# ->
459 We can only do this if the (y+1) is ok for speculation: it has no
460 side effects, and can't diverge or raise an exception.
463 exprOkForSpeculation :: CoreExpr -> Bool
464 exprOkForSpeculation (Lit _) = True
465 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
466 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
467 exprOkForSpeculation other_expr
468 = go other_expr 0 True
470 go (Var f) n_args args_ok
471 = case globalIdDetails f of
472 DataConId _ -> True -- The strictness of the constructor has already
473 -- been expressed by its "wrapper", so we don't need
474 -- to take the arguments into account
476 PrimOpId op -> primOpOkForSpeculation op && args_ok
477 -- A bit conservative: we don't really need
478 -- to care about lazy arguments, but this is easy
482 go (App f a) n_args args_ok
483 | isTypeArg a = go f n_args args_ok
484 | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
486 go other n_args args_ok = False
491 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
492 exprIsBottom e = go 0 e
494 -- n is the number of args
495 go n (Note _ e) = go n e
496 go n (Let _ e) = go n e
497 go n (Case e _ _) = go 0 e -- Just check the scrut
498 go n (App e _) = go (n+1) e
499 go n (Var v) = idAppIsBottom v n
501 go n (Lam _ _) = False
503 idAppIsBottom :: Id -> Int -> Bool
504 idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
507 @exprIsValue@ returns true for expressions that are certainly *already*
508 evaluated to WHNF. This is used to decide wether it's ok to change
509 case x of _ -> e ===> e
511 and to decide whether it's safe to discard a `seq`
513 So, it does *not* treat variables as evaluated, unless they say they are.
515 But it *does* treat partial applications and constructor applications
516 as values, even if their arguments are non-trivial;
517 e.g. (:) (f x) (map f xs) is a value
518 map (...redex...) is a value
519 Because `seq` on such things completes immediately
521 A worry: constructors with unboxed args:
523 Suppose (f x) diverges; then C (f x) is not a value.
526 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
527 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
529 exprIsValue (Lit l) = True
530 exprIsValue (Lam b e) = isId b || exprIsValue e
531 exprIsValue (Note _ e) = exprIsValue e
532 exprIsValue other_expr
535 go (Var f) n_args = idAppIsValue f n_args
538 | isTypeArg a = go f n_args
539 | otherwise = go f (n_args + 1)
541 go (Note _ f) n_args = go f n_args
543 go other n_args = False
545 idAppIsValue :: Id -> Int -> Bool
546 idAppIsValue id n_val_args
547 = case globalIdDetails id of
549 PrimOpId _ -> n_val_args < idArity id
550 other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
551 | otherwise -> n_val_args < idArity id
552 -- A worry: what if an Id's unfolding is just itself:
553 -- then we could get an infinite loop...
557 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
558 exprIsConApp_maybe expr
559 = analyse (collectArgs expr)
561 analyse (Var fun, args)
562 | Just con <- isDataConId_maybe fun,
563 length args >= dataConRepArity con
564 -- Might be > because the arity excludes type args
567 -- Look through unfoldings, but only cheap ones, because
568 -- we are effectively duplicating the unfolding
569 analyse (Var fun, [])
570 | let unf = idUnfolding fun,
572 = exprIsConApp_maybe (unfoldingTemplate unf)
574 analyse other = Nothing
577 The arity of an expression (in the code-generator sense, i.e. the
578 number of lambdas at the beginning).
581 exprArity :: CoreExpr -> Int
583 | isTyVar x = exprArity e
584 | otherwise = 1 + exprArity e
586 -- Ignore coercions. Top level sccs are removed by the final
587 -- profiling pass, so we ignore those too.
593 %************************************************************************
595 \subsection{Eta reduction and expansion}
597 %************************************************************************
599 @etaReduce@ trys an eta reduction at the top level of a Core Expr.
601 e.g. \ x y -> f x y ===> f
603 But we only do this if it gets rid of a whole lambda, not part.
604 The idea is that lambdas are often quite helpful: they indicate
605 head normal forms, so we don't want to chuck them away lightly.
608 etaReduce :: CoreExpr -> CoreExpr
609 -- ToDo: we should really check that we don't turn a non-bottom
610 -- lambda into a bottom variable. Sigh
612 etaReduce expr@(Lam bndr body)
613 = check (reverse binders) body
615 (binders, body) = collectBinders expr
618 | not (any (`elemVarSet` body_fvs) binders)
621 body_fvs = exprFreeVars body
623 check (b : bs) (App fun arg)
624 | (varToCoreExpr b `cheapEqExpr` arg)
627 check _ _ = expr -- Bale out
629 etaReduce expr = expr -- The common case
634 exprEtaExpandArity :: CoreExpr -> (Int, Bool)
635 -- The Int is number of value args the thing can be
636 -- applied to without doing much work
637 -- The Bool is True iff there are enough explicit value lambdas
638 -- at the top to make this arity apparent
639 -- (but ignore it when arity==0)
641 -- This is used when eta expanding
642 -- e ==> \xy -> e x y
644 -- It returns 1 (or more) to:
645 -- case x of p -> \s -> ...
646 -- because for I/O ish things we really want to get that \s to the top.
647 -- We are prepared to evaluate x each time round the loop in order to get that
649 -- Consider let x = expensive in \y z -> E
650 -- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
651 -- Hence the extra Bool returned by go1
652 -- NB: this is particularly important/useful for IO state
653 -- transformers, where we often get
654 -- let x = E in \ s -> ...
655 -- and the \s is a real-world state token abstraction. Such
656 -- abstractions are almost invariably 1-shot, so we want to
657 -- pull the \s out, past the let x=E.
658 -- The hack is in Id.isOneShotLambda
663 go :: Int -> CoreExpr -> (Int,Bool)
664 go ar (Lam x e) | isId x = go (ar+1) e
665 | otherwise = go ar e
666 go ar (Note n e) | ok_note n = go ar e
667 go ar other = (ar + ar', ar' == 0)
669 ar' = length (go1 other)
671 go1 :: CoreExpr -> [Bool]
672 -- (go1 e) = [b1,..,bn]
673 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
674 -- where bi is True <=> the lambda is one-shot
676 go1 (Note n e) | ok_note n = go1 e
677 go1 (Var v) = replicate (idArity v) False -- When the type of the Id
678 -- encodes one-shot-ness, use
681 -- Lambdas; increase arity
682 go1 (Lam x e) | isId x = isOneShotLambda x : go1 e
685 -- Applications; decrease arity
686 go1 (App f (Type _)) = go1 f
687 go1 (App f a) = case go1 f of
688 (one_shot : xs) | one_shot || exprIsCheap a -> xs
691 -- Case/Let; keep arity if either the expression is cheap
692 -- or it's a 1-shot lambda
693 go1 (Case scrut _ alts) = case foldr1 (zipWith (&&)) [go1 rhs | (_,_,rhs) <- alts] of
694 xs@(one_shot : _) | one_shot || exprIsCheap scrut -> xs
696 go1 (Let b e) = case go1 e of
697 xs@(one_shot : _) | one_shot || all exprIsCheap (rhssOfBind b) -> xs
702 ok_note (Coerce _ _) = True
703 ok_note InlineCall = True
704 ok_note other = False
705 -- Notice that we do not look through __inline_me__
706 -- This one is a bit more surprising, but consider
707 -- f = _inline_me (\x -> e)
708 -- We DO NOT want to eta expand this to
709 -- f = \x -> (_inline_me (\x -> e)) x
710 -- because the _inline_me gets dropped now it is applied,
715 min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
716 min_zero (x:xs) = go x xs
718 go 0 xs = 0 -- Nothing beats zero
720 go min (x:xs) | x < min = go x xs
721 | otherwise = go min xs
727 etaExpand :: Int -- Add this number of value args
729 -> CoreExpr -> Type -- Expression and its type
731 -- (etaExpand n us e ty) returns an expression with
732 -- the same meaning as 'e', but with arity 'n'.
734 -- Given e' = etaExpand n us e ty
736 -- ty = exprType e = exprType e'
738 -- etaExpand deals with for-alls and coerces. For example:
740 -- where E :: forall a. T
741 -- newtype T = MkT (A -> B)
744 -- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
746 -- (case x of { I# x -> /\ a -> coerce T E)
748 etaExpand n us expr ty
749 | n == 0 -- Saturated, so nothing to do
752 | otherwise -- An unsaturated constructor or primop; eta expand it
753 = case splitForAllTy_maybe ty of {
754 Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
758 case splitFunTy_maybe ty of {
759 Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
761 arg1 = mkSysLocal SLIT("eta") uniq arg_ty
762 (us1, us2) = splitUniqSupply us
763 uniq = uniqFromSupply us1
767 case splitNewType_maybe ty of {
768 Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
770 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
775 %************************************************************************
777 \subsection{Equality}
779 %************************************************************************
781 @cheapEqExpr@ is a cheap equality test which bales out fast!
782 True => definitely equal
783 False => may or may not be equal
786 cheapEqExpr :: Expr b -> Expr b -> Bool
788 cheapEqExpr (Var v1) (Var v2) = v1==v2
789 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
790 cheapEqExpr (Type t1) (Type t2) = t1 == t2
792 cheapEqExpr (App f1 a1) (App f2 a2)
793 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
795 cheapEqExpr _ _ = False
797 exprIsBig :: Expr b -> Bool
798 -- Returns True of expressions that are too big to be compared by cheapEqExpr
799 exprIsBig (Lit _) = False
800 exprIsBig (Var v) = False
801 exprIsBig (Type t) = False
802 exprIsBig (App f a) = exprIsBig f || exprIsBig a
803 exprIsBig other = True
808 eqExpr :: CoreExpr -> CoreExpr -> Bool
809 -- Works ok at more general type, but only needed at CoreExpr
811 = eq emptyVarEnv e1 e2
813 -- The "env" maps variables in e1 to variables in ty2
814 -- So when comparing lambdas etc,
815 -- we in effect substitute v2 for v1 in e1 before continuing
816 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
817 Just v1' -> v1' == v2
820 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
821 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
822 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
823 eq env (Let (NonRec v1 r1) e1)
824 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
825 eq env (Let (Rec ps1) e1)
826 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
827 and (zipWith eq_rhs ps1 ps2) &&
830 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
831 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
832 eq env (Case e1 v1 a1)
833 (Case e2 v2 a2) = eq env e1 e2 &&
834 length a1 == length a2 &&
835 and (zipWith (eq_alt env') a1 a2)
837 env' = extendVarEnv env v1 v2
839 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
840 eq env (Type t1) (Type t2) = t1 == t2
843 eq_list env [] [] = True
844 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
845 eq_list env es1 es2 = False
847 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
848 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
850 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
851 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
852 eq_note env InlineCall InlineCall = True
853 eq_note env other1 other2 = False
857 %************************************************************************
859 \subsection{The size of an expression}
861 %************************************************************************
864 coreBindsSize :: [CoreBind] -> Int
865 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
867 exprSize :: CoreExpr -> Int
868 -- A measure of the size of the expressions
869 -- It also forces the expression pretty drastically as a side effect
870 exprSize (Var v) = varSize v
871 exprSize (Lit lit) = lit `seq` 1
872 exprSize (App f a) = exprSize f + exprSize a
873 exprSize (Lam b e) = varSize b + exprSize e
874 exprSize (Let b e) = bindSize b + exprSize e
875 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
876 exprSize (Note n e) = noteSize n + exprSize e
877 exprSize (Type t) = seqType t `seq` 1
879 noteSize (SCC cc) = cc `seq` 1
880 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
881 noteSize InlineCall = 1
882 noteSize InlineMe = 1
884 varSize :: Var -> Int
885 varSize b | isTyVar b = 1
886 | otherwise = seqType (idType b) `seq`
887 megaSeqIdInfo (idInfo b) `seq`
890 varsSize = foldr ((+) . varSize) 0
892 bindSize (NonRec b e) = varSize b + exprSize e
893 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
895 pairSize (b,e) = varSize b + exprSize e
897 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
901 %************************************************************************
905 %************************************************************************
908 hashExpr :: CoreExpr -> Int
909 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
912 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
914 hash_expr (Note _ e) = hash_expr e
915 hash_expr (Let (NonRec b r) e) = hashId b
916 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
917 hash_expr (Case _ b _) = hashId b
918 hash_expr (App f e) = hash_expr f * fast_hash_expr e
919 hash_expr (Var v) = hashId v
920 hash_expr (Lit lit) = hashLiteral lit
921 hash_expr (Lam b _) = hashId b
922 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
924 fast_hash_expr (Var v) = hashId v
925 fast_hash_expr (Lit lit) = hashLiteral lit
926 fast_hash_expr (App f (Type _)) = fast_hash_expr f
927 fast_hash_expr (App f a) = fast_hash_expr a
928 fast_hash_expr (Lam b _) = hashId b
929 fast_hash_expr other = 1
932 hashId id = hashName (idName id)