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 -- Properties of expressions
14 exprType, coreAltsType,
15 exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
16 exprIsValue,exprOkForSpeculation, exprIsBig,
18 idAppIsBottom, idAppIsCheap,
21 -- Expr transformation
23 exprArity, exprEtaExpandArity,
32 cheapEqExpr, eqExpr, applyTypeToArgs
35 #include "HsVersions.h"
38 import GlaExts -- For `xori`
41 import CoreFVs ( exprFreeVars )
42 import PprCore ( pprCoreExpr )
43 import Var ( Var, isId, isTyVar )
46 import Name ( hashName )
47 import Literal ( hashLiteral, literalType, litIsDupable )
48 import DataCon ( DataCon, dataConRepArity )
49 import PrimOp ( primOpOkForSpeculation, primOpIsCheap,
51 import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo,
52 mkWildId, idArity, idName, idUnfolding, idInfo,
53 isDataConId_maybe, isPrimOpId_maybe, mkSysLocal
55 import IdInfo ( LBVarInfo(..),
58 import Demand ( appIsBottom )
59 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
60 applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
61 splitForAllTy_maybe, splitNewType_maybe
63 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
64 import CostCentre ( CostCentre )
65 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
66 import Maybes ( maybeToBool )
68 import TysPrim ( alphaTy ) -- Debugging only
72 %************************************************************************
74 \subsection{Find the type of a Core atom/expression}
76 %************************************************************************
79 exprType :: CoreExpr -> Type
81 exprType (Var var) = idType var
82 exprType (Lit lit) = literalType lit
83 exprType (Let _ body) = exprType body
84 exprType (Case _ _ alts) = coreAltsType alts
85 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
86 exprType (Note other_note e) = exprType e
87 exprType (Lam binder expr) = mkPiType binder (exprType expr)
89 = case collectArgs e of
90 (fun, args) -> applyTypeToArgs e (exprType fun) args
92 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
94 coreAltsType :: [CoreAlt] -> Type
95 coreAltsType ((_,_,rhs) : _) = exprType rhs
98 @mkPiType@ makes a (->) type or a forall type, depending on whether
99 it is given a type variable or a term variable. We cleverly use the
100 lbvarinfo field to figure out the right annotation for the arrove in
101 case of a term variable.
104 mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work...
105 mkPiType v ty | isId v = (case idLBVarInfo v of
106 LBVarInfo u -> mkUTy u
108 mkFunTy (idType v) ty
109 | isTyVar v = mkForAllTy v ty
113 -- The first argument is just for debugging
114 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
115 applyTypeToArgs e op_ty [] = op_ty
117 applyTypeToArgs e op_ty (Type ty : args)
118 = -- Accumulate type arguments so we can instantiate all at once
119 applyTypeToArgs e (applyTys op_ty tys) rest_args
121 (tys, rest_args) = go [ty] args
122 go tys (Type ty : args) = go (ty:tys) args
123 go tys rest_args = (reverse tys, rest_args)
125 applyTypeToArgs e op_ty (other_arg : args)
126 = case (splitFunTy_maybe op_ty) of
127 Just (_, res_ty) -> applyTypeToArgs e res_ty args
128 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
133 %************************************************************************
135 \subsection{Attaching notes}
137 %************************************************************************
139 mkNote removes redundant coercions, and SCCs where possible
142 mkNote :: Note -> CoreExpr -> CoreExpr
143 mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr
144 mkNote (SCC cc) expr = mkSCC cc expr
145 mkNote InlineMe expr = mkInlineMe expr
146 mkNote note expr = Note note expr
148 -- Slide InlineCall in around the function
149 -- No longer necessary I think (SLPJ Apr 99)
150 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
151 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
152 -- mkNote InlineCall expr = expr
155 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
156 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
157 not be *applied* to anything.
160 mkInlineMe e | exprIsTrivial e = e
161 | otherwise = Note InlineMe e
167 mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
169 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
170 = ASSERT( from_ty == to_ty2 )
171 mkCoerce to_ty from_ty2 expr
173 mkCoerce to_ty from_ty expr
174 | to_ty == from_ty = expr
175 | otherwise = ASSERT( from_ty == exprType expr )
176 Note (Coerce to_ty from_ty) expr
180 mkSCC :: CostCentre -> Expr b -> Expr b
181 -- Note: Nested SCC's *are* preserved for the benefit of
182 -- cost centre stack profiling (Durham)
184 mkSCC cc (Lit lit) = Lit lit
185 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
186 mkSCC cc expr = Note (SCC cc) expr
190 %************************************************************************
192 \subsection{Other expression construction}
194 %************************************************************************
197 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
198 -- (bindNonRec x r b) produces either
201 -- case r of x { _DEFAULT_ -> b }
203 -- depending on whether x is unlifted or not
204 -- It's used by the desugarer to avoid building bindings
205 -- that give Core Lint a heart attack. Actually the simplifier
206 -- deals with them perfectly well.
207 bindNonRec bndr rhs body
208 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
209 | otherwise = Let (NonRec bndr rhs) body
213 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
214 -- This guy constructs the value that the scrutinee must have
215 -- when you are in one particular branch of a case
216 mkAltExpr (DataAlt con) args inst_tys
217 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
218 mkAltExpr (LitAlt lit) [] []
221 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
222 mkIfThenElse guard then_expr else_expr
223 = Case guard (mkWildId boolTy)
224 [ (DataAlt trueDataCon, [], then_expr),
225 (DataAlt falseDataCon, [], else_expr) ]
228 %************************************************************************
230 \subsection{Figuring out things about expressions}
232 %************************************************************************
234 @exprIsTrivial@ is true of expressions we are unconditionally happy to
235 duplicate; simple variables and constants, and type
236 applications. Note that primop Ids aren't considered
239 @exprIsBottom@ is true of expressions that are guaranteed to diverge
243 exprIsTrivial (Var v)
244 | Just op <- isPrimOpId_maybe v = primOpIsDupable op
246 exprIsTrivial (Type _) = True
247 exprIsTrivial (Lit lit) = True
248 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
249 exprIsTrivial (Note _ e) = exprIsTrivial e
250 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
251 exprIsTrivial other = False
255 @exprIsDupable@ is true of expressions that can be duplicated at a modest
256 cost in code size. This will only happen in different case
257 branches, so there's no issue about duplicating work.
259 That is, exprIsDupable returns True of (f x) even if
260 f is very very expensive to call.
262 Its only purpose is to avoid fruitless let-binding
263 and then inlining of case join points
267 exprIsDupable (Type _) = True
268 exprIsDupable (Var v) = True
269 exprIsDupable (Lit lit) = litIsDupable lit
270 exprIsDupable (Note _ e) = exprIsDupable e
274 go (Var v) n_args = True
275 go (App f a) n_args = n_args < dupAppSize
278 go other n_args = False
281 dupAppSize = 4 -- Size of application we are prepared to duplicate
284 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
285 it is obviously in weak head normal form, or is cheap to get to WHNF.
286 [Note that that's not the same as exprIsDupable; an expression might be
287 big, and hence not dupable, but still cheap.]
289 By ``cheap'' we mean a computation we're willing to:
290 push inside a lambda, or
291 inline at more than one place
292 That might mean it gets evaluated more than once, instead of being
293 shared. The main examples of things which aren't WHNF but are
298 (where e, and all the ei are cheap)
301 (where e and b are cheap)
304 (where op is a cheap primitive operator)
307 (because we are happy to substitute it inside a lambda)
309 Notice that a variable is considered 'cheap': we can push it inside a lambda,
310 because sharing will make sure it is only evaluated once.
313 exprIsCheap :: CoreExpr -> Bool
314 exprIsCheap (Lit lit) = True
315 exprIsCheap (Type _) = True
316 exprIsCheap (Var _) = True
317 exprIsCheap (Note _ e) = exprIsCheap e
318 exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
319 exprIsCheap (Case e _ alts) = exprIsCheap e &&
320 and [exprIsCheap rhs | (_,_,rhs) <- alts]
321 -- Experimentally, treat (case x of ...) as cheap
322 -- (and case __coerce x etc.)
323 -- This improves arities of overloaded functions where
324 -- there is only dictionary selection (no construction) involved
325 exprIsCheap (Let (NonRec x _) e)
326 | isUnLiftedType (idType x) = exprIsCheap e
328 -- strict lets always have cheap right hand sides, and
331 exprIsCheap other_expr
332 = go other_expr 0 True
334 go (Var f) n_args args_cheap
335 = (idAppIsCheap f n_args && args_cheap)
336 -- A constructor, cheap primop, or partial application
338 || idAppIsBottom f n_args
339 -- Application of a function which
340 -- always gives bottom; we treat this as cheap
341 -- because it certainly doesn't need to be shared!
343 go (App f a) n_args args_cheap
344 | isTypeArg a = go f n_args args_cheap
345 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
347 go other n_args args_cheap = False
349 idAppIsCheap :: Id -> Int -> Bool
350 idAppIsCheap id n_val_args
351 | n_val_args == 0 = True -- Just a type application of
352 -- a variable (f t1 t2 t3)
354 | otherwise = case idFlavour id of
356 RecordSelId _ -> True -- I'm experimenting with making record selection
357 -- look cheap, so we will substitute it inside a
358 -- lambda. Particularly for dictionary field selection
360 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
361 -- that return a type variable, since the result
362 -- might be applied to something, but I'm not going
363 -- to bother to check the number of args
364 other -> n_val_args < idArity id
367 exprOkForSpeculation returns True of an expression that it is
369 * safe to evaluate even if normal order eval might not
370 evaluate the expression at all, or
372 * safe *not* to evaluate even if normal order would do so
376 the expression guarantees to terminate,
378 without raising an exception,
379 without causing a side effect (e.g. writing a mutable variable)
382 let x = case y# +# 1# of { r# -> I# r# }
385 case y# +# 1# of { r# ->
390 We can only do this if the (y+1) is ok for speculation: it has no
391 side effects, and can't diverge or raise an exception.
394 exprOkForSpeculation :: CoreExpr -> Bool
395 exprOkForSpeculation (Lit _) = True
396 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
397 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
398 exprOkForSpeculation other_expr
399 = go other_expr 0 True
401 go (Var f) n_args args_ok
402 = case idFlavour f of
403 DataConId _ -> True -- The strictness of the constructor has already
404 -- been expressed by its "wrapper", so we don't need
405 -- to take the arguments into account
407 PrimOpId op -> primOpOkForSpeculation op && args_ok
408 -- A bit conservative: we don't really need
409 -- to care about lazy arguments, but this is easy
413 go (App f a) n_args args_ok
414 | isTypeArg a = go f n_args args_ok
415 | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
417 go other n_args args_ok = False
422 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
423 exprIsBottom e = go 0 e
425 -- n is the number of args
426 go n (Note _ e) = go n e
427 go n (Let _ e) = go n e
428 go n (Case e _ _) = go 0 e -- Just check the scrut
429 go n (App e _) = go (n+1) e
430 go n (Var v) = idAppIsBottom v n
432 go n (Lam _ _) = False
434 idAppIsBottom :: Id -> Int -> Bool
435 idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
438 @exprIsValue@ returns true for expressions that are certainly *already*
439 evaluated to WHNF. This is used to decide wether it's ok to change
440 case x of _ -> e ===> e
442 and to decide whether it's safe to discard a `seq`
444 So, it does *not* treat variables as evaluated, unless they say they are
447 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
448 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
450 exprIsValue (Lit l) = True
451 exprIsValue (Lam b e) = isId b || exprIsValue e
452 exprIsValue (Note _ e) = exprIsValue e
453 exprIsValue other_expr
456 go (Var f) n_args = idAppIsValue f n_args
459 | isTypeArg a = go f n_args
460 | otherwise = go f (n_args + 1)
462 go (Note _ f) n_args = go f n_args
464 go other n_args = False
466 idAppIsValue :: Id -> Int -> Bool
467 idAppIsValue id n_val_args
468 = case idFlavour id of
470 PrimOpId _ -> n_val_args < idArity id
471 other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
472 | otherwise -> n_val_args < idArity id
473 -- A worry: what if an Id's unfolding is just itself:
474 -- then we could get an infinite loop...
478 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
479 exprIsConApp_maybe expr
480 = analyse (collectArgs expr)
482 analyse (Var fun, args)
483 | maybeToBool maybe_con_app = maybe_con_app
485 maybe_con_app = case isDataConId_maybe fun of
486 Just con | length args >= dataConRepArity con
487 -- Might be > because the arity excludes type args
491 analyse (Var fun, [])
492 = case maybeUnfoldingTemplate (idUnfolding fun) of
494 Just unf -> exprIsConApp_maybe unf
496 analyse other = Nothing
499 The arity of an expression (in the code-generator sense, i.e. the
500 number of lambdas at the beginning).
503 exprArity :: CoreExpr -> Int
505 | isTyVar x = exprArity e
506 | otherwise = 1 + exprArity e
508 -- Ignore coercions. Top level sccs are removed by the final
509 -- profiling pass, so we ignore those too.
515 %************************************************************************
517 \subsection{Eta reduction and expansion}
519 %************************************************************************
521 @etaReduce@ trys an eta reduction at the top level of a Core Expr.
523 e.g. \ x y -> f x y ===> f
525 But we only do this if it gets rid of a whole lambda, not part.
526 The idea is that lambdas are often quite helpful: they indicate
527 head normal forms, so we don't want to chuck them away lightly.
530 etaReduce :: CoreExpr -> CoreExpr
531 -- ToDo: we should really check that we don't turn a non-bottom
532 -- lambda into a bottom variable. Sigh
534 etaReduce expr@(Lam bndr body)
535 = check (reverse binders) body
537 (binders, body) = collectBinders expr
540 | not (any (`elemVarSet` body_fvs) binders)
543 body_fvs = exprFreeVars body
545 check (b : bs) (App fun arg)
546 | (varToCoreExpr b `cheapEqExpr` arg)
549 check _ _ = expr -- Bale out
551 etaReduce expr = expr -- The common case
556 exprEtaExpandArity :: CoreExpr -> (Int, Bool)
557 -- The Int is number of value args the thing can be
558 -- applied to without doing much work
559 -- The Bool is True iff there are enough explicit value lambdas
560 -- at the top to make this arity apparent
561 -- (but ignore it when arity==0)
563 -- This is used when eta expanding
564 -- e ==> \xy -> e x y
566 -- It returns 1 (or more) to:
567 -- case x of p -> \s -> ...
568 -- because for I/O ish things we really want to get that \s to the top.
569 -- We are prepared to evaluate x each time round the loop in order to get that
570 -- Hence "generous" arity
575 go ar (Lam x e) | isId x = go (ar+1) e
576 | otherwise = go ar e
577 go ar (Note n e) | ok_note n = go ar e
578 go ar other = (ar + ar', ar' == 0)
580 ar' = go1 other `max` 0
582 go1 (Var v) = idArity v
583 go1 (Lam x e) | isId x = go1 e + 1
585 go1 (Note n e) | ok_note n = go1 e
586 go1 (App f (Type _)) = go1 f
587 go1 (App f a) | exprIsCheap a = go1 f - 1
588 go1 (Case scrut _ alts)
589 | exprIsCheap scrut = min_zero [go1 rhs | (_,_,rhs) <- alts]
591 | all exprIsCheap (rhssOfBind b) = go1 e
595 ok_note (Coerce _ _) = True
596 ok_note InlineCall = True
597 ok_note other = False
598 -- Notice that we do not look through __inline_me__
599 -- This one is a bit more surprising, but consider
600 -- f = _inline_me (\x -> e)
601 -- We DO NOT want to eta expand this to
602 -- f = \x -> (_inline_me (\x -> e)) x
603 -- because the _inline_me gets dropped now it is applied,
608 min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
609 min_zero (x:xs) = go x xs
611 go 0 xs = 0 -- Nothing beats zero
613 go min (x:xs) | x < min = go x xs
614 | otherwise = go min xs
620 etaExpand :: Int -- Add this number of value args
622 -> CoreExpr -> Type -- Expression and its type
624 -- (etaExpand n us e ty) returns an expression with
625 -- the same meaning as 'e', but with arity 'n'.
627 -- Given e' = etaExpand n us e ty
629 -- ty = exprType e = exprType e'
631 -- etaExpand deals with for-alls and coerces. For example:
633 -- where E :: forall a. T
634 -- newtype T = MkT (A -> B)
637 -- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
639 -- (case x of { I# x -> /\ a -> coerce T E)
641 etaExpand n us expr ty
642 | n == 0 -- Saturated, so nothing to do
645 | otherwise -- An unsaturated constructor or primop; eta expand it
646 = case splitForAllTy_maybe ty of {
647 Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
651 case splitFunTy_maybe ty of {
652 Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
654 arg1 = mkSysLocal SLIT("eta") uniq arg_ty
655 (us1, us2) = splitUniqSupply us
656 uniq = uniqFromSupply us1
660 case splitNewType_maybe ty of {
661 Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
663 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
668 %************************************************************************
670 \subsection{Equality}
672 %************************************************************************
674 @cheapEqExpr@ is a cheap equality test which bales out fast!
675 True => definitely equal
676 False => may or may not be equal
679 cheapEqExpr :: Expr b -> Expr b -> Bool
681 cheapEqExpr (Var v1) (Var v2) = v1==v2
682 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
683 cheapEqExpr (Type t1) (Type t2) = t1 == t2
685 cheapEqExpr (App f1 a1) (App f2 a2)
686 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
688 cheapEqExpr _ _ = False
690 exprIsBig :: Expr b -> Bool
691 -- Returns True of expressions that are too big to be compared by cheapEqExpr
692 exprIsBig (Lit _) = False
693 exprIsBig (Var v) = False
694 exprIsBig (Type t) = False
695 exprIsBig (App f a) = exprIsBig f || exprIsBig a
696 exprIsBig other = True
701 eqExpr :: CoreExpr -> CoreExpr -> Bool
702 -- Works ok at more general type, but only needed at CoreExpr
704 = eq emptyVarEnv e1 e2
706 -- The "env" maps variables in e1 to variables in ty2
707 -- So when comparing lambdas etc,
708 -- we in effect substitute v2 for v1 in e1 before continuing
709 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
710 Just v1' -> v1' == v2
713 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
714 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
715 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
716 eq env (Let (NonRec v1 r1) e1)
717 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
718 eq env (Let (Rec ps1) e1)
719 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
720 and (zipWith eq_rhs ps1 ps2) &&
723 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
724 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
725 eq env (Case e1 v1 a1)
726 (Case e2 v2 a2) = eq env e1 e2 &&
727 length a1 == length a2 &&
728 and (zipWith (eq_alt env') a1 a2)
730 env' = extendVarEnv env v1 v2
732 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
733 eq env (Type t1) (Type t2) = t1 == t2
736 eq_list env [] [] = True
737 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
738 eq_list env es1 es2 = False
740 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
741 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
743 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
744 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
745 eq_note env InlineCall InlineCall = True
746 eq_note env other1 other2 = False
750 %************************************************************************
752 \subsection{The size of an expression}
754 %************************************************************************
757 coreBindsSize :: [CoreBind] -> Int
758 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
760 exprSize :: CoreExpr -> Int
761 -- A measure of the size of the expressions
762 -- It also forces the expression pretty drastically as a side effect
763 exprSize (Var v) = varSize v
764 exprSize (Lit lit) = lit `seq` 1
765 exprSize (App f a) = exprSize f + exprSize a
766 exprSize (Lam b e) = varSize b + exprSize e
767 exprSize (Let b e) = bindSize b + exprSize e
768 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
769 exprSize (Note n e) = noteSize n + exprSize e
770 exprSize (Type t) = seqType t `seq` 1
772 noteSize (SCC cc) = cc `seq` 1
773 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
774 noteSize InlineCall = 1
775 noteSize InlineMe = 1
777 varSize :: Var -> Int
778 varSize b | isTyVar b = 1
779 | otherwise = seqType (idType b) `seq`
780 megaSeqIdInfo (idInfo b) `seq`
783 varsSize = foldr ((+) . varSize) 0
785 bindSize (NonRec b e) = varSize b + exprSize e
786 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
788 pairSize (b,e) = varSize b + exprSize e
790 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
794 %************************************************************************
798 %************************************************************************
801 hashExpr :: CoreExpr -> Int
802 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
805 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
807 hash_expr (Note _ e) = hash_expr e
808 hash_expr (Let (NonRec b r) e) = hashId b
809 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
810 hash_expr (Case _ b _) = hashId b
811 hash_expr (App f e) = hash_expr f * fast_hash_expr e
812 hash_expr (Var v) = hashId v
813 hash_expr (Lit lit) = hashLiteral lit
814 hash_expr (Lam b _) = hashId b
815 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
817 fast_hash_expr (Var v) = hashId v
818 fast_hash_expr (Lit lit) = hashLiteral lit
819 fast_hash_expr (App f (Type _)) = fast_hash_expr f
820 fast_hash_expr (App f a) = fast_hash_expr a
821 fast_hash_expr (Lam b _) = hashId b
822 fast_hash_expr other = 1
825 hashId id = hashName (idName id)