2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
10 bindNonRec, needsCaseBinding,
11 mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
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 -- Arity and eta expansion
25 manifestArity, exprArity,
26 exprEtaExpandArity, etaExpand,
35 cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
38 #include "HsVersions.h"
41 import GLAEXTS -- For `xori`
44 import PprCore ( pprCoreExpr )
45 import Var ( Var, isId, isTyVar )
47 import Name ( hashName )
48 import Literal ( hashLiteral, literalType, litIsDupable, isZeroLit )
49 import DataCon ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon )
50 import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
51 import Id ( Id, idType, globalIdDetails, idNewStrictness,
52 mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
53 isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId
55 import IdInfo ( GlobalIdDetails(..),
57 import NewDemand ( appIsBottom )
58 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
59 applyTys, isUnLiftedType, seqType, mkTyVarTy,
60 splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
61 splitTyConApp_maybe, eqType, funResultTy, applyTy,
64 import TyCon ( tyConArity )
65 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
66 import CostCentre ( CostCentre )
67 import BasicTypes ( Arity )
68 import Unique ( Unique )
70 import TysPrim ( alphaTy ) -- Debugging only
71 import Util ( equalLength, lengthAtLeast )
75 %************************************************************************
77 \subsection{Find the type of a Core atom/expression}
79 %************************************************************************
82 exprType :: CoreExpr -> Type
84 exprType (Var var) = idType var
85 exprType (Lit lit) = literalType lit
86 exprType (Let _ body) = exprType body
87 exprType (Case _ _ alts) = coreAltsType alts
88 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
89 exprType (Note other_note e) = exprType e
90 exprType (Lam binder expr) = mkPiType binder (exprType expr)
92 = case collectArgs e of
93 (fun, args) -> applyTypeToArgs e (exprType fun) args
95 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
97 coreAltsType :: [CoreAlt] -> Type
98 coreAltsType ((_,_,rhs) : _) = exprType rhs
101 @mkPiType@ makes a (->) type or a forall type, depending on whether
102 it is given a type variable or a term variable. We cleverly use the
103 lbvarinfo field to figure out the right annotation for the arrove in
104 case of a term variable.
107 mkPiType :: Var -> Type -> Type -- The more polymorphic version
108 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
110 mkPiTypes vs ty = foldr mkPiType ty vs
113 | isId v = mkFunTy (idType v) ty
114 | otherwise = mkForAllTy v ty
118 applyTypeToArg :: Type -> CoreExpr -> Type
119 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
120 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
122 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
123 -- A more efficient version of applyTypeToArg
124 -- when we have several args
125 -- The first argument is just for debugging
126 applyTypeToArgs e op_ty [] = op_ty
128 applyTypeToArgs e op_ty (Type ty : args)
129 = -- Accumulate type arguments so we can instantiate all at once
132 go rev_tys (Type ty : args) = go (ty:rev_tys) args
133 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
135 op_ty' = applyTys op_ty (reverse rev_tys)
137 applyTypeToArgs e op_ty (other_arg : args)
138 = case (splitFunTy_maybe op_ty) of
139 Just (_, res_ty) -> applyTypeToArgs e res_ty args
140 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
145 %************************************************************************
147 \subsection{Attaching notes}
149 %************************************************************************
151 mkNote removes redundant coercions, and SCCs where possible
154 mkNote :: Note -> CoreExpr -> CoreExpr
155 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
156 mkNote (SCC cc) expr = mkSCC cc expr
157 mkNote InlineMe expr = mkInlineMe expr
158 mkNote note expr = Note note expr
160 -- Slide InlineCall in around the function
161 -- No longer necessary I think (SLPJ Apr 99)
162 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
163 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
164 -- mkNote InlineCall expr = expr
167 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
168 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
169 not be *applied* to anything.
171 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
174 f = inline_me (coerce t fw)
175 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
176 We want the split, so that the coerces can cancel at the call site.
178 However, we can get left with tiresome type applications. Notably, consider
179 f = /\ a -> let t = e in (t, w)
180 Then lifting the let out of the big lambda gives
182 f = /\ a -> let t = inline_me (t' a) in (t, w)
183 The inline_me is to stop the simplifier inlining t' right back
184 into t's RHS. In the next phase we'll substitute for t (since
185 its rhs is trivial) and *then* we could get rid of the inline_me.
186 But it hardly seems worth it, so I don't bother.
189 mkInlineMe (Var v) = Var v
190 mkInlineMe e = Note InlineMe e
196 mkCoerce :: Type -> CoreExpr -> CoreExpr
197 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
199 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
200 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
201 = ASSERT( from_ty `eqType` to_ty2 )
202 mkCoerce2 to_ty from_ty2 expr
204 mkCoerce2 to_ty from_ty expr
205 | to_ty `eqType` from_ty = expr
206 | otherwise = ASSERT( from_ty `eqType` exprType expr )
207 Note (Coerce to_ty from_ty) expr
211 mkSCC :: CostCentre -> Expr b -> Expr b
212 -- Note: Nested SCC's *are* preserved for the benefit of
213 -- cost centre stack profiling
214 mkSCC cc (Lit lit) = Lit lit
215 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
216 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
217 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
218 mkSCC cc expr = Note (SCC cc) expr
222 %************************************************************************
224 \subsection{Other expression construction}
226 %************************************************************************
229 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
230 -- (bindNonRec x r b) produces either
233 -- case r of x { _DEFAULT_ -> b }
235 -- depending on whether x is unlifted or not
236 -- It's used by the desugarer to avoid building bindings
237 -- that give Core Lint a heart attack. Actually the simplifier
238 -- deals with them perfectly well.
239 bindNonRec bndr rhs body
240 | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
241 | otherwise = Let (NonRec bndr rhs) body
243 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
244 -- Make a case expression instead of a let
245 -- These can arise either from the desugarer,
246 -- or from beta reductions: (\x.e) (x +# y)
250 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
251 -- This guy constructs the value that the scrutinee must have
252 -- when you are in one particular branch of a case
253 mkAltExpr (DataAlt con) args inst_tys
254 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
255 mkAltExpr (LitAlt lit) [] []
258 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
259 mkIfThenElse guard then_expr else_expr
260 = Case guard (mkWildId boolTy)
261 [ (DataAlt trueDataCon, [], then_expr),
262 (DataAlt falseDataCon, [], else_expr) ]
266 %************************************************************************
268 \subsection{Taking expressions apart}
270 %************************************************************************
272 The default alternative must be first, if it exists at all.
273 This makes it easy to find, though it makes matching marginally harder.
276 hasDefault :: [CoreAlt] -> Bool
277 hasDefault ((DEFAULT,_,_) : alts) = True
280 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
281 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
282 findDefault alts = (alts, Nothing)
284 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
287 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
288 other -> go alts panic_deflt
291 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
294 go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
295 | otherwise = ASSERT( not (con1 == DEFAULT) )
300 %************************************************************************
302 \subsection{Figuring out things about expressions}
304 %************************************************************************
306 @exprIsTrivial@ is true of expressions we are unconditionally happy to
307 duplicate; simple variables and constants, and type
308 applications. Note that primop Ids aren't considered
311 @exprIsBottom@ is true of expressions that are guaranteed to diverge
314 There used to be a gruesome test for (hasNoBinding v) in the
316 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
317 The idea here is that a constructor worker, like $wJust, is
318 really short for (\x -> $wJust x), becuase $wJust has no binding.
319 So it should be treated like a lambda. Ditto unsaturated primops.
320 But now constructor workers are not "have-no-binding" Ids. And
321 completely un-applied primops and foreign-call Ids are sufficiently
322 rare that I plan to allow them to be duplicated and put up with
326 exprIsTrivial (Var v) = True -- See notes above
327 exprIsTrivial (Type _) = True
328 exprIsTrivial (Lit lit) = True
329 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
330 exprIsTrivial (Note _ e) = exprIsTrivial e
331 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
332 exprIsTrivial other = False
334 exprIsAtom :: CoreExpr -> Bool
335 -- Used to decide whether to let-binding an STG argument
336 -- when compiling to ILX => type applications are not allowed
337 exprIsAtom (Var v) = True -- primOpIsDupable?
338 exprIsAtom (Lit lit) = True
339 exprIsAtom (Type ty) = True
340 exprIsAtom (Note (SCC _) e) = False
341 exprIsAtom (Note _ e) = exprIsAtom e
342 exprIsAtom other = False
346 @exprIsDupable@ is true of expressions that can be duplicated at a modest
347 cost in code size. This will only happen in different case
348 branches, so there's no issue about duplicating work.
350 That is, exprIsDupable returns True of (f x) even if
351 f is very very expensive to call.
353 Its only purpose is to avoid fruitless let-binding
354 and then inlining of case join points
358 exprIsDupable (Type _) = True
359 exprIsDupable (Var v) = True
360 exprIsDupable (Lit lit) = litIsDupable lit
361 exprIsDupable (Note InlineMe e) = True
362 exprIsDupable (Note _ e) = exprIsDupable e
366 go (Var v) n_args = True
367 go (App f a) n_args = n_args < dupAppSize
370 go other n_args = False
373 dupAppSize = 4 -- Size of application we are prepared to duplicate
376 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
377 it is obviously in weak head normal form, or is cheap to get to WHNF.
378 [Note that that's not the same as exprIsDupable; an expression might be
379 big, and hence not dupable, but still cheap.]
381 By ``cheap'' we mean a computation we're willing to:
382 push inside a lambda, or
383 inline at more than one place
384 That might mean it gets evaluated more than once, instead of being
385 shared. The main examples of things which aren't WHNF but are
390 (where e, and all the ei are cheap)
393 (where e and b are cheap)
396 (where op is a cheap primitive operator)
399 (because we are happy to substitute it inside a lambda)
401 Notice that a variable is considered 'cheap': we can push it inside a lambda,
402 because sharing will make sure it is only evaluated once.
405 exprIsCheap :: CoreExpr -> Bool
406 exprIsCheap (Lit lit) = True
407 exprIsCheap (Type _) = True
408 exprIsCheap (Var _) = True
409 exprIsCheap (Note InlineMe e) = True
410 exprIsCheap (Note _ e) = exprIsCheap e
411 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
412 exprIsCheap (Case e _ alts) = exprIsCheap e &&
413 and [exprIsCheap rhs | (_,_,rhs) <- alts]
414 -- Experimentally, treat (case x of ...) as cheap
415 -- (and case __coerce x etc.)
416 -- This improves arities of overloaded functions where
417 -- there is only dictionary selection (no construction) involved
418 exprIsCheap (Let (NonRec x _) e)
419 | isUnLiftedType (idType x) = exprIsCheap e
421 -- strict lets always have cheap right hand sides, and
424 exprIsCheap other_expr
425 = go other_expr 0 True
427 go (Var f) n_args args_cheap
428 = (idAppIsCheap f n_args && args_cheap)
429 -- A constructor, cheap primop, or partial application
431 || idAppIsBottom f n_args
432 -- Application of a function which
433 -- always gives bottom; we treat this as cheap
434 -- because it certainly doesn't need to be shared!
436 go (App f a) n_args args_cheap
437 | not (isRuntimeArg a) = go f n_args args_cheap
438 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
440 go other n_args args_cheap = False
442 idAppIsCheap :: Id -> Int -> Bool
443 idAppIsCheap id n_val_args
444 | n_val_args == 0 = True -- Just a type application of
445 -- a variable (f t1 t2 t3)
447 | otherwise = case globalIdDetails id of
449 RecordSelId _ -> True -- I'm experimenting with making record selection
450 -- look cheap, so we will substitute it inside a
451 -- lambda. Particularly for dictionary field selection
453 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
454 -- that return a type variable, since the result
455 -- might be applied to something, but I'm not going
456 -- to bother to check the number of args
457 other -> n_val_args < idArity id
460 exprOkForSpeculation returns True of an expression that it is
462 * safe to evaluate even if normal order eval might not
463 evaluate the expression at all, or
465 * safe *not* to evaluate even if normal order would do so
469 the expression guarantees to terminate,
471 without raising an exception,
472 without causing a side effect (e.g. writing a mutable variable)
475 let x = case y# +# 1# of { r# -> I# r# }
478 case y# +# 1# of { r# ->
483 We can only do this if the (y+1) is ok for speculation: it has no
484 side effects, and can't diverge or raise an exception.
487 exprOkForSpeculation :: CoreExpr -> Bool
488 exprOkForSpeculation (Lit _) = True
489 exprOkForSpeculation (Type _) = True
490 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
491 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
492 exprOkForSpeculation other_expr
493 = case collectArgs other_expr of
494 (Var f, args) -> spec_ok (globalIdDetails f) args
498 spec_ok (DataConId _) args
499 = True -- The strictness of the constructor has already
500 -- been expressed by its "wrapper", so we don't need
501 -- to take the arguments into account
503 spec_ok (PrimOpId op) args
504 | isDivOp op, -- Special case for dividing operations that fail
505 [arg1, Lit lit] <- args -- only if the divisor is zero
506 = not (isZeroLit lit) && exprOkForSpeculation arg1
507 -- Often there is a literal divisor, and this
508 -- can get rid of a thunk in an inner looop
511 = primOpOkForSpeculation op &&
512 all exprOkForSpeculation args
513 -- A bit conservative: we don't really need
514 -- to care about lazy arguments, but this is easy
516 spec_ok other args = False
518 isDivOp :: PrimOp -> Bool
519 -- True of dyadic operators that can fail
520 -- only if the second arg is zero
521 -- This function probably belongs in PrimOp, or even in
522 -- an automagically generated file.. but it's such a
523 -- special case I thought I'd leave it here for now.
524 isDivOp IntQuotOp = True
525 isDivOp IntRemOp = True
526 isDivOp WordQuotOp = True
527 isDivOp WordRemOp = True
528 isDivOp IntegerQuotRemOp = True
529 isDivOp IntegerDivModOp = True
530 isDivOp FloatDivOp = True
531 isDivOp DoubleDivOp = True
532 isDivOp other = False
537 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
538 exprIsBottom e = go 0 e
540 -- n is the number of args
541 go n (Note _ e) = go n e
542 go n (Let _ e) = go n e
543 go n (Case e _ _) = go 0 e -- Just check the scrut
544 go n (App e _) = go (n+1) e
545 go n (Var v) = idAppIsBottom v n
547 go n (Lam _ _) = False
549 idAppIsBottom :: Id -> Int -> Bool
550 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
553 @exprIsValue@ returns true for expressions that are certainly *already*
554 evaluated to *head* normal form. This is used to decide whether it's ok
557 case x of _ -> e ===> e
559 and to decide whether it's safe to discard a `seq`
561 So, it does *not* treat variables as evaluated, unless they say they are.
563 But it *does* treat partial applications and constructor applications
564 as values, even if their arguments are non-trivial, provided the argument
566 e.g. (:) (f x) (map f xs) is a value
567 map (...redex...) is a value
568 Because `seq` on such things completes immediately
570 For unlifted argument types, we have to be careful:
572 Suppose (f x) diverges; then C (f x) is not a value. True, but
573 this form is illegal (see the invariants in CoreSyn). Args of unboxed
574 type must be ok-for-speculation (or trivial).
577 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
578 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
580 exprIsValue (Lit l) = True
581 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
582 exprIsValue (Note _ e) = exprIsValue e
583 exprIsValue (Var v) = idArity v > 0 || isEvaldUnfolding (idUnfolding v)
584 -- The idArity case catches data cons and primops that
585 -- don't have unfoldings
586 -- A worry: what if an Id's unfolding is just itself:
587 -- then we could get an infinite loop...
588 exprIsValue other_expr
589 | (Var fun, args) <- collectArgs other_expr,
590 isDataConId fun || valArgCount args < idArity fun
591 = check (idType fun) args
595 -- 'check' checks that unlifted-type args are in
596 -- fact guaranteed non-divergent
597 check fun_ty [] = True
598 check fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
599 Just (_, ty) -> check ty args
600 check fun_ty (arg : args)
601 | isUnLiftedType arg_ty = exprOkForSpeculation arg
602 | otherwise = check res_ty args
604 (arg_ty, res_ty) = splitFunTy fun_ty
608 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
609 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
610 = -- Maybe this is over the top, but here we try to turn
611 -- coerce (S,T) ( x, y )
613 -- ( coerce S x, coerce T y )
614 -- This happens in anger in PrelArrExts which has a coerce
615 -- case coerce memcpy a b of
617 -- where the memcpy is in the IO monad, but the call is in
619 case exprIsConApp_maybe expr of {
623 case splitTyConApp_maybe to_ty of {
625 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
626 | isExistentialDataCon dc -> Nothing
628 -- Type constructor must match
629 -- We knock out existentials to keep matters simple(r)
631 arity = tyConArity tc
632 val_args = drop arity args
633 to_arg_tys = dataConArgTys dc tc_arg_tys
634 mk_coerce ty arg = mkCoerce ty arg
635 new_val_args = zipWith mk_coerce to_arg_tys val_args
637 ASSERT( all isTypeArg (take arity args) )
638 ASSERT( equalLength val_args to_arg_tys )
639 Just (dc, map Type tc_arg_tys ++ new_val_args)
642 exprIsConApp_maybe (Note _ expr)
643 = exprIsConApp_maybe expr
644 -- We ignore InlineMe notes in case we have
645 -- x = __inline_me__ (a,b)
646 -- All part of making sure that INLINE pragmas never hurt
647 -- Marcin tripped on this one when making dictionaries more inlinable
649 -- In fact, we ignore all notes. For example,
650 -- case _scc_ "foo" (C a b) of
652 -- should be optimised away, but it will be only if we look
653 -- through the SCC note.
655 exprIsConApp_maybe expr = analyse (collectArgs expr)
657 analyse (Var fun, args)
658 | Just con <- isDataConId_maybe fun,
659 args `lengthAtLeast` dataConRepArity con
660 -- Might be > because the arity excludes type args
663 -- Look through unfoldings, but only cheap ones, because
664 -- we are effectively duplicating the unfolding
665 analyse (Var fun, [])
666 | let unf = idUnfolding fun,
668 = exprIsConApp_maybe (unfoldingTemplate unf)
670 analyse other = Nothing
675 %************************************************************************
677 \subsection{Eta reduction and expansion}
679 %************************************************************************
682 exprEtaExpandArity :: CoreExpr -> Arity
683 -- The Int is number of value args the thing can be
684 -- applied to without doing much work
686 -- This is used when eta expanding
687 -- e ==> \xy -> e x y
689 -- It returns 1 (or more) to:
690 -- case x of p -> \s -> ...
691 -- because for I/O ish things we really want to get that \s to the top.
692 -- We are prepared to evaluate x each time round the loop in order to get that
694 -- It's all a bit more subtle than it looks. Consider one-shot lambdas
695 -- let x = expensive in \y z -> E
696 -- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
697 -- Hence the ArityType returned by arityType
699 -- NB: this is particularly important/useful for IO state
700 -- transformers, where we often get
701 -- let x = E in \ s -> ...
702 -- and the \s is a real-world state token abstraction. Such
703 -- abstractions are almost invariably 1-shot, so we want to
704 -- pull the \s out, past the let x=E.
705 -- The hack is in Id.isOneShotLambda
708 -- f = \x -> error "foo"
709 -- Here, arity 1 is fine. But if it is
710 -- f = \x -> case e of
711 -- True -> error "foo"
712 -- False -> \y -> x+y
713 -- then we want to get arity 2.
714 -- Hence the ABot/ATop in ArityType
717 exprEtaExpandArity e = arityDepth (arityType e)
719 -- A limited sort of function type
720 data ArityType = AFun Bool ArityType -- True <=> one-shot
721 | ATop -- Know nothing
724 arityDepth :: ArityType -> Arity
725 arityDepth (AFun _ ty) = 1 + arityDepth ty
728 andArityType ABot at2 = at2
729 andArityType ATop at2 = ATop
730 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
731 andArityType at1 at2 = andArityType at2 at1
733 arityType :: CoreExpr -> ArityType
734 -- (go1 e) = [b1,..,bn]
735 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
736 -- where bi is True <=> the lambda is one-shot
738 arityType (Note n e) = arityType e
739 -- Not needed any more: etaExpand is cleverer
740 -- | ok_note n = arityType e
741 -- | otherwise = ATop
746 mk :: Arity -> ArityType
747 mk 0 | isBottomingId v = ABot
749 mk n = AFun False (mk (n-1))
751 -- When the type of the Id encodes one-shot-ness,
752 -- use the idinfo here
754 -- Lambdas; increase arity
755 arityType (Lam x e) | isId x = AFun (isOneShotLambda x) (arityType e)
756 | otherwise = arityType e
758 -- Applications; decrease arity
759 arityType (App f (Type _)) = arityType f
760 arityType (App f a) = case arityType f of
761 AFun one_shot xs | one_shot -> xs
762 | exprIsCheap a -> xs
765 -- Case/Let; keep arity if either the expression is cheap
766 -- or it's a 1-shot lambda
767 arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
768 xs@(AFun one_shot _) | one_shot -> xs
769 xs | exprIsCheap scrut -> xs
772 arityType (Let b e) = case arityType e of
773 xs@(AFun one_shot _) | one_shot -> xs
774 xs | all exprIsCheap (rhssOfBind b) -> xs
777 arityType other = ATop
779 {- NOT NEEDED ANY MORE: etaExpand is cleverer
780 ok_note InlineMe = False
782 -- Notice that we do not look through __inline_me__
783 -- This may seem surprising, but consider
784 -- f = _inline_me (\x -> e)
785 -- We DO NOT want to eta expand this to
786 -- f = \x -> (_inline_me (\x -> e)) x
787 -- because the _inline_me gets dropped now it is applied,
796 etaExpand :: Arity -- Result should have this number of value args
798 -> CoreExpr -> Type -- Expression and its type
800 -- (etaExpand n us e ty) returns an expression with
801 -- the same meaning as 'e', but with arity 'n'.
803 -- Given e' = etaExpand n us e ty
805 -- ty = exprType e = exprType e'
807 -- Note that SCCs are not treated specially. If we have
808 -- etaExpand 2 (\x -> scc "foo" e)
809 -- = (\xy -> (scc "foo" e) y)
810 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
812 etaExpand n us expr ty
813 | manifestArity expr >= n = expr -- The no-op case
814 | otherwise = eta_expand n us expr ty
817 -- manifestArity sees how many leading value lambdas there are
818 manifestArity :: CoreExpr -> Arity
819 manifestArity (Lam v e) | isId v = 1 + manifestArity e
820 | otherwise = manifestArity e
821 manifestArity (Note _ e) = manifestArity e
824 -- etaExpand deals with for-alls. For example:
826 -- where E :: forall a. a -> a
828 -- (/\b. \y::a -> E b y)
830 -- It deals with coerces too, though they are now rare
831 -- so perhaps the extra code isn't worth it
833 eta_expand n us expr ty
835 -- The ILX code generator requires eta expansion for type arguments
836 -- too, but alas the 'n' doesn't tell us how many of them there
837 -- may be. So we eagerly eta expand any big lambdas, and just
838 -- cross our fingers about possible loss of sharing in the ILX case.
839 -- The Right Thing is probably to make 'arity' include
840 -- type variables throughout the compiler. (ToDo.)
842 -- Saturated, so nothing to do
845 -- Short cut for the case where there already
846 -- is a lambda; no point in gratuitously adding more
847 eta_expand n us (Lam v body) ty
849 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
852 = Lam v (eta_expand (n-1) us body (funResultTy ty))
854 -- We used to have a special case that stepped inside Coerces here,
855 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
856 -- = Note note (eta_expand n us e ty)
857 -- BUT this led to an infinite loop
858 -- Example: newtype T = MkT (Int -> Int)
859 -- eta_expand 1 (coerce (Int->Int) e)
860 -- --> coerce (Int->Int) (eta_expand 1 T e)
862 -- --> coerce (Int->Int) (coerce T
863 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
864 -- by the splitNewType_maybe case below
867 eta_expand n us expr ty
868 = case splitForAllTy_maybe ty of {
869 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
873 case splitFunTy_maybe ty of {
874 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
876 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
882 -- newtype T = MkT (Int -> Int)
883 -- Consider eta-expanding this
886 -- coerce T (\x::Int -> (coerce (Int->Int) e) x)
888 case splitNewType_maybe ty of {
889 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
890 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
894 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
895 It tells how many things the expression can be applied to before doing
896 any work. It doesn't look inside cases, lets, etc. The idea is that
897 exprEtaExpandArity will do the hard work, leaving something that's easy
898 for exprArity to grapple with. In particular, Simplify uses exprArity to
899 compute the ArityInfo for the Id.
901 Originally I thought that it was enough just to look for top-level lambdas, but
902 it isn't. I've seen this
904 foo = PrelBase.timesInt
906 We want foo to get arity 2 even though the eta-expander will leave it
907 unchanged, in the expectation that it'll be inlined. But occasionally it
908 isn't, because foo is blacklisted (used in a rule).
910 Similarly, see the ok_note check in exprEtaExpandArity. So
911 f = __inline_me (\x -> e)
912 won't be eta-expanded.
914 And in any case it seems more robust to have exprArity be a bit more intelligent.
915 But note that (\x y z -> f x y z)
916 should have arity 3, regardless of f's arity.
919 exprArity :: CoreExpr -> Arity
922 go (Var v) = idArity v
923 go (Lam x e) | isId x = go e + 1
926 go (App e (Type t)) = go e
927 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
928 -- NB: exprIsCheap a!
929 -- f (fac x) does not have arity 2,
930 -- even if f has arity 3!
931 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
932 -- unknown, hence arity 0
936 %************************************************************************
938 \subsection{Equality}
940 %************************************************************************
942 @cheapEqExpr@ is a cheap equality test which bales out fast!
943 True => definitely equal
944 False => may or may not be equal
947 cheapEqExpr :: Expr b -> Expr b -> Bool
949 cheapEqExpr (Var v1) (Var v2) = v1==v2
950 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
951 cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
953 cheapEqExpr (App f1 a1) (App f2 a2)
954 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
956 cheapEqExpr _ _ = False
958 exprIsBig :: Expr b -> Bool
959 -- Returns True of expressions that are too big to be compared by cheapEqExpr
960 exprIsBig (Lit _) = False
961 exprIsBig (Var v) = False
962 exprIsBig (Type t) = False
963 exprIsBig (App f a) = exprIsBig f || exprIsBig a
964 exprIsBig other = True
969 eqExpr :: CoreExpr -> CoreExpr -> Bool
970 -- Works ok at more general type, but only needed at CoreExpr
971 -- Used in rule matching, so when we find a type we use
972 -- eqTcType, which doesn't look through newtypes
973 -- [And it doesn't risk falling into a black hole either.]
975 = eq emptyVarEnv e1 e2
977 -- The "env" maps variables in e1 to variables in ty2
978 -- So when comparing lambdas etc,
979 -- we in effect substitute v2 for v1 in e1 before continuing
980 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
981 Just v1' -> v1' == v2
984 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
985 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
986 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
987 eq env (Let (NonRec v1 r1) e1)
988 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
989 eq env (Let (Rec ps1) e1)
990 (Let (Rec ps2) e2) = equalLength ps1 ps2 &&
991 and (zipWith eq_rhs ps1 ps2) &&
994 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
995 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
996 eq env (Case e1 v1 a1)
997 (Case e2 v2 a2) = eq env e1 e2 &&
999 and (zipWith (eq_alt env') a1 a2)
1001 env' = extendVarEnv env v1 v2
1003 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
1004 eq env (Type t1) (Type t2) = t1 `eqType` t2
1005 eq env e1 e2 = False
1007 eq_list env [] [] = True
1008 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
1009 eq_list env es1 es2 = False
1011 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
1012 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
1014 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1015 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
1016 eq_note env InlineCall InlineCall = True
1017 eq_note env other1 other2 = False
1021 %************************************************************************
1023 \subsection{The size of an expression}
1025 %************************************************************************
1028 coreBindsSize :: [CoreBind] -> Int
1029 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1031 exprSize :: CoreExpr -> Int
1032 -- A measure of the size of the expressions
1033 -- It also forces the expression pretty drastically as a side effect
1034 exprSize (Var v) = v `seq` 1
1035 exprSize (Lit lit) = lit `seq` 1
1036 exprSize (App f a) = exprSize f + exprSize a
1037 exprSize (Lam b e) = varSize b + exprSize e
1038 exprSize (Let b e) = bindSize b + exprSize e
1039 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
1040 exprSize (Note n e) = noteSize n + exprSize e
1041 exprSize (Type t) = seqType t `seq` 1
1043 noteSize (SCC cc) = cc `seq` 1
1044 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1045 noteSize InlineCall = 1
1046 noteSize InlineMe = 1
1048 varSize :: Var -> Int
1049 varSize b | isTyVar b = 1
1050 | otherwise = seqType (idType b) `seq`
1051 megaSeqIdInfo (idInfo b) `seq`
1054 varsSize = foldr ((+) . varSize) 0
1056 bindSize (NonRec b e) = varSize b + exprSize e
1057 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1059 pairSize (b,e) = varSize b + exprSize e
1061 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1065 %************************************************************************
1067 \subsection{Hashing}
1069 %************************************************************************
1072 hashExpr :: CoreExpr -> Int
1073 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1076 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1078 hash_expr (Note _ e) = hash_expr e
1079 hash_expr (Let (NonRec b r) e) = hashId b
1080 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1081 hash_expr (Case _ b _) = hashId b
1082 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1083 hash_expr (Var v) = hashId v
1084 hash_expr (Lit lit) = hashLiteral lit
1085 hash_expr (Lam b _) = hashId b
1086 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1088 fast_hash_expr (Var v) = hashId v
1089 fast_hash_expr (Lit lit) = hashLiteral lit
1090 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1091 fast_hash_expr (App f a) = fast_hash_expr a
1092 fast_hash_expr (Lam b _) = hashId b
1093 fast_hash_expr other = 1
1096 hashId id = hashName (idName id)