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,
17 exprIsConApp_maybe, exprIsAtom,
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, litSize, 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.
159 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
162 f = inline_me (coerce t fw)
163 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
164 We want the split, so that the coerces can cancel at the call site.
166 However, we can get left with tiresome type applications. Notably, consider
167 f = /\ a -> let t = e in (t, w)
168 Then lifting the let out of the big lambda gives
170 f = /\ a -> let t = inline_me (t' a) in (t, w)
171 The inline_me is to stop the simplifier inlining t' right back
172 into t's RHS. In the next phase we'll substitute for t (since
173 its rhs is trivial) and *then* we could get rid of the inline_me.
174 But it hardly seems worth it, so I don't bother.
177 mkInlineMe (Var v) = Var v
178 mkInlineMe e = Note InlineMe e
184 mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
186 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
187 = ASSERT( from_ty == to_ty2 )
188 mkCoerce to_ty from_ty2 expr
190 mkCoerce to_ty from_ty expr
191 | to_ty == from_ty = expr
192 | otherwise = ASSERT( from_ty == exprType expr )
193 Note (Coerce to_ty from_ty) expr
197 mkSCC :: CostCentre -> Expr b -> Expr b
198 -- Note: Nested SCC's *are* preserved for the benefit of
199 -- cost centre stack profiling (Durham)
201 mkSCC cc (Lit lit) = Lit lit
202 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
203 mkSCC cc expr = Note (SCC cc) expr
207 %************************************************************************
209 \subsection{Other expression construction}
211 %************************************************************************
214 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
215 -- (bindNonRec x r b) produces either
218 -- case r of x { _DEFAULT_ -> b }
220 -- depending on whether x is unlifted or not
221 -- It's used by the desugarer to avoid building bindings
222 -- that give Core Lint a heart attack. Actually the simplifier
223 -- deals with them perfectly well.
224 bindNonRec bndr rhs body
225 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
226 | otherwise = Let (NonRec bndr rhs) body
230 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
231 -- This guy constructs the value that the scrutinee must have
232 -- when you are in one particular branch of a case
233 mkAltExpr (DataAlt con) args inst_tys
234 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
235 mkAltExpr (LitAlt lit) [] []
238 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
239 mkIfThenElse guard then_expr else_expr
240 = Case guard (mkWildId boolTy)
241 [ (DataAlt trueDataCon, [], then_expr),
242 (DataAlt falseDataCon, [], else_expr) ]
245 %************************************************************************
247 \subsection{Figuring out things about expressions}
249 %************************************************************************
251 @exprIsTrivial@ is true of expressions we are unconditionally happy to
252 duplicate; simple variables and constants, and type
253 applications. Note that primop Ids aren't considered
256 @exprIsBottom@ is true of expressions that are guaranteed to diverge
260 exprIsTrivial (Var v)
261 | Just op <- isPrimOpId_maybe v = primOpIsDupable op
263 exprIsTrivial (Type _) = True
264 exprIsTrivial (Lit lit) = True
265 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
266 exprIsTrivial (Note _ e) = exprIsTrivial e
267 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
268 exprIsTrivial other = False
270 exprIsAtom :: CoreExpr -> Bool
271 -- Used to decide whether to let-binding an STG argument
272 -- when compiling to ILX => type applications are not allowed
273 exprIsAtom (Var v) = True -- primOpIsDupable?
274 exprIsAtom (Lit lit) = True
275 exprIsAtom (Type ty) = True
276 exprIsAtom (Note _ e) = exprIsAtom e
277 exprIsAtom other = False
281 @exprIsDupable@ is true of expressions that can be duplicated at a modest
282 cost in code size. This will only happen in different case
283 branches, so there's no issue about duplicating work.
285 That is, exprIsDupable returns True of (f x) even if
286 f is very very expensive to call.
288 Its only purpose is to avoid fruitless let-binding
289 and then inlining of case join points
293 exprIsDupable (Type _) = True
294 exprIsDupable (Var v) = True
295 exprIsDupable (Lit lit) = litIsDupable lit
296 exprIsDupable (Note _ e) = exprIsDupable e
300 go (Var v) n_args = True
301 go (App f a) n_args = n_args < dupAppSize
304 go other n_args = False
307 dupAppSize = 4 -- Size of application we are prepared to duplicate
310 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
311 it is obviously in weak head normal form, or is cheap to get to WHNF.
312 [Note that that's not the same as exprIsDupable; an expression might be
313 big, and hence not dupable, but still cheap.]
315 By ``cheap'' we mean a computation we're willing to:
316 push inside a lambda, or
317 inline at more than one place
318 That might mean it gets evaluated more than once, instead of being
319 shared. The main examples of things which aren't WHNF but are
324 (where e, and all the ei are cheap)
327 (where e and b are cheap)
330 (where op is a cheap primitive operator)
333 (because we are happy to substitute it inside a lambda)
335 Notice that a variable is considered 'cheap': we can push it inside a lambda,
336 because sharing will make sure it is only evaluated once.
339 exprIsCheap :: CoreExpr -> Bool
340 exprIsCheap (Lit lit) = True
341 exprIsCheap (Type _) = True
342 exprIsCheap (Var _) = True
343 exprIsCheap (Note _ e) = exprIsCheap e
344 exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
345 exprIsCheap (Case e _ alts) = exprIsCheap e &&
346 and [exprIsCheap rhs | (_,_,rhs) <- alts]
347 -- Experimentally, treat (case x of ...) as cheap
348 -- (and case __coerce x etc.)
349 -- This improves arities of overloaded functions where
350 -- there is only dictionary selection (no construction) involved
351 exprIsCheap (Let (NonRec x _) e)
352 | isUnLiftedType (idType x) = exprIsCheap e
354 -- strict lets always have cheap right hand sides, and
357 exprIsCheap other_expr
358 = go other_expr 0 True
360 go (Var f) n_args args_cheap
361 = (idAppIsCheap f n_args && args_cheap)
362 -- A constructor, cheap primop, or partial application
364 || idAppIsBottom f n_args
365 -- Application of a function which
366 -- always gives bottom; we treat this as cheap
367 -- because it certainly doesn't need to be shared!
369 go (App f a) n_args args_cheap
370 | isTypeArg a = go f n_args args_cheap
371 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
373 go other n_args args_cheap = False
375 idAppIsCheap :: Id -> Int -> Bool
376 idAppIsCheap id n_val_args
377 | n_val_args == 0 = True -- Just a type application of
378 -- a variable (f t1 t2 t3)
380 | otherwise = case idFlavour id of
382 RecordSelId _ -> True -- I'm experimenting with making record selection
383 -- look cheap, so we will substitute it inside a
384 -- lambda. Particularly for dictionary field selection
386 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
387 -- that return a type variable, since the result
388 -- might be applied to something, but I'm not going
389 -- to bother to check the number of args
390 other -> n_val_args < idArity id
393 exprOkForSpeculation returns True of an expression that it is
395 * safe to evaluate even if normal order eval might not
396 evaluate the expression at all, or
398 * safe *not* to evaluate even if normal order would do so
402 the expression guarantees to terminate,
404 without raising an exception,
405 without causing a side effect (e.g. writing a mutable variable)
408 let x = case y# +# 1# of { r# -> I# r# }
411 case y# +# 1# of { r# ->
416 We can only do this if the (y+1) is ok for speculation: it has no
417 side effects, and can't diverge or raise an exception.
420 exprOkForSpeculation :: CoreExpr -> Bool
421 exprOkForSpeculation (Lit _) = True
422 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
423 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
424 exprOkForSpeculation other_expr
425 = go other_expr 0 True
427 go (Var f) n_args args_ok
428 = case idFlavour f of
429 DataConId _ -> True -- The strictness of the constructor has already
430 -- been expressed by its "wrapper", so we don't need
431 -- to take the arguments into account
433 PrimOpId op -> primOpOkForSpeculation op && args_ok
434 -- A bit conservative: we don't really need
435 -- to care about lazy arguments, but this is easy
439 go (App f a) n_args args_ok
440 | isTypeArg a = go f n_args args_ok
441 | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
443 go other n_args args_ok = False
448 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
449 exprIsBottom e = go 0 e
451 -- n is the number of args
452 go n (Note _ e) = go n e
453 go n (Let _ e) = go n e
454 go n (Case e _ _) = go 0 e -- Just check the scrut
455 go n (App e _) = go (n+1) e
456 go n (Var v) = idAppIsBottom v n
458 go n (Lam _ _) = False
460 idAppIsBottom :: Id -> Int -> Bool
461 idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
464 @exprIsValue@ returns true for expressions that are certainly *already*
465 evaluated to WHNF. This is used to decide wether it's ok to change
466 case x of _ -> e ===> e
468 and to decide whether it's safe to discard a `seq`
470 So, it does *not* treat variables as evaluated, unless they say they are
473 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
474 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
476 exprIsValue (Lit l) = True
477 exprIsValue (Lam b e) = isId b || exprIsValue e
478 exprIsValue (Note _ e) = exprIsValue e
479 exprIsValue other_expr
482 go (Var f) n_args = idAppIsValue f n_args
485 | isTypeArg a = go f n_args
486 | otherwise = go f (n_args + 1)
488 go (Note _ f) n_args = go f n_args
490 go other n_args = False
492 idAppIsValue :: Id -> Int -> Bool
493 idAppIsValue id n_val_args
494 = case idFlavour id of
496 PrimOpId _ -> n_val_args < idArity id
497 other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
498 | otherwise -> n_val_args < idArity id
499 -- A worry: what if an Id's unfolding is just itself:
500 -- then we could get an infinite loop...
504 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
505 exprIsConApp_maybe expr
506 = analyse (collectArgs expr)
508 analyse (Var fun, args)
509 | maybeToBool maybe_con_app = maybe_con_app
511 maybe_con_app = case isDataConId_maybe fun of
512 Just con | length args >= dataConRepArity con
513 -- Might be > because the arity excludes type args
517 analyse (Var fun, [])
518 = case maybeUnfoldingTemplate (idUnfolding fun) of
520 Just unf -> exprIsConApp_maybe unf
522 analyse other = Nothing
525 The arity of an expression (in the code-generator sense, i.e. the
526 number of lambdas at the beginning).
529 exprArity :: CoreExpr -> Int
531 | isTyVar x = exprArity e
532 | otherwise = 1 + exprArity e
534 -- Ignore coercions. Top level sccs are removed by the final
535 -- profiling pass, so we ignore those too.
541 %************************************************************************
543 \subsection{Eta reduction and expansion}
545 %************************************************************************
547 @etaReduce@ trys an eta reduction at the top level of a Core Expr.
549 e.g. \ x y -> f x y ===> f
551 But we only do this if it gets rid of a whole lambda, not part.
552 The idea is that lambdas are often quite helpful: they indicate
553 head normal forms, so we don't want to chuck them away lightly.
556 etaReduce :: CoreExpr -> CoreExpr
557 -- ToDo: we should really check that we don't turn a non-bottom
558 -- lambda into a bottom variable. Sigh
560 etaReduce expr@(Lam bndr body)
561 = check (reverse binders) body
563 (binders, body) = collectBinders expr
566 | not (any (`elemVarSet` body_fvs) binders)
569 body_fvs = exprFreeVars body
571 check (b : bs) (App fun arg)
572 | (varToCoreExpr b `cheapEqExpr` arg)
575 check _ _ = expr -- Bale out
577 etaReduce expr = expr -- The common case
582 exprEtaExpandArity :: CoreExpr -> (Int, Bool)
583 -- The Int is number of value args the thing can be
584 -- applied to without doing much work
585 -- The Bool is True iff there are enough explicit value lambdas
586 -- at the top to make this arity apparent
587 -- (but ignore it when arity==0)
589 -- This is used when eta expanding
590 -- e ==> \xy -> e x y
592 -- It returns 1 (or more) to:
593 -- case x of p -> \s -> ...
594 -- because for I/O ish things we really want to get that \s to the top.
595 -- We are prepared to evaluate x each time round the loop in order to get that
596 -- Hence "generous" arity
601 go ar (Lam x e) | isId x = go (ar+1) e
602 | otherwise = go ar e
603 go ar (Note n e) | ok_note n = go ar e
604 go ar other = (ar + ar', ar' == 0)
606 ar' = go1 other `max` 0
608 go1 (Var v) = idArity v
609 go1 (Lam x e) | isId x = go1 e + 1
611 go1 (Note n e) | ok_note n = go1 e
612 go1 (App f (Type _)) = go1 f
613 go1 (App f a) | exprIsCheap a = go1 f - 1
614 go1 (Case scrut _ alts)
615 | exprIsCheap scrut = min_zero [go1 rhs | (_,_,rhs) <- alts]
617 | all exprIsCheap (rhssOfBind b) = go1 e
621 ok_note (Coerce _ _) = True
622 ok_note InlineCall = True
623 ok_note other = False
624 -- Notice that we do not look through __inline_me__
625 -- This one is a bit more surprising, but consider
626 -- f = _inline_me (\x -> e)
627 -- We DO NOT want to eta expand this to
628 -- f = \x -> (_inline_me (\x -> e)) x
629 -- because the _inline_me gets dropped now it is applied,
634 min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
635 min_zero (x:xs) = go x xs
637 go 0 xs = 0 -- Nothing beats zero
639 go min (x:xs) | x < min = go x xs
640 | otherwise = go min xs
646 etaExpand :: Int -- Add this number of value args
648 -> CoreExpr -> Type -- Expression and its type
650 -- (etaExpand n us e ty) returns an expression with
651 -- the same meaning as 'e', but with arity 'n'.
653 -- Given e' = etaExpand n us e ty
655 -- ty = exprType e = exprType e'
657 -- etaExpand deals with for-alls and coerces. For example:
659 -- where E :: forall a. T
660 -- newtype T = MkT (A -> B)
663 -- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
665 -- (case x of { I# x -> /\ a -> coerce T E)
667 etaExpand n us expr ty
668 | n == 0 -- Saturated, so nothing to do
671 | otherwise -- An unsaturated constructor or primop; eta expand it
672 = case splitForAllTy_maybe ty of {
673 Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
677 case splitFunTy_maybe ty of {
678 Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
680 arg1 = mkSysLocal SLIT("eta") uniq arg_ty
681 (us1, us2) = splitUniqSupply us
682 uniq = uniqFromSupply us1
686 case splitNewType_maybe ty of {
687 Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
689 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
694 %************************************************************************
696 \subsection{Equality}
698 %************************************************************************
700 @cheapEqExpr@ is a cheap equality test which bales out fast!
701 True => definitely equal
702 False => may or may not be equal
705 cheapEqExpr :: Expr b -> Expr b -> Bool
707 cheapEqExpr (Var v1) (Var v2) = v1==v2
708 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
709 cheapEqExpr (Type t1) (Type t2) = t1 == t2
711 cheapEqExpr (App f1 a1) (App f2 a2)
712 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
714 cheapEqExpr _ _ = False
716 exprIsBig :: Expr b -> Bool
717 -- Returns True of expressions that are too big to be compared by cheapEqExpr
718 exprIsBig (Lit _) = False
719 exprIsBig (Var v) = False
720 exprIsBig (Type t) = False
721 exprIsBig (App f a) = exprIsBig f || exprIsBig a
722 exprIsBig other = True
727 eqExpr :: CoreExpr -> CoreExpr -> Bool
728 -- Works ok at more general type, but only needed at CoreExpr
730 = eq emptyVarEnv e1 e2
732 -- The "env" maps variables in e1 to variables in ty2
733 -- So when comparing lambdas etc,
734 -- we in effect substitute v2 for v1 in e1 before continuing
735 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
736 Just v1' -> v1' == v2
739 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
740 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
741 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
742 eq env (Let (NonRec v1 r1) e1)
743 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
744 eq env (Let (Rec ps1) e1)
745 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
746 and (zipWith eq_rhs ps1 ps2) &&
749 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
750 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
751 eq env (Case e1 v1 a1)
752 (Case e2 v2 a2) = eq env e1 e2 &&
753 length a1 == length a2 &&
754 and (zipWith (eq_alt env') a1 a2)
756 env' = extendVarEnv env v1 v2
758 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
759 eq env (Type t1) (Type t2) = t1 == t2
762 eq_list env [] [] = True
763 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
764 eq_list env es1 es2 = False
766 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
767 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
769 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
770 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
771 eq_note env InlineCall InlineCall = True
772 eq_note env other1 other2 = False
776 %************************************************************************
778 \subsection{The size of an expression}
780 %************************************************************************
783 coreBindsSize :: [CoreBind] -> Int
784 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
786 exprSize :: CoreExpr -> Int
787 -- A measure of the size of the expressions
788 -- It also forces the expression pretty drastically as a side effect
789 exprSize (Var v) = varSize v
790 exprSize (Lit lit) = lit `seq` 1
791 exprSize (App f a) = exprSize f + exprSize a
792 exprSize (Lam b e) = varSize b + exprSize e
793 exprSize (Let b e) = bindSize b + exprSize e
794 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
795 exprSize (Note n e) = noteSize n + exprSize e
796 exprSize (Type t) = seqType t `seq` 1
798 noteSize (SCC cc) = cc `seq` 1
799 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
800 noteSize InlineCall = 1
801 noteSize InlineMe = 1
803 varSize :: Var -> Int
804 varSize b | isTyVar b = 1
805 | otherwise = seqType (idType b) `seq`
806 megaSeqIdInfo (idInfo b) `seq`
809 varsSize = foldr ((+) . varSize) 0
811 bindSize (NonRec b e) = varSize b + exprSize e
812 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
814 pairSize (b,e) = varSize b + exprSize e
816 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
820 %************************************************************************
824 %************************************************************************
827 hashExpr :: CoreExpr -> Int
828 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
831 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
833 hash_expr (Note _ e) = hash_expr e
834 hash_expr (Let (NonRec b r) e) = hashId b
835 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
836 hash_expr (Case _ b _) = hashId b
837 hash_expr (App f e) = hash_expr f * fast_hash_expr e
838 hash_expr (Var v) = hashId v
839 hash_expr (Lit lit) = hashLiteral lit
840 hash_expr (Lam b _) = hashId b
841 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
843 fast_hash_expr (Var v) = hashId v
844 fast_hash_expr (Lit lit) = hashLiteral lit
845 fast_hash_expr (App f (Type _)) = fast_hash_expr f
846 fast_hash_expr (App f a) = fast_hash_expr a
847 fast_hash_expr (Lam b _) = hashId b
848 fast_hash_expr other = 1
851 hashId id = hashName (idName id)