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
14 findDefault, findAlt, hasDefault,
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, isForAllTy, splitNewType_maybe, eqType
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 `eqType` to_ty2 )
189 mkCoerce to_ty from_ty2 expr
191 mkCoerce to_ty from_ty expr
192 | to_ty `eqType` from_ty = expr
193 | otherwise = ASSERT( from_ty `eqType` 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 %************************************************************************
254 The default alternative must be first, if it exists at all.
255 This makes it easy to find, though it makes matching marginally harder.
258 hasDefault :: [CoreAlt] -> Bool
259 hasDefault ((DEFAULT,_,_) : alts) = True
262 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
263 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
264 findDefault alts = (alts, Nothing)
266 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
269 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
270 other -> go alts panic_deflt
273 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
276 go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
277 | otherwise = ASSERT( not (con1 == DEFAULT) )
282 %************************************************************************
284 \subsection{Figuring out things about expressions}
286 %************************************************************************
288 @exprIsTrivial@ is true of expressions we are unconditionally happy to
289 duplicate; simple variables and constants, and type
290 applications. Note that primop Ids aren't considered
293 @exprIsBottom@ is true of expressions that are guaranteed to diverge
297 exprIsTrivial (Var v)
298 | hasNoBinding v = idArity v == 0
299 -- WAS: | Just op <- isPrimOpId_maybe v = primOpIsDupable op
300 -- The idea here is that a constructor worker, like $wJust, is
301 -- really short for (\x -> $wJust x), becuase $wJust has no binding.
302 -- So it should be treated like a lambda.
303 -- Ditto unsaturated primops.
304 -- This came up when dealing with eta expansion/reduction for
306 -- Here we want to eta-expand. This looks like an optimisation,
307 -- but it's important (albeit tiresome) that CoreSat doesn't increase
310 exprIsTrivial (Type _) = True
311 exprIsTrivial (Lit lit) = True
312 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
313 exprIsTrivial (Note _ e) = exprIsTrivial e
314 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
315 exprIsTrivial other = False
317 exprIsAtom :: CoreExpr -> Bool
318 -- Used to decide whether to let-binding an STG argument
319 -- when compiling to ILX => type applications are not allowed
320 exprIsAtom (Var v) = True -- primOpIsDupable?
321 exprIsAtom (Lit lit) = True
322 exprIsAtom (Type ty) = True
323 exprIsAtom (Note (SCC _) e) = False
324 exprIsAtom (Note _ e) = exprIsAtom e
325 exprIsAtom other = False
329 @exprIsDupable@ is true of expressions that can be duplicated at a modest
330 cost in code size. This will only happen in different case
331 branches, so there's no issue about duplicating work.
333 That is, exprIsDupable returns True of (f x) even if
334 f is very very expensive to call.
336 Its only purpose is to avoid fruitless let-binding
337 and then inlining of case join points
341 exprIsDupable (Type _) = True
342 exprIsDupable (Var v) = True
343 exprIsDupable (Lit lit) = litIsDupable lit
344 exprIsDupable (Note InlineMe e) = True
345 exprIsDupable (Note _ e) = exprIsDupable e
349 go (Var v) n_args = True
350 go (App f a) n_args = n_args < dupAppSize
353 go other n_args = False
356 dupAppSize = 4 -- Size of application we are prepared to duplicate
359 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
360 it is obviously in weak head normal form, or is cheap to get to WHNF.
361 [Note that that's not the same as exprIsDupable; an expression might be
362 big, and hence not dupable, but still cheap.]
364 By ``cheap'' we mean a computation we're willing to:
365 push inside a lambda, or
366 inline at more than one place
367 That might mean it gets evaluated more than once, instead of being
368 shared. The main examples of things which aren't WHNF but are
373 (where e, and all the ei are cheap)
376 (where e and b are cheap)
379 (where op is a cheap primitive operator)
382 (because we are happy to substitute it inside a lambda)
384 Notice that a variable is considered 'cheap': we can push it inside a lambda,
385 because sharing will make sure it is only evaluated once.
388 exprIsCheap :: CoreExpr -> Bool
389 exprIsCheap (Lit lit) = True
390 exprIsCheap (Type _) = True
391 exprIsCheap (Var _) = True
392 exprIsCheap (Note InlineMe e) = True
393 exprIsCheap (Note _ e) = exprIsCheap e
394 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
395 exprIsCheap (Case e _ alts) = exprIsCheap e &&
396 and [exprIsCheap rhs | (_,_,rhs) <- alts]
397 -- Experimentally, treat (case x of ...) as cheap
398 -- (and case __coerce x etc.)
399 -- This improves arities of overloaded functions where
400 -- there is only dictionary selection (no construction) involved
401 exprIsCheap (Let (NonRec x _) e)
402 | isUnLiftedType (idType x) = exprIsCheap e
404 -- strict lets always have cheap right hand sides, and
407 exprIsCheap other_expr
408 = go other_expr 0 True
410 go (Var f) n_args args_cheap
411 = (idAppIsCheap f n_args && args_cheap)
412 -- A constructor, cheap primop, or partial application
414 || idAppIsBottom f n_args
415 -- Application of a function which
416 -- always gives bottom; we treat this as cheap
417 -- because it certainly doesn't need to be shared!
419 go (App f a) n_args args_cheap
420 | not (isRuntimeArg a) = go f n_args args_cheap
421 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
423 go other n_args args_cheap = False
425 idAppIsCheap :: Id -> Int -> Bool
426 idAppIsCheap id n_val_args
427 | n_val_args == 0 = True -- Just a type application of
428 -- a variable (f t1 t2 t3)
430 | otherwise = case globalIdDetails id of
432 RecordSelId _ -> True -- I'm experimenting with making record selection
433 -- look cheap, so we will substitute it inside a
434 -- lambda. Particularly for dictionary field selection
436 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
437 -- that return a type variable, since the result
438 -- might be applied to something, but I'm not going
439 -- to bother to check the number of args
440 other -> n_val_args < idArity id
443 exprOkForSpeculation returns True of an expression that it is
445 * safe to evaluate even if normal order eval might not
446 evaluate the expression at all, or
448 * safe *not* to evaluate even if normal order would do so
452 the expression guarantees to terminate,
454 without raising an exception,
455 without causing a side effect (e.g. writing a mutable variable)
458 let x = case y# +# 1# of { r# -> I# r# }
461 case y# +# 1# of { r# ->
466 We can only do this if the (y+1) is ok for speculation: it has no
467 side effects, and can't diverge or raise an exception.
470 exprOkForSpeculation :: CoreExpr -> Bool
471 exprOkForSpeculation (Lit _) = True
472 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
473 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
474 exprOkForSpeculation other_expr
475 = go other_expr 0 True
477 go (Var f) n_args args_ok
478 = case globalIdDetails f of
479 DataConId _ -> True -- The strictness of the constructor has already
480 -- been expressed by its "wrapper", so we don't need
481 -- to take the arguments into account
483 PrimOpId op -> primOpOkForSpeculation op && args_ok
484 -- A bit conservative: we don't really need
485 -- to care about lazy arguments, but this is easy
489 go (App f a) n_args args_ok
490 | not (isRuntimeArg a) = go f n_args args_ok
491 | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
493 go other n_args args_ok = False
498 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
499 exprIsBottom e = go 0 e
501 -- n is the number of args
502 go n (Note _ e) = go n e
503 go n (Let _ e) = go n e
504 go n (Case e _ _) = go 0 e -- Just check the scrut
505 go n (App e _) = go (n+1) e
506 go n (Var v) = idAppIsBottom v n
508 go n (Lam _ _) = False
510 idAppIsBottom :: Id -> Int -> Bool
511 idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
514 @exprIsValue@ returns true for expressions that are certainly *already*
515 evaluated to WHNF. This is used to decide whether it's ok to change
516 case x of _ -> e ===> e
518 and to decide whether it's safe to discard a `seq`
520 So, it does *not* treat variables as evaluated, unless they say they are.
522 But it *does* treat partial applications and constructor applications
523 as values, even if their arguments are non-trivial;
524 e.g. (:) (f x) (map f xs) is a value
525 map (...redex...) is a value
526 Because `seq` on such things completes immediately
528 A possible worry: constructors with unboxed args:
530 Suppose (f x) diverges; then C (f x) is not a value. True, but
531 this form is illegal (see the invariants in CoreSyn). Args of unboxed
532 type must be ok-for-speculation (or trivial).
535 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
536 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
538 exprIsValue (Lit l) = True
539 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
540 exprIsValue (Note _ e) = exprIsValue e
541 exprIsValue other_expr
544 go (Var f) n_args = idAppIsValue f n_args
547 | not (isRuntimeArg a) = go f n_args
548 | otherwise = go f (n_args + 1)
550 go (Note _ f) n_args = go f n_args
552 go other n_args = False
554 idAppIsValue :: Id -> Int -> Bool
555 idAppIsValue id n_val_args
556 = case globalIdDetails id of
558 PrimOpId _ -> n_val_args < idArity id
559 other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
560 | otherwise -> n_val_args < idArity id
561 -- A worry: what if an Id's unfolding is just itself:
562 -- then we could get an infinite loop...
566 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
567 exprIsConApp_maybe (Note InlineMe expr) = exprIsConApp_maybe expr
568 -- We ignore InlineMe notes in case we have
569 -- x = __inline_me__ (a,b)
570 -- All part of making sure that INLINE pragmas never hurt
571 -- Marcin tripped on this one when making dictionaries more inlinable
573 exprIsConApp_maybe expr = analyse (collectArgs expr)
575 analyse (Var fun, args)
576 | Just con <- isDataConId_maybe fun,
577 length args >= dataConRepArity con
578 -- Might be > because the arity excludes type args
581 -- Look through unfoldings, but only cheap ones, because
582 -- we are effectively duplicating the unfolding
583 analyse (Var fun, [])
584 | let unf = idUnfolding fun,
586 = exprIsConApp_maybe (unfoldingTemplate unf)
588 analyse other = Nothing
593 %************************************************************************
595 \subsection{Eta reduction and expansion}
597 %************************************************************************
599 @etaReduce@ trys an eta reduction at the top level of a Core Expr.
601 e.g. \ x y -> f x y ===> f
603 But we only do this if it gets rid of a whole lambda, not part.
604 The idea is that lambdas are often quite helpful: they indicate
605 head normal forms, so we don't want to chuck them away lightly.
608 etaReduce :: CoreExpr -> CoreExpr
609 -- ToDo: we should really check that we don't turn a non-bottom
610 -- lambda into a bottom variable. Sigh
612 etaReduce expr@(Lam bndr body)
613 = check (reverse binders) body
615 (binders, body) = collectBinders expr
618 | not (any (`elemVarSet` body_fvs) binders)
621 body_fvs = exprFreeVars body
623 check (b : bs) (App fun arg)
624 | (varToCoreExpr b `cheapEqExpr` arg)
627 check _ _ = expr -- Bale out
629 etaReduce expr = expr -- The common case
634 exprEtaExpandArity :: CoreExpr -> (Int, Bool)
635 -- The Int is number of value args the thing can be
636 -- applied to without doing much work
637 -- The Bool is True iff there are enough explicit value lambdas
638 -- at the top to make this arity apparent
639 -- (but ignore it when arity==0)
641 -- This is used when eta expanding
642 -- e ==> \xy -> e x y
644 -- It returns 1 (or more) to:
645 -- case x of p -> \s -> ...
646 -- because for I/O ish things we really want to get that \s to the top.
647 -- We are prepared to evaluate x each time round the loop in order to get that
649 -- Consider let x = expensive in \y z -> E
650 -- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
652 -- Hence the list of Bools returned by go1
653 -- NB: this is particularly important/useful for IO state
654 -- transformers, where we often get
655 -- let x = E in \ s -> ...
656 -- and the \s is a real-world state token abstraction. Such
657 -- abstractions are almost invariably 1-shot, so we want to
658 -- pull the \s out, past the let x=E.
659 -- The hack is in Id.isOneShotLambda
664 go :: Int -> CoreExpr -> (Int,Bool)
665 go ar (Lam x e) | isId x = go (ar+1) e
666 | otherwise = go ar e
667 go ar (Note n e) | ok_note n = go ar e
668 go ar other = (ar + ar', ar' == 0)
670 ar' = length (go1 other)
672 go1 :: CoreExpr -> [Bool]
673 -- (go1 e) = [b1,..,bn]
674 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
675 -- where bi is True <=> the lambda is one-shot
677 go1 (Note n e) | ok_note n = go1 e
678 go1 (Var v) = replicate (idArity v) False -- When the type of the Id
679 -- encodes one-shot-ness, use
682 -- Lambdas; increase arity
683 go1 (Lam x e) | isId x = isOneShotLambda x : go1 e
686 -- Applications; decrease arity
687 go1 (App f (Type _)) = go1 f
688 go1 (App f a) = case go1 f of
689 (one_shot : xs) | one_shot || exprIsCheap a -> xs
692 -- Case/Let; keep arity if either the expression is cheap
693 -- or it's a 1-shot lambda
694 go1 (Case scrut _ alts) = case foldr1 (zipWith (&&)) [go1 rhs | (_,_,rhs) <- alts] of
695 xs@(one_shot : _) | one_shot || exprIsCheap scrut -> xs
697 go1 (Let b e) = case go1 e of
698 xs@(one_shot : _) | one_shot || all exprIsCheap (rhssOfBind b) -> xs
703 ok_note InlineMe = False
705 -- Notice that we do not look through __inline_me__
706 -- This may seem surprising, but consider
707 -- f = _inline_me (\x -> e)
708 -- We DO NOT want to eta expand this to
709 -- f = \x -> (_inline_me (\x -> e)) x
710 -- because the _inline_me gets dropped now it is applied,
718 etaExpand :: Int -- Add this number of value args
720 -> CoreExpr -> Type -- Expression and its type
722 -- (etaExpand n us e ty) returns an expression with
723 -- the same meaning as 'e', but with arity 'n'.
725 -- Given e' = etaExpand n us e ty
727 -- ty = exprType e = exprType e'
729 -- etaExpand deals with for-alls. For example:
731 -- where E :: forall a. a -> a
733 -- (/\b. \y::a -> E b y)
735 -- It deals with coerces too, though they are now rare
736 -- so perhaps the extra code isn't worth it
738 etaExpand n us expr ty
740 -- The ILX code generator requires eta expansion for type arguments
741 -- too, but alas the 'n' doesn't tell us how many of them there
742 -- may be. So we eagerly eta expand any big lambdas, and just
743 -- cross our fingers about possible loss of sharing in the
745 -- The Right Thing is probably to make 'arity' include
746 -- type variables throughout the compiler. (ToDo.)
748 -- Saturated, so nothing to do
751 | otherwise -- An unsaturated constructor or primop; eta expand it
752 = case splitForAllTy_maybe ty of {
753 Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
757 case splitFunTy_maybe ty of {
758 Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
760 arg1 = mkSysLocal SLIT("eta") uniq arg_ty
761 (us1, us2) = splitUniqSupply us
762 uniq = uniqFromSupply us1
766 case splitNewType_maybe ty of {
767 Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
768 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
773 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
774 It tells how many things the expression can be applied to before doing
775 any work. It doesn't look inside cases, lets, etc. The idea is that
776 exprEtaExpandArity will do the hard work, leaving something that's easy
777 for exprArity to grapple with. In particular, Simplify uses exprArity to
778 compute the ArityInfo for the Id.
780 Originally I thought that it was enough just to look for top-level lambdas, but
781 it isn't. I've seen this
783 foo = PrelBase.timesInt
785 We want foo to get arity 2 even though the eta-expander will leave it
786 unchanged, in the expectation that it'll be inlined. But occasionally it
787 isn't, because foo is blacklisted (used in a rule).
789 Similarly, see the ok_note check in exprEtaExpandArity. So
790 f = __inline_me (\x -> e)
791 won't be eta-expanded.
793 And in any case it seems more robust to have exprArity be a bit more intelligent.
796 exprArity :: CoreExpr -> Int
799 go (Var v) = idArity v
800 go (Lam x e) | isId x = go e + 1
803 go (App e (Type t)) = go e
804 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
805 -- NB: exprIsCheap a!
806 -- f (fac x) does not have arity 2,
807 -- even if f has arity 3!
808 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
809 -- unknown, hence arity 0
814 %************************************************************************
816 \subsection{Equality}
818 %************************************************************************
820 @cheapEqExpr@ is a cheap equality test which bales out fast!
821 True => definitely equal
822 False => may or may not be equal
825 cheapEqExpr :: Expr b -> Expr b -> Bool
827 cheapEqExpr (Var v1) (Var v2) = v1==v2
828 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
829 cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
831 cheapEqExpr (App f1 a1) (App f2 a2)
832 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
834 cheapEqExpr _ _ = False
836 exprIsBig :: Expr b -> Bool
837 -- Returns True of expressions that are too big to be compared by cheapEqExpr
838 exprIsBig (Lit _) = False
839 exprIsBig (Var v) = False
840 exprIsBig (Type t) = False
841 exprIsBig (App f a) = exprIsBig f || exprIsBig a
842 exprIsBig other = True
847 eqExpr :: CoreExpr -> CoreExpr -> Bool
848 -- Works ok at more general type, but only needed at CoreExpr
849 -- Used in rule matching, so when we find a type we use
850 -- eqTcType, which doesn't look through newtypes
851 -- [And it doesn't risk falling into a black hole either.]
853 = eq emptyVarEnv e1 e2
855 -- The "env" maps variables in e1 to variables in ty2
856 -- So when comparing lambdas etc,
857 -- we in effect substitute v2 for v1 in e1 before continuing
858 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
859 Just v1' -> v1' == v2
862 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
863 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
864 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
865 eq env (Let (NonRec v1 r1) e1)
866 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
867 eq env (Let (Rec ps1) e1)
868 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
869 and (zipWith eq_rhs ps1 ps2) &&
872 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
873 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
874 eq env (Case e1 v1 a1)
875 (Case e2 v2 a2) = eq env e1 e2 &&
876 length a1 == length a2 &&
877 and (zipWith (eq_alt env') a1 a2)
879 env' = extendVarEnv env v1 v2
881 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
882 eq env (Type t1) (Type t2) = t1 `eqType` t2
885 eq_list env [] [] = True
886 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
887 eq_list env es1 es2 = False
889 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
890 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
892 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
893 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
894 eq_note env InlineCall InlineCall = True
895 eq_note env other1 other2 = False
899 %************************************************************************
901 \subsection{The size of an expression}
903 %************************************************************************
906 coreBindsSize :: [CoreBind] -> Int
907 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
909 exprSize :: CoreExpr -> Int
910 -- A measure of the size of the expressions
911 -- It also forces the expression pretty drastically as a side effect
912 exprSize (Var v) = varSize v
913 exprSize (Lit lit) = lit `seq` 1
914 exprSize (App f a) = exprSize f + exprSize a
915 exprSize (Lam b e) = varSize b + exprSize e
916 exprSize (Let b e) = bindSize b + exprSize e
917 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
918 exprSize (Note n e) = noteSize n + exprSize e
919 exprSize (Type t) = seqType t `seq` 1
921 noteSize (SCC cc) = cc `seq` 1
922 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
923 noteSize InlineCall = 1
924 noteSize InlineMe = 1
926 varSize :: Var -> Int
927 varSize b | isTyVar b = 1
928 | otherwise = seqType (idType b) `seq`
929 megaSeqIdInfo (idInfo b) `seq`
932 varsSize = foldr ((+) . varSize) 0
934 bindSize (NonRec b e) = varSize b + exprSize e
935 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
937 pairSize (b,e) = varSize b + exprSize e
939 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
943 %************************************************************************
947 %************************************************************************
950 hashExpr :: CoreExpr -> Int
951 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
954 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
956 hash_expr (Note _ e) = hash_expr e
957 hash_expr (Let (NonRec b r) e) = hashId b
958 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
959 hash_expr (Case _ b _) = hashId b
960 hash_expr (App f e) = hash_expr f * fast_hash_expr e
961 hash_expr (Var v) = hashId v
962 hash_expr (Lit lit) = hashLiteral lit
963 hash_expr (Lam b _) = hashId b
964 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
966 fast_hash_expr (Var v) = hashId v
967 fast_hash_expr (Lit lit) = hashLiteral lit
968 fast_hash_expr (App f (Type _)) = fast_hash_expr f
969 fast_hash_expr (App f a) = fast_hash_expr a
970 fast_hash_expr (Lam b _) = hashId b
971 fast_hash_expr other = 1
974 hashId id = hashName (idName id)