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 )
53 import Id ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo,
54 mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
55 isDataConId_maybe, mkSysLocal, hasNoBinding
57 import IdInfo ( LBVarInfo(..),
60 import Demand ( appIsBottom )
61 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
62 applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
63 splitForAllTy_maybe, splitNewType_maybe, isForAllTy
65 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
66 import CostCentre ( CostCentre )
67 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
69 import TysPrim ( alphaTy ) -- Debugging only
73 %************************************************************************
75 \subsection{Find the type of a Core atom/expression}
77 %************************************************************************
80 exprType :: CoreExpr -> Type
82 exprType (Var var) = idType var
83 exprType (Lit lit) = literalType lit
84 exprType (Let _ body) = exprType body
85 exprType (Case _ _ alts) = coreAltsType alts
86 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
87 exprType (Note other_note e) = exprType e
88 exprType (Lam binder expr) = mkPiType binder (exprType expr)
90 = case collectArgs e of
91 (fun, args) -> applyTypeToArgs e (exprType fun) args
93 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
95 coreAltsType :: [CoreAlt] -> Type
96 coreAltsType ((_,_,rhs) : _) = exprType rhs
99 @mkPiType@ makes a (->) type or a forall type, depending on whether
100 it is given a type variable or a term variable. We cleverly use the
101 lbvarinfo field to figure out the right annotation for the arrove in
102 case of a term variable.
105 mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work...
106 mkPiType v ty | isId v = (case idLBVarInfo v of
107 LBVarInfo u -> mkUTy u
109 mkFunTy (idType v) ty
110 | isTyVar v = mkForAllTy v ty
114 -- The first argument is just for debugging
115 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
116 applyTypeToArgs e op_ty [] = op_ty
118 applyTypeToArgs e op_ty (Type ty : args)
119 = -- Accumulate type arguments so we can instantiate all at once
120 applyTypeToArgs e (applyTys op_ty tys) rest_args
122 (tys, rest_args) = go [ty] args
123 go tys (Type ty : args) = go (ty:tys) args
124 go tys rest_args = (reverse tys, rest_args)
126 applyTypeToArgs e op_ty (other_arg : args)
127 = case (splitFunTy_maybe op_ty) of
128 Just (_, res_ty) -> applyTypeToArgs e res_ty args
129 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
134 %************************************************************************
136 \subsection{Attaching notes}
138 %************************************************************************
140 mkNote removes redundant coercions, and SCCs where possible
143 mkNote :: Note -> CoreExpr -> CoreExpr
144 mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr
145 mkNote (SCC cc) expr = mkSCC cc expr
146 mkNote InlineMe expr = mkInlineMe expr
147 mkNote note expr = Note note expr
149 -- Slide InlineCall in around the function
150 -- No longer necessary I think (SLPJ Apr 99)
151 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
152 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
153 -- mkNote InlineCall expr = expr
156 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
157 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
158 not be *applied* to anything.
160 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
163 f = inline_me (coerce t fw)
164 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
165 We want the split, so that the coerces can cancel at the call site.
167 However, we can get left with tiresome type applications. Notably, consider
168 f = /\ a -> let t = e in (t, w)
169 Then lifting the let out of the big lambda gives
171 f = /\ a -> let t = inline_me (t' a) in (t, w)
172 The inline_me is to stop the simplifier inlining t' right back
173 into t's RHS. In the next phase we'll substitute for t (since
174 its rhs is trivial) and *then* we could get rid of the inline_me.
175 But it hardly seems worth it, so I don't bother.
178 mkInlineMe (Var v) = Var v
179 mkInlineMe e = Note InlineMe e
185 mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
187 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
188 = ASSERT( from_ty == to_ty2 )
189 mkCoerce to_ty from_ty2 expr
191 mkCoerce to_ty from_ty expr
192 | to_ty == from_ty = expr
193 | otherwise = ASSERT( from_ty == exprType expr )
194 Note (Coerce to_ty from_ty) expr
198 mkSCC :: CostCentre -> Expr b -> Expr b
199 -- Note: Nested SCC's *are* preserved for the benefit of
200 -- cost centre stack profiling
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 (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
204 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
205 mkSCC cc expr = Note (SCC cc) expr
209 %************************************************************************
211 \subsection{Other expression construction}
213 %************************************************************************
216 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
217 -- (bindNonRec x r b) produces either
220 -- case r of x { _DEFAULT_ -> b }
222 -- depending on whether x is unlifted or not
223 -- It's used by the desugarer to avoid building bindings
224 -- that give Core Lint a heart attack. Actually the simplifier
225 -- deals with them perfectly well.
226 bindNonRec bndr rhs body
227 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
228 | otherwise = Let (NonRec bndr rhs) body
232 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
233 -- This guy constructs the value that the scrutinee must have
234 -- when you are in one particular branch of a case
235 mkAltExpr (DataAlt con) args inst_tys
236 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
237 mkAltExpr (LitAlt lit) [] []
240 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
241 mkIfThenElse guard then_expr else_expr
242 = Case guard (mkWildId boolTy)
243 [ (DataAlt trueDataCon, [], then_expr),
244 (DataAlt falseDataCon, [], else_expr) ]
248 %************************************************************************
250 \subsection{Taking expressions apart}
252 %************************************************************************
256 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
257 findDefault [] = ([], Nothing)
258 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
260 findDefault (alt : alts) = case findDefault alts of
261 (alts', deflt) -> (alt : alts', deflt)
263 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
267 go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
268 go (alt : alts) | matches alt = alt
269 | otherwise = go alts
271 matches (DEFAULT, _, _) = True
272 matches (con1, _, _) = con == con1
276 %************************************************************************
278 \subsection{Figuring out things about expressions}
280 %************************************************************************
282 @exprIsTrivial@ is true of expressions we are unconditionally happy to
283 duplicate; simple variables and constants, and type
284 applications. Note that primop Ids aren't considered
287 @exprIsBottom@ is true of expressions that are guaranteed to diverge
291 exprIsTrivial (Var v)
292 | hasNoBinding v = idArity v == 0
293 -- WAS: | Just op <- isPrimOpId_maybe v = primOpIsDupable op
294 -- The idea here is that a constructor worker, like $wJust, is
295 -- really short for (\x -> $wJust x), becuase $wJust has no binding.
296 -- So it should be treated like a lambda.
297 -- Ditto unsaturated primops.
298 -- This came up when dealing with eta expansion/reduction for
300 -- Here we want to eta-expand. This looks like an optimisation,
301 -- but it's important (albeit tiresome) that CoreSat doesn't increase
304 exprIsTrivial (Type _) = True
305 exprIsTrivial (Lit lit) = True
306 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
307 exprIsTrivial (Note _ e) = exprIsTrivial e
308 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
309 exprIsTrivial other = False
311 exprIsAtom :: CoreExpr -> Bool
312 -- Used to decide whether to let-binding an STG argument
313 -- when compiling to ILX => type applications are not allowed
314 exprIsAtom (Var v) = True -- primOpIsDupable?
315 exprIsAtom (Lit lit) = True
316 exprIsAtom (Type ty) = True
317 exprIsAtom (Note (SCC _) e) = False
318 exprIsAtom (Note _ e) = exprIsAtom e
319 exprIsAtom other = False
323 @exprIsDupable@ is true of expressions that can be duplicated at a modest
324 cost in code size. This will only happen in different case
325 branches, so there's no issue about duplicating work.
327 That is, exprIsDupable returns True of (f x) even if
328 f is very very expensive to call.
330 Its only purpose is to avoid fruitless let-binding
331 and then inlining of case join points
335 exprIsDupable (Type _) = True
336 exprIsDupable (Var v) = True
337 exprIsDupable (Lit lit) = litIsDupable lit
338 exprIsDupable (Note InlineMe e) = True
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 InlineMe e) = True
387 exprIsCheap (Note _ e) = exprIsCheap e
388 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
389 exprIsCheap (Case e _ alts) = exprIsCheap e &&
390 and [exprIsCheap rhs | (_,_,rhs) <- alts]
391 -- Experimentally, treat (case x of ...) as cheap
392 -- (and case __coerce x etc.)
393 -- This improves arities of overloaded functions where
394 -- there is only dictionary selection (no construction) involved
395 exprIsCheap (Let (NonRec x _) e)
396 | isUnLiftedType (idType x) = exprIsCheap e
398 -- strict lets always have cheap right hand sides, and
401 exprIsCheap other_expr
402 = go other_expr 0 True
404 go (Var f) n_args args_cheap
405 = (idAppIsCheap f n_args && args_cheap)
406 -- A constructor, cheap primop, or partial application
408 || idAppIsBottom f n_args
409 -- Application of a function which
410 -- always gives bottom; we treat this as cheap
411 -- because it certainly doesn't need to be shared!
413 go (App f a) n_args args_cheap
414 | not (isRuntimeArg a) = go f n_args args_cheap
415 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
417 go other n_args args_cheap = False
419 idAppIsCheap :: Id -> Int -> Bool
420 idAppIsCheap id n_val_args
421 | n_val_args == 0 = True -- Just a type application of
422 -- a variable (f t1 t2 t3)
424 | otherwise = case globalIdDetails id of
426 RecordSelId _ -> True -- I'm experimenting with making record selection
427 -- look cheap, so we will substitute it inside a
428 -- lambda. Particularly for dictionary field selection
430 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
431 -- that return a type variable, since the result
432 -- might be applied to something, but I'm not going
433 -- to bother to check the number of args
434 other -> n_val_args < idArity id
437 exprOkForSpeculation returns True of an expression that it is
439 * safe to evaluate even if normal order eval might not
440 evaluate the expression at all, or
442 * safe *not* to evaluate even if normal order would do so
446 the expression guarantees to terminate,
448 without raising an exception,
449 without causing a side effect (e.g. writing a mutable variable)
452 let x = case y# +# 1# of { r# -> I# r# }
455 case y# +# 1# of { r# ->
460 We can only do this if the (y+1) is ok for speculation: it has no
461 side effects, and can't diverge or raise an exception.
464 exprOkForSpeculation :: CoreExpr -> Bool
465 exprOkForSpeculation (Lit _) = True
466 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
467 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
468 exprOkForSpeculation other_expr
469 = go other_expr 0 True
471 go (Var f) n_args args_ok
472 = case globalIdDetails f of
473 DataConId _ -> True -- The strictness of the constructor has already
474 -- been expressed by its "wrapper", so we don't need
475 -- to take the arguments into account
477 PrimOpId op -> primOpOkForSpeculation op && args_ok
478 -- A bit conservative: we don't really need
479 -- to care about lazy arguments, but this is easy
483 go (App f a) n_args args_ok
484 | not (isRuntimeArg a) = go f n_args args_ok
485 | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
487 go other n_args args_ok = False
492 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
493 exprIsBottom e = go 0 e
495 -- n is the number of args
496 go n (Note _ e) = go n e
497 go n (Let _ e) = go n e
498 go n (Case e _ _) = go 0 e -- Just check the scrut
499 go n (App e _) = go (n+1) e
500 go n (Var v) = idAppIsBottom v n
502 go n (Lam _ _) = False
504 idAppIsBottom :: Id -> Int -> Bool
505 idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
508 @exprIsValue@ returns true for expressions that are certainly *already*
509 evaluated to WHNF. This is used to decide wether it's ok to change
510 case x of _ -> e ===> e
512 and to decide whether it's safe to discard a `seq`
514 So, it does *not* treat variables as evaluated, unless they say they are.
516 But it *does* treat partial applications and constructor applications
517 as values, even if their arguments are non-trivial;
518 e.g. (:) (f x) (map f xs) is a value
519 map (...redex...) is a value
520 Because `seq` on such things completes immediately
522 A possible worry: constructors with unboxed args:
524 Suppose (f x) diverges; then C (f x) is not a value. True, but
525 this form is illegal (see the invariants in CoreSyn). Args of unboxed
526 type must be ok-for-speculation (or trivial).
529 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
530 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
532 exprIsValue (Lit l) = True
533 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
534 exprIsValue (Note _ e) = exprIsValue e
535 exprIsValue other_expr
538 go (Var f) n_args = idAppIsValue f n_args
541 | not (isRuntimeArg a) = go f n_args
542 | otherwise = go f (n_args + 1)
544 go (Note _ f) n_args = go f n_args
546 go other n_args = False
548 idAppIsValue :: Id -> Int -> Bool
549 idAppIsValue id n_val_args
550 = case globalIdDetails id of
552 PrimOpId _ -> n_val_args < idArity id
553 other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
554 | otherwise -> n_val_args < idArity id
555 -- A worry: what if an Id's unfolding is just itself:
556 -- then we could get an infinite loop...
560 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
561 exprIsConApp_maybe (Note InlineMe expr) = exprIsConApp_maybe expr
562 -- We ignore InlineMe notes in case we have
563 -- x = __inline_me__ (a,b)
564 -- All part of making sure that INLINE pragmas never hurt
565 -- Marcin tripped on this one when making dictionaries more inlinable
567 exprIsConApp_maybe expr = analyse (collectArgs expr)
569 analyse (Var fun, args)
570 | Just con <- isDataConId_maybe fun,
571 length args >= dataConRepArity con
572 -- Might be > because the arity excludes type args
575 -- Look through unfoldings, but only cheap ones, because
576 -- we are effectively duplicating the unfolding
577 analyse (Var fun, [])
578 | let unf = idUnfolding fun,
580 = exprIsConApp_maybe (unfoldingTemplate unf)
582 analyse other = Nothing
587 %************************************************************************
589 \subsection{Eta reduction and expansion}
591 %************************************************************************
593 @etaReduce@ trys an eta reduction at the top level of a Core Expr.
595 e.g. \ x y -> f x y ===> f
597 But we only do this if it gets rid of a whole lambda, not part.
598 The idea is that lambdas are often quite helpful: they indicate
599 head normal forms, so we don't want to chuck them away lightly.
602 etaReduce :: CoreExpr -> CoreExpr
603 -- ToDo: we should really check that we don't turn a non-bottom
604 -- lambda into a bottom variable. Sigh
606 etaReduce expr@(Lam bndr body)
607 = check (reverse binders) body
609 (binders, body) = collectBinders expr
612 | not (any (`elemVarSet` body_fvs) binders)
615 body_fvs = exprFreeVars body
617 check (b : bs) (App fun arg)
618 | (varToCoreExpr b `cheapEqExpr` arg)
621 check _ _ = expr -- Bale out
623 etaReduce expr = expr -- The common case
628 exprEtaExpandArity :: CoreExpr -> (Int, Bool)
629 -- The Int is number of value args the thing can be
630 -- applied to without doing much work
631 -- The Bool is True iff there are enough explicit value lambdas
632 -- at the top to make this arity apparent
633 -- (but ignore it when arity==0)
635 -- This is used when eta expanding
636 -- e ==> \xy -> e x y
638 -- It returns 1 (or more) to:
639 -- case x of p -> \s -> ...
640 -- because for I/O ish things we really want to get that \s to the top.
641 -- We are prepared to evaluate x each time round the loop in order to get that
643 -- Consider let x = expensive in \y z -> E
644 -- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
646 -- Hence the list of Bools returned by go1
647 -- NB: this is particularly important/useful for IO state
648 -- transformers, where we often get
649 -- let x = E in \ s -> ...
650 -- and the \s is a real-world state token abstraction. Such
651 -- abstractions are almost invariably 1-shot, so we want to
652 -- pull the \s out, past the let x=E.
653 -- The hack is in Id.isOneShotLambda
658 go :: Int -> CoreExpr -> (Int,Bool)
659 go ar (Lam x e) | isId x = go (ar+1) e
660 | otherwise = go ar e
661 go ar (Note n e) | ok_note n = go ar e
662 go ar other = (ar + ar', ar' == 0)
664 ar' = length (go1 other)
666 go1 :: CoreExpr -> [Bool]
667 -- (go1 e) = [b1,..,bn]
668 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
669 -- where bi is True <=> the lambda is one-shot
671 go1 (Note n e) | ok_note n = go1 e
672 go1 (Var v) = replicate (idArity v) False -- When the type of the Id
673 -- encodes one-shot-ness, use
676 -- Lambdas; increase arity
677 go1 (Lam x e) | isId x = isOneShotLambda x : go1 e
680 -- Applications; decrease arity
681 go1 (App f (Type _)) = go1 f
682 go1 (App f a) = case go1 f of
683 (one_shot : xs) | one_shot || exprIsCheap a -> xs
686 -- Case/Let; keep arity if either the expression is cheap
687 -- or it's a 1-shot lambda
688 go1 (Case scrut _ alts) = case foldr1 (zipWith (&&)) [go1 rhs | (_,_,rhs) <- alts] of
689 xs@(one_shot : _) | one_shot || exprIsCheap scrut -> xs
691 go1 (Let b e) = case go1 e of
692 xs@(one_shot : _) | one_shot || all exprIsCheap (rhssOfBind b) -> xs
697 ok_note (Coerce _ _) = True
698 ok_note InlineCall = True
699 ok_note other = False
700 -- Notice that we do not look through __inline_me__
701 -- This may seem surprising, but consider
702 -- f = _inline_me (\x -> e)
703 -- We DO NOT want to eta expand this to
704 -- f = \x -> (_inline_me (\x -> e)) x
705 -- because the _inline_me gets dropped now it is applied,
713 etaExpand :: Int -- Add this number of value args
715 -> CoreExpr -> Type -- Expression and its type
717 -- (etaExpand n us e ty) returns an expression with
718 -- the same meaning as 'e', but with arity 'n'.
720 -- Given e' = etaExpand n us e ty
722 -- ty = exprType e = exprType e'
724 -- etaExpand deals with for-alls and coerces. For example:
726 -- where E :: forall a. T
727 -- newtype T = MkT (A -> B)
730 -- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
732 etaExpand n us expr ty
734 -- The ILX code generator requires eta expansion for type arguments
735 -- too, but alas the 'n' doesn't tell us how many of them there
736 -- may be. So we eagerly eta expand any big lambdas, and just
737 -- cross our fingers about possible loss of sharing in the
739 -- The Right Thing is probably to make 'arity' include
740 -- type variables throughout the compiler. (ToDo.)
742 -- Saturated, so nothing to do
745 | otherwise -- An unsaturated constructor or primop; eta expand it
746 = case splitForAllTy_maybe ty of {
747 Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
751 case splitFunTy_maybe ty of {
752 Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
754 arg1 = mkSysLocal SLIT("eta") uniq arg_ty
755 (us1, us2) = splitUniqSupply us
756 uniq = uniqFromSupply us1
760 case splitNewType_maybe ty of {
761 Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
763 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
768 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
769 It tells how many things the expression can be applied to before doing
770 any work. It doesn't look inside cases, lets, etc. The idea is that
771 exprEtaExpandArity will do the hard work, leaving something that's easy
772 for exprArity to grapple with. In particular, Simplify uses exprArity to
773 compute the ArityInfo for the Id.
775 Originally I thought that it was enough just to look for top-level lambdas, but
776 it isn't. I've seen this
778 foo = PrelBase.timesInt
780 We want foo to get arity 2 even though the eta-expander will leave it
781 unchanged, in the expectation that it'll be inlined. But occasionally it
782 isn't, because foo is blacklisted (used in a rule).
784 Similarly, see the ok_note check in exprEtaExpandArity. So
785 f = __inline_me (\x -> e)
786 won't be eta-expanded.
788 And in any case it seems more robust to have exprArity be a bit more intelligent.
791 exprArity :: CoreExpr -> Int
792 exprArity e = go e `max` 0
794 go (Lam x e) | isId x = go e + 1
797 go (App e (Type t)) = go e
798 go (App f a) = go f - 1
799 go (Var v) = idArity v
804 %************************************************************************
806 \subsection{Equality}
808 %************************************************************************
810 @cheapEqExpr@ is a cheap equality test which bales out fast!
811 True => definitely equal
812 False => may or may not be equal
815 cheapEqExpr :: Expr b -> Expr b -> Bool
817 cheapEqExpr (Var v1) (Var v2) = v1==v2
818 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
819 cheapEqExpr (Type t1) (Type t2) = t1 == t2
821 cheapEqExpr (App f1 a1) (App f2 a2)
822 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
824 cheapEqExpr _ _ = False
826 exprIsBig :: Expr b -> Bool
827 -- Returns True of expressions that are too big to be compared by cheapEqExpr
828 exprIsBig (Lit _) = False
829 exprIsBig (Var v) = False
830 exprIsBig (Type t) = False
831 exprIsBig (App f a) = exprIsBig f || exprIsBig a
832 exprIsBig other = True
837 eqExpr :: CoreExpr -> CoreExpr -> Bool
838 -- Works ok at more general type, but only needed at CoreExpr
840 = eq emptyVarEnv e1 e2
842 -- The "env" maps variables in e1 to variables in ty2
843 -- So when comparing lambdas etc,
844 -- we in effect substitute v2 for v1 in e1 before continuing
845 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
846 Just v1' -> v1' == v2
849 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
850 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
851 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
852 eq env (Let (NonRec v1 r1) e1)
853 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
854 eq env (Let (Rec ps1) e1)
855 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
856 and (zipWith eq_rhs ps1 ps2) &&
859 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
860 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
861 eq env (Case e1 v1 a1)
862 (Case e2 v2 a2) = eq env e1 e2 &&
863 length a1 == length a2 &&
864 and (zipWith (eq_alt env') a1 a2)
866 env' = extendVarEnv env v1 v2
868 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
869 eq env (Type t1) (Type t2) = t1 == t2
872 eq_list env [] [] = True
873 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
874 eq_list env es1 es2 = False
876 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
877 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
879 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
880 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
881 eq_note env InlineCall InlineCall = True
882 eq_note env other1 other2 = False
886 %************************************************************************
888 \subsection{The size of an expression}
890 %************************************************************************
893 coreBindsSize :: [CoreBind] -> Int
894 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
896 exprSize :: CoreExpr -> Int
897 -- A measure of the size of the expressions
898 -- It also forces the expression pretty drastically as a side effect
899 exprSize (Var v) = varSize v
900 exprSize (Lit lit) = lit `seq` 1
901 exprSize (App f a) = exprSize f + exprSize a
902 exprSize (Lam b e) = varSize b + exprSize e
903 exprSize (Let b e) = bindSize b + exprSize e
904 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
905 exprSize (Note n e) = noteSize n + exprSize e
906 exprSize (Type t) = seqType t `seq` 1
908 noteSize (SCC cc) = cc `seq` 1
909 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
910 noteSize InlineCall = 1
911 noteSize InlineMe = 1
913 varSize :: Var -> Int
914 varSize b | isTyVar b = 1
915 | otherwise = seqType (idType b) `seq`
916 megaSeqIdInfo (idInfo b) `seq`
919 varsSize = foldr ((+) . varSize) 0
921 bindSize (NonRec b e) = varSize b + exprSize e
922 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
924 pairSize (b,e) = varSize b + exprSize e
926 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
930 %************************************************************************
934 %************************************************************************
937 hashExpr :: CoreExpr -> Int
938 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
941 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
943 hash_expr (Note _ e) = hash_expr e
944 hash_expr (Let (NonRec b r) e) = hashId b
945 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
946 hash_expr (Case _ b _) = hashId b
947 hash_expr (App f e) = hash_expr f * fast_hash_expr e
948 hash_expr (Var v) = hashId v
949 hash_expr (Lit lit) = hashLiteral lit
950 hash_expr (Lam b _) = hashId b
951 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
953 fast_hash_expr (Var v) = hashId v
954 fast_hash_expr (Lit lit) = hashLiteral lit
955 fast_hash_expr (App f (Type _)) = fast_hash_expr f
956 fast_hash_expr (App f a) = fast_hash_expr a
957 fast_hash_expr (Lam b _) = hashId b
958 fast_hash_expr other = 1
961 hashId id = hashName (idName id)