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, 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
272 @exprIsDupable@ is true of expressions that can be duplicated at a modest
273 cost in code size. This will only happen in different case
274 branches, so there's no issue about duplicating work.
276 That is, exprIsDupable returns True of (f x) even if
277 f is very very expensive to call.
279 Its only purpose is to avoid fruitless let-binding
280 and then inlining of case join points
284 exprIsDupable (Type _) = True
285 exprIsDupable (Var v) = True
286 exprIsDupable (Lit lit) = litIsDupable lit
287 exprIsDupable (Note _ e) = exprIsDupable e
291 go (Var v) n_args = True
292 go (App f a) n_args = n_args < dupAppSize
295 go other n_args = False
298 dupAppSize = 4 -- Size of application we are prepared to duplicate
301 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
302 it is obviously in weak head normal form, or is cheap to get to WHNF.
303 [Note that that's not the same as exprIsDupable; an expression might be
304 big, and hence not dupable, but still cheap.]
306 By ``cheap'' we mean a computation we're willing to:
307 push inside a lambda, or
308 inline at more than one place
309 That might mean it gets evaluated more than once, instead of being
310 shared. The main examples of things which aren't WHNF but are
315 (where e, and all the ei are cheap)
318 (where e and b are cheap)
321 (where op is a cheap primitive operator)
324 (because we are happy to substitute it inside a lambda)
326 Notice that a variable is considered 'cheap': we can push it inside a lambda,
327 because sharing will make sure it is only evaluated once.
330 exprIsCheap :: CoreExpr -> Bool
331 exprIsCheap (Lit lit) = True
332 exprIsCheap (Type _) = True
333 exprIsCheap (Var _) = True
334 exprIsCheap (Note _ e) = exprIsCheap e
335 exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
336 exprIsCheap (Case e _ alts) = exprIsCheap e &&
337 and [exprIsCheap rhs | (_,_,rhs) <- alts]
338 -- Experimentally, treat (case x of ...) as cheap
339 -- (and case __coerce x etc.)
340 -- This improves arities of overloaded functions where
341 -- there is only dictionary selection (no construction) involved
342 exprIsCheap (Let (NonRec x _) e)
343 | isUnLiftedType (idType x) = exprIsCheap e
345 -- strict lets always have cheap right hand sides, and
348 exprIsCheap other_expr
349 = go other_expr 0 True
351 go (Var f) n_args args_cheap
352 = (idAppIsCheap f n_args && args_cheap)
353 -- A constructor, cheap primop, or partial application
355 || idAppIsBottom f n_args
356 -- Application of a function which
357 -- always gives bottom; we treat this as cheap
358 -- because it certainly doesn't need to be shared!
360 go (App f a) n_args args_cheap
361 | isTypeArg a = go f n_args args_cheap
362 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
364 go other n_args args_cheap = False
366 idAppIsCheap :: Id -> Int -> Bool
367 idAppIsCheap id n_val_args
368 | n_val_args == 0 = True -- Just a type application of
369 -- a variable (f t1 t2 t3)
371 | otherwise = case idFlavour id of
373 RecordSelId _ -> True -- I'm experimenting with making record selection
374 -- look cheap, so we will substitute it inside a
375 -- lambda. Particularly for dictionary field selection
377 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
378 -- that return a type variable, since the result
379 -- might be applied to something, but I'm not going
380 -- to bother to check the number of args
381 other -> n_val_args < idArity id
384 exprOkForSpeculation returns True of an expression that it is
386 * safe to evaluate even if normal order eval might not
387 evaluate the expression at all, or
389 * safe *not* to evaluate even if normal order would do so
393 the expression guarantees to terminate,
395 without raising an exception,
396 without causing a side effect (e.g. writing a mutable variable)
399 let x = case y# +# 1# of { r# -> I# r# }
402 case y# +# 1# of { r# ->
407 We can only do this if the (y+1) is ok for speculation: it has no
408 side effects, and can't diverge or raise an exception.
411 exprOkForSpeculation :: CoreExpr -> Bool
412 exprOkForSpeculation (Lit _) = True
413 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
414 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
415 exprOkForSpeculation other_expr
416 = go other_expr 0 True
418 go (Var f) n_args args_ok
419 = case idFlavour f of
420 DataConId _ -> True -- The strictness of the constructor has already
421 -- been expressed by its "wrapper", so we don't need
422 -- to take the arguments into account
424 PrimOpId op -> primOpOkForSpeculation op && args_ok
425 -- A bit conservative: we don't really need
426 -- to care about lazy arguments, but this is easy
430 go (App f a) n_args args_ok
431 | isTypeArg a = go f n_args args_ok
432 | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
434 go other n_args args_ok = False
439 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
440 exprIsBottom e = go 0 e
442 -- n is the number of args
443 go n (Note _ e) = go n e
444 go n (Let _ e) = go n e
445 go n (Case e _ _) = go 0 e -- Just check the scrut
446 go n (App e _) = go (n+1) e
447 go n (Var v) = idAppIsBottom v n
449 go n (Lam _ _) = False
451 idAppIsBottom :: Id -> Int -> Bool
452 idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
455 @exprIsValue@ returns true for expressions that are certainly *already*
456 evaluated to WHNF. This is used to decide wether it's ok to change
457 case x of _ -> e ===> e
459 and to decide whether it's safe to discard a `seq`
461 So, it does *not* treat variables as evaluated, unless they say they are
464 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
465 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
467 exprIsValue (Lit l) = True
468 exprIsValue (Lam b e) = isId b || exprIsValue e
469 exprIsValue (Note _ e) = exprIsValue e
470 exprIsValue other_expr
473 go (Var f) n_args = idAppIsValue f n_args
476 | isTypeArg a = go f n_args
477 | otherwise = go f (n_args + 1)
479 go (Note _ f) n_args = go f n_args
481 go other n_args = False
483 idAppIsValue :: Id -> Int -> Bool
484 idAppIsValue id n_val_args
485 = case idFlavour id of
487 PrimOpId _ -> n_val_args < idArity id
488 other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
489 | otherwise -> n_val_args < idArity id
490 -- A worry: what if an Id's unfolding is just itself:
491 -- then we could get an infinite loop...
495 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
496 exprIsConApp_maybe expr
497 = analyse (collectArgs expr)
499 analyse (Var fun, args)
500 | maybeToBool maybe_con_app = maybe_con_app
502 maybe_con_app = case isDataConId_maybe fun of
503 Just con | length args >= dataConRepArity con
504 -- Might be > because the arity excludes type args
508 analyse (Var fun, [])
509 = case maybeUnfoldingTemplate (idUnfolding fun) of
511 Just unf -> exprIsConApp_maybe unf
513 analyse other = Nothing
516 The arity of an expression (in the code-generator sense, i.e. the
517 number of lambdas at the beginning).
520 exprArity :: CoreExpr -> Int
522 | isTyVar x = exprArity e
523 | otherwise = 1 + exprArity e
525 -- Ignore coercions. Top level sccs are removed by the final
526 -- profiling pass, so we ignore those too.
532 %************************************************************************
534 \subsection{Eta reduction and expansion}
536 %************************************************************************
538 @etaReduce@ trys an eta reduction at the top level of a Core Expr.
540 e.g. \ x y -> f x y ===> f
542 But we only do this if it gets rid of a whole lambda, not part.
543 The idea is that lambdas are often quite helpful: they indicate
544 head normal forms, so we don't want to chuck them away lightly.
547 etaReduce :: CoreExpr -> CoreExpr
548 -- ToDo: we should really check that we don't turn a non-bottom
549 -- lambda into a bottom variable. Sigh
551 etaReduce expr@(Lam bndr body)
552 = check (reverse binders) body
554 (binders, body) = collectBinders expr
557 | not (any (`elemVarSet` body_fvs) binders)
560 body_fvs = exprFreeVars body
562 check (b : bs) (App fun arg)
563 | (varToCoreExpr b `cheapEqExpr` arg)
566 check _ _ = expr -- Bale out
568 etaReduce expr = expr -- The common case
573 exprEtaExpandArity :: CoreExpr -> (Int, Bool)
574 -- The Int is number of value args the thing can be
575 -- applied to without doing much work
576 -- The Bool is True iff there are enough explicit value lambdas
577 -- at the top to make this arity apparent
578 -- (but ignore it when arity==0)
580 -- This is used when eta expanding
581 -- e ==> \xy -> e x y
583 -- It returns 1 (or more) to:
584 -- case x of p -> \s -> ...
585 -- because for I/O ish things we really want to get that \s to the top.
586 -- We are prepared to evaluate x each time round the loop in order to get that
587 -- Hence "generous" arity
592 go ar (Lam x e) | isId x = go (ar+1) e
593 | otherwise = go ar e
594 go ar (Note n e) | ok_note n = go ar e
595 go ar other = (ar + ar', ar' == 0)
597 ar' = go1 other `max` 0
599 go1 (Var v) = idArity v
600 go1 (Lam x e) | isId x = go1 e + 1
602 go1 (Note n e) | ok_note n = go1 e
603 go1 (App f (Type _)) = go1 f
604 go1 (App f a) | exprIsCheap a = go1 f - 1
605 go1 (Case scrut _ alts)
606 | exprIsCheap scrut = min_zero [go1 rhs | (_,_,rhs) <- alts]
608 | all exprIsCheap (rhssOfBind b) = go1 e
612 ok_note (Coerce _ _) = True
613 ok_note InlineCall = True
614 ok_note other = False
615 -- Notice that we do not look through __inline_me__
616 -- This one is a bit more surprising, but consider
617 -- f = _inline_me (\x -> e)
618 -- We DO NOT want to eta expand this to
619 -- f = \x -> (_inline_me (\x -> e)) x
620 -- because the _inline_me gets dropped now it is applied,
625 min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
626 min_zero (x:xs) = go x xs
628 go 0 xs = 0 -- Nothing beats zero
630 go min (x:xs) | x < min = go x xs
631 | otherwise = go min xs
637 etaExpand :: Int -- Add this number of value args
639 -> CoreExpr -> Type -- Expression and its type
641 -- (etaExpand n us e ty) returns an expression with
642 -- the same meaning as 'e', but with arity 'n'.
644 -- Given e' = etaExpand n us e ty
646 -- ty = exprType e = exprType e'
648 -- etaExpand deals with for-alls and coerces. For example:
650 -- where E :: forall a. T
651 -- newtype T = MkT (A -> B)
654 -- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
656 -- (case x of { I# x -> /\ a -> coerce T E)
658 etaExpand n us expr ty
659 | n == 0 -- Saturated, so nothing to do
662 | otherwise -- An unsaturated constructor or primop; eta expand it
663 = case splitForAllTy_maybe ty of {
664 Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
668 case splitFunTy_maybe ty of {
669 Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
671 arg1 = mkSysLocal SLIT("eta") uniq arg_ty
672 (us1, us2) = splitUniqSupply us
673 uniq = uniqFromSupply us1
677 case splitNewType_maybe ty of {
678 Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
680 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
685 %************************************************************************
687 \subsection{Equality}
689 %************************************************************************
691 @cheapEqExpr@ is a cheap equality test which bales out fast!
692 True => definitely equal
693 False => may or may not be equal
696 cheapEqExpr :: Expr b -> Expr b -> Bool
698 cheapEqExpr (Var v1) (Var v2) = v1==v2
699 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
700 cheapEqExpr (Type t1) (Type t2) = t1 == t2
702 cheapEqExpr (App f1 a1) (App f2 a2)
703 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
705 cheapEqExpr _ _ = False
707 exprIsBig :: Expr b -> Bool
708 -- Returns True of expressions that are too big to be compared by cheapEqExpr
709 exprIsBig (Lit _) = False
710 exprIsBig (Var v) = False
711 exprIsBig (Type t) = False
712 exprIsBig (App f a) = exprIsBig f || exprIsBig a
713 exprIsBig other = True
718 eqExpr :: CoreExpr -> CoreExpr -> Bool
719 -- Works ok at more general type, but only needed at CoreExpr
721 = eq emptyVarEnv e1 e2
723 -- The "env" maps variables in e1 to variables in ty2
724 -- So when comparing lambdas etc,
725 -- we in effect substitute v2 for v1 in e1 before continuing
726 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
727 Just v1' -> v1' == v2
730 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
731 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
732 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
733 eq env (Let (NonRec v1 r1) e1)
734 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
735 eq env (Let (Rec ps1) e1)
736 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
737 and (zipWith eq_rhs ps1 ps2) &&
740 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
741 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
742 eq env (Case e1 v1 a1)
743 (Case e2 v2 a2) = eq env e1 e2 &&
744 length a1 == length a2 &&
745 and (zipWith (eq_alt env') a1 a2)
747 env' = extendVarEnv env v1 v2
749 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
750 eq env (Type t1) (Type t2) = t1 == t2
753 eq_list env [] [] = True
754 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
755 eq_list env es1 es2 = False
757 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
758 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
760 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
761 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
762 eq_note env InlineCall InlineCall = True
763 eq_note env other1 other2 = False
767 %************************************************************************
769 \subsection{The size of an expression}
771 %************************************************************************
774 coreBindsSize :: [CoreBind] -> Int
775 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
777 exprSize :: CoreExpr -> Int
778 -- A measure of the size of the expressions
779 -- It also forces the expression pretty drastically as a side effect
780 exprSize (Var v) = varSize v
781 exprSize (Lit lit) = lit `seq` 1
782 exprSize (App f a) = exprSize f + exprSize a
783 exprSize (Lam b e) = varSize b + exprSize e
784 exprSize (Let b e) = bindSize b + exprSize e
785 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
786 exprSize (Note n e) = noteSize n + exprSize e
787 exprSize (Type t) = seqType t `seq` 1
789 noteSize (SCC cc) = cc `seq` 1
790 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
791 noteSize InlineCall = 1
792 noteSize InlineMe = 1
794 varSize :: Var -> Int
795 varSize b | isTyVar b = 1
796 | otherwise = seqType (idType b) `seq`
797 megaSeqIdInfo (idInfo b) `seq`
800 varsSize = foldr ((+) . varSize) 0
802 bindSize (NonRec b e) = varSize b + exprSize e
803 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
805 pairSize (b,e) = varSize b + exprSize e
807 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
811 %************************************************************************
815 %************************************************************************
818 hashExpr :: CoreExpr -> Int
819 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
822 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
824 hash_expr (Note _ e) = hash_expr e
825 hash_expr (Let (NonRec b r) e) = hashId b
826 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
827 hash_expr (Case _ b _) = hashId b
828 hash_expr (App f e) = hash_expr f * fast_hash_expr e
829 hash_expr (Var v) = hashId v
830 hash_expr (Lit lit) = hashLiteral lit
831 hash_expr (Lam b _) = hashId b
832 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
834 fast_hash_expr (Var v) = hashId v
835 fast_hash_expr (Lit lit) = hashLiteral lit
836 fast_hash_expr (App f (Type _)) = fast_hash_expr f
837 fast_hash_expr (App f a) = fast_hash_expr a
838 fast_hash_expr (Lam b _) = hashId b
839 fast_hash_expr other = 1
842 hashId id = hashName (idName id)