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, 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, idLBVarInfo,
52 mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
53 isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId
55 import IdInfo ( LBVarInfo(..),
58 import NewDemand ( appIsBottom )
59 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
60 applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
61 splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
62 splitTyConApp_maybe, eqType, funResultTy, applyTy,
65 import TyCon ( tyConArity )
66 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
67 import CostCentre ( CostCentre )
68 import BasicTypes ( Arity )
69 import Unique ( Unique )
71 import TysPrim ( alphaTy ) -- Debugging only
72 import Util ( equalLength, lengthAtLeast )
76 %************************************************************************
78 \subsection{Find the type of a Core atom/expression}
80 %************************************************************************
83 exprType :: CoreExpr -> Type
85 exprType (Var var) = idType var
86 exprType (Lit lit) = literalType lit
87 exprType (Let _ body) = exprType body
88 exprType (Case _ _ alts) = coreAltsType alts
89 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
90 exprType (Note other_note e) = exprType e
91 exprType (Lam binder expr) = mkPiType binder (exprType expr)
93 = case collectArgs e of
94 (fun, args) -> applyTypeToArgs e (exprType fun) args
96 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
98 coreAltsType :: [CoreAlt] -> Type
99 coreAltsType ((_,_,rhs) : _) = exprType rhs
102 @mkPiType@ makes a (->) type or a forall type, depending on whether
103 it is given a type variable or a term variable. We cleverly use the
104 lbvarinfo field to figure out the right annotation for the arrove in
105 case of a term variable.
108 mkPiType :: Var -> Type -> Type -- The more polymorphic version
109 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
111 mkPiTypes vs ty = foldr mkPiType ty vs
114 | isId v = add_usage (mkFunTy (idType v) ty)
115 | otherwise = mkForAllTy v ty
117 add_usage ty = case idLBVarInfo v of
118 LBVarInfo u -> mkUTy u ty
123 applyTypeToArg :: Type -> CoreExpr -> Type
124 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
125 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
127 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
128 -- A more efficient version of applyTypeToArg
129 -- when we have several args
130 -- The first argument is just for debugging
131 applyTypeToArgs e op_ty [] = op_ty
133 applyTypeToArgs e op_ty (Type ty : args)
134 = -- Accumulate type arguments so we can instantiate all at once
137 go rev_tys (Type ty : args) = go (ty:rev_tys) args
138 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
140 op_ty' = applyTys op_ty (reverse rev_tys)
142 applyTypeToArgs e op_ty (other_arg : args)
143 = case (splitFunTy_maybe op_ty) of
144 Just (_, res_ty) -> applyTypeToArgs e res_ty args
145 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
150 %************************************************************************
152 \subsection{Attaching notes}
154 %************************************************************************
156 mkNote removes redundant coercions, and SCCs where possible
159 mkNote :: Note -> CoreExpr -> CoreExpr
160 mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr
161 mkNote (SCC cc) expr = mkSCC cc expr
162 mkNote InlineMe expr = mkInlineMe expr
163 mkNote note expr = Note note expr
165 -- Slide InlineCall in around the function
166 -- No longer necessary I think (SLPJ Apr 99)
167 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
168 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
169 -- mkNote InlineCall expr = expr
172 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
173 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
174 not be *applied* to anything.
176 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
179 f = inline_me (coerce t fw)
180 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
181 We want the split, so that the coerces can cancel at the call site.
183 However, we can get left with tiresome type applications. Notably, consider
184 f = /\ a -> let t = e in (t, w)
185 Then lifting the let out of the big lambda gives
187 f = /\ a -> let t = inline_me (t' a) in (t, w)
188 The inline_me is to stop the simplifier inlining t' right back
189 into t's RHS. In the next phase we'll substitute for t (since
190 its rhs is trivial) and *then* we could get rid of the inline_me.
191 But it hardly seems worth it, so I don't bother.
194 mkInlineMe (Var v) = Var v
195 mkInlineMe e = Note InlineMe e
201 mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
203 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
204 = ASSERT( from_ty `eqType` to_ty2 )
205 mkCoerce to_ty from_ty2 expr
207 mkCoerce to_ty from_ty expr
208 | to_ty `eqType` from_ty = expr
209 | otherwise = ASSERT( from_ty `eqType` exprType expr )
210 Note (Coerce to_ty from_ty) expr
214 mkSCC :: CostCentre -> Expr b -> Expr b
215 -- Note: Nested SCC's *are* preserved for the benefit of
216 -- cost centre stack profiling
217 mkSCC cc (Lit lit) = Lit lit
218 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
219 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
220 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
221 mkSCC cc expr = Note (SCC cc) expr
225 %************************************************************************
227 \subsection{Other expression construction}
229 %************************************************************************
232 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
233 -- (bindNonRec x r b) produces either
236 -- case r of x { _DEFAULT_ -> b }
238 -- depending on whether x is unlifted or not
239 -- It's used by the desugarer to avoid building bindings
240 -- that give Core Lint a heart attack. Actually the simplifier
241 -- deals with them perfectly well.
242 bindNonRec bndr rhs body
243 | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
244 | otherwise = Let (NonRec bndr rhs) body
246 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
247 -- Make a case expression instead of a let
248 -- These can arise either from the desugarer,
249 -- or from beta reductions: (\x.e) (x +# y)
253 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
254 -- This guy constructs the value that the scrutinee must have
255 -- when you are in one particular branch of a case
256 mkAltExpr (DataAlt con) args inst_tys
257 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
258 mkAltExpr (LitAlt lit) [] []
261 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
262 mkIfThenElse guard then_expr else_expr
263 = Case guard (mkWildId boolTy)
264 [ (DataAlt trueDataCon, [], then_expr),
265 (DataAlt falseDataCon, [], else_expr) ]
269 %************************************************************************
271 \subsection{Taking expressions apart}
273 %************************************************************************
275 The default alternative must be first, if it exists at all.
276 This makes it easy to find, though it makes matching marginally harder.
279 hasDefault :: [CoreAlt] -> Bool
280 hasDefault ((DEFAULT,_,_) : alts) = True
283 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
284 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
285 findDefault alts = (alts, Nothing)
287 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
290 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
291 other -> go alts panic_deflt
294 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
297 go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
298 | otherwise = ASSERT( not (con1 == DEFAULT) )
303 %************************************************************************
305 \subsection{Figuring out things about expressions}
307 %************************************************************************
309 @exprIsTrivial@ is true of expressions we are unconditionally happy to
310 duplicate; simple variables and constants, and type
311 applications. Note that primop Ids aren't considered
314 @exprIsBottom@ is true of expressions that are guaranteed to diverge
317 There used to be a gruesome test for (hasNoBinding v) in the
319 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
320 The idea here is that a constructor worker, like $wJust, is
321 really short for (\x -> $wJust x), becuase $wJust has no binding.
322 So it should be treated like a lambda. Ditto unsaturated primops.
323 But now constructor workers are not "have-no-binding" Ids. And
324 completely un-applied primops and foreign-call Ids are sufficiently
325 rare that I plan to allow them to be duplicated and put up with
329 exprIsTrivial (Var v) = True -- See notes above
330 exprIsTrivial (Type _) = True
331 exprIsTrivial (Lit lit) = True
332 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
333 exprIsTrivial (Note _ e) = exprIsTrivial e
334 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
335 exprIsTrivial other = False
337 exprIsAtom :: CoreExpr -> Bool
338 -- Used to decide whether to let-binding an STG argument
339 -- when compiling to ILX => type applications are not allowed
340 exprIsAtom (Var v) = True -- primOpIsDupable?
341 exprIsAtom (Lit lit) = True
342 exprIsAtom (Type ty) = True
343 exprIsAtom (Note (SCC _) e) = False
344 exprIsAtom (Note _ e) = exprIsAtom e
345 exprIsAtom other = False
349 @exprIsDupable@ is true of expressions that can be duplicated at a modest
350 cost in code size. This will only happen in different case
351 branches, so there's no issue about duplicating work.
353 That is, exprIsDupable returns True of (f x) even if
354 f is very very expensive to call.
356 Its only purpose is to avoid fruitless let-binding
357 and then inlining of case join points
361 exprIsDupable (Type _) = True
362 exprIsDupable (Var v) = True
363 exprIsDupable (Lit lit) = litIsDupable lit
364 exprIsDupable (Note InlineMe e) = True
365 exprIsDupable (Note _ e) = exprIsDupable e
369 go (Var v) n_args = True
370 go (App f a) n_args = n_args < dupAppSize
373 go other n_args = False
376 dupAppSize = 4 -- Size of application we are prepared to duplicate
379 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
380 it is obviously in weak head normal form, or is cheap to get to WHNF.
381 [Note that that's not the same as exprIsDupable; an expression might be
382 big, and hence not dupable, but still cheap.]
384 By ``cheap'' we mean a computation we're willing to:
385 push inside a lambda, or
386 inline at more than one place
387 That might mean it gets evaluated more than once, instead of being
388 shared. The main examples of things which aren't WHNF but are
393 (where e, and all the ei are cheap)
396 (where e and b are cheap)
399 (where op is a cheap primitive operator)
402 (because we are happy to substitute it inside a lambda)
404 Notice that a variable is considered 'cheap': we can push it inside a lambda,
405 because sharing will make sure it is only evaluated once.
408 exprIsCheap :: CoreExpr -> Bool
409 exprIsCheap (Lit lit) = True
410 exprIsCheap (Type _) = True
411 exprIsCheap (Var _) = True
412 exprIsCheap (Note InlineMe e) = True
413 exprIsCheap (Note _ e) = exprIsCheap e
414 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
415 exprIsCheap (Case e _ alts) = exprIsCheap e &&
416 and [exprIsCheap rhs | (_,_,rhs) <- alts]
417 -- Experimentally, treat (case x of ...) as cheap
418 -- (and case __coerce x etc.)
419 -- This improves arities of overloaded functions where
420 -- there is only dictionary selection (no construction) involved
421 exprIsCheap (Let (NonRec x _) e)
422 | isUnLiftedType (idType x) = exprIsCheap e
424 -- strict lets always have cheap right hand sides, and
427 exprIsCheap other_expr
428 = go other_expr 0 True
430 go (Var f) n_args args_cheap
431 = (idAppIsCheap f n_args && args_cheap)
432 -- A constructor, cheap primop, or partial application
434 || idAppIsBottom f n_args
435 -- Application of a function which
436 -- always gives bottom; we treat this as cheap
437 -- because it certainly doesn't need to be shared!
439 go (App f a) n_args args_cheap
440 | not (isRuntimeArg a) = go f n_args args_cheap
441 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
443 go other n_args args_cheap = False
445 idAppIsCheap :: Id -> Int -> Bool
446 idAppIsCheap id n_val_args
447 | n_val_args == 0 = True -- Just a type application of
448 -- a variable (f t1 t2 t3)
450 | otherwise = case globalIdDetails id of
452 RecordSelId _ -> True -- I'm experimenting with making record selection
453 -- look cheap, so we will substitute it inside a
454 -- lambda. Particularly for dictionary field selection
456 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
457 -- that return a type variable, since the result
458 -- might be applied to something, but I'm not going
459 -- to bother to check the number of args
460 other -> n_val_args < idArity id
463 exprOkForSpeculation returns True of an expression that it is
465 * safe to evaluate even if normal order eval might not
466 evaluate the expression at all, or
468 * safe *not* to evaluate even if normal order would do so
472 the expression guarantees to terminate,
474 without raising an exception,
475 without causing a side effect (e.g. writing a mutable variable)
478 let x = case y# +# 1# of { r# -> I# r# }
481 case y# +# 1# of { r# ->
486 We can only do this if the (y+1) is ok for speculation: it has no
487 side effects, and can't diverge or raise an exception.
490 exprOkForSpeculation :: CoreExpr -> Bool
491 exprOkForSpeculation (Lit _) = True
492 exprOkForSpeculation (Type _) = True
493 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
494 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
495 exprOkForSpeculation other_expr
496 = case collectArgs other_expr of
497 (Var f, args) -> spec_ok (globalIdDetails f) args
501 spec_ok (DataConId _) args
502 = True -- The strictness of the constructor has already
503 -- been expressed by its "wrapper", so we don't need
504 -- to take the arguments into account
506 spec_ok (PrimOpId op) args
507 | isDivOp op, -- Special case for dividing operations that fail
508 [arg1, Lit lit] <- args -- only if the divisor is zero
509 = not (isZeroLit lit) && exprOkForSpeculation arg1
510 -- Often there is a literal divisor, and this
511 -- can get rid of a thunk in an inner looop
514 = primOpOkForSpeculation op &&
515 all exprOkForSpeculation args
516 -- A bit conservative: we don't really need
517 -- to care about lazy arguments, but this is easy
519 spec_ok other args = False
521 isDivOp :: PrimOp -> Bool
522 -- True of dyadic operators that can fail
523 -- only if the second arg is zero
524 -- This function probably belongs in PrimOp, or even in
525 -- an automagically generated file.. but it's such a
526 -- special case I thought I'd leave it here for now.
527 isDivOp IntQuotOp = True
528 isDivOp IntRemOp = True
529 isDivOp WordQuotOp = True
530 isDivOp WordRemOp = True
531 isDivOp IntegerQuotRemOp = True
532 isDivOp IntegerDivModOp = True
533 isDivOp FloatDivOp = True
534 isDivOp DoubleDivOp = True
535 isDivOp other = False
540 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
541 exprIsBottom e = go 0 e
543 -- n is the number of args
544 go n (Note _ e) = go n e
545 go n (Let _ e) = go n e
546 go n (Case e _ _) = go 0 e -- Just check the scrut
547 go n (App e _) = go (n+1) e
548 go n (Var v) = idAppIsBottom v n
550 go n (Lam _ _) = False
552 idAppIsBottom :: Id -> Int -> Bool
553 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
556 @exprIsValue@ returns true for expressions that are certainly *already*
557 evaluated to *head* normal form. This is used to decide whether it's ok
560 case x of _ -> e ===> e
562 and to decide whether it's safe to discard a `seq`
564 So, it does *not* treat variables as evaluated, unless they say they are.
566 But it *does* treat partial applications and constructor applications
567 as values, even if their arguments are non-trivial, provided the argument
569 e.g. (:) (f x) (map f xs) is a value
570 map (...redex...) is a value
571 Because `seq` on such things completes immediately
573 For unlifted argument types, we have to be careful:
575 Suppose (f x) diverges; then C (f x) is not a value. True, but
576 this form is illegal (see the invariants in CoreSyn). Args of unboxed
577 type must be ok-for-speculation (or trivial).
580 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
581 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
583 exprIsValue (Lit l) = True
584 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
585 exprIsValue (Note _ e) = exprIsValue e
586 exprIsValue (Var v) = idArity v > 0 || isEvaldUnfolding (idUnfolding v)
587 -- The idArity case catches data cons and primops that
588 -- don't have unfoldings
589 -- A worry: what if an Id's unfolding is just itself:
590 -- then we could get an infinite loop...
591 exprIsValue other_expr
592 | (Var fun, args) <- collectArgs other_expr,
593 isDataConId fun || valArgCount args < idArity fun
594 = check (idType fun) args
598 -- 'check' checks that unlifted-type args are in
599 -- fact guaranteed non-divergent
600 check fun_ty [] = True
601 check fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
602 Just (_, ty) -> check ty args
603 check fun_ty (arg : args)
604 | isUnLiftedType arg_ty = exprOkForSpeculation arg
605 | otherwise = check res_ty args
607 (arg_ty, res_ty) = splitFunTy fun_ty
611 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
612 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
613 = -- Maybe this is over the top, but here we try to turn
614 -- coerce (S,T) ( x, y )
616 -- ( coerce S x, coerce T y )
617 -- This happens in anger in PrelArrExts which has a coerce
618 -- case coerce memcpy a b of
620 -- where the memcpy is in the IO monad, but the call is in
622 case exprIsConApp_maybe expr of {
626 case splitTyConApp_maybe to_ty of {
628 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
629 | isExistentialDataCon dc -> Nothing
631 -- Type constructor must match
632 -- We knock out existentials to keep matters simple(r)
634 arity = tyConArity tc
635 val_args = drop arity args
636 to_arg_tys = dataConArgTys dc tc_arg_tys
637 mk_coerce ty arg = mkCoerce ty (exprType arg) arg
638 new_val_args = zipWith mk_coerce to_arg_tys val_args
640 ASSERT( all isTypeArg (take arity args) )
641 ASSERT( equalLength val_args to_arg_tys )
642 Just (dc, map Type tc_arg_tys ++ new_val_args)
645 exprIsConApp_maybe (Note _ expr)
646 = exprIsConApp_maybe expr
647 -- We ignore InlineMe notes in case we have
648 -- x = __inline_me__ (a,b)
649 -- All part of making sure that INLINE pragmas never hurt
650 -- Marcin tripped on this one when making dictionaries more inlinable
652 -- In fact, we ignore all notes. For example,
653 -- case _scc_ "foo" (C a b) of
655 -- should be optimised away, but it will be only if we look
656 -- through the SCC note.
658 exprIsConApp_maybe expr = analyse (collectArgs expr)
660 analyse (Var fun, args)
661 | Just con <- isDataConId_maybe fun,
662 args `lengthAtLeast` dataConRepArity con
663 -- Might be > because the arity excludes type args
666 -- Look through unfoldings, but only cheap ones, because
667 -- we are effectively duplicating the unfolding
668 analyse (Var fun, [])
669 | let unf = idUnfolding fun,
671 = exprIsConApp_maybe (unfoldingTemplate unf)
673 analyse other = Nothing
678 %************************************************************************
680 \subsection{Eta reduction and expansion}
682 %************************************************************************
685 exprEtaExpandArity :: CoreExpr -> Arity
686 -- The Int is number of value args the thing can be
687 -- applied to without doing much work
689 -- This is used when eta expanding
690 -- e ==> \xy -> e x y
692 -- It returns 1 (or more) to:
693 -- case x of p -> \s -> ...
694 -- because for I/O ish things we really want to get that \s to the top.
695 -- We are prepared to evaluate x each time round the loop in order to get that
697 -- It's all a bit more subtle than it looks. Consider one-shot lambdas
698 -- let x = expensive in \y z -> E
699 -- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
700 -- Hence the ArityType returned by arityType
702 -- NB: this is particularly important/useful for IO state
703 -- transformers, where we often get
704 -- let x = E in \ s -> ...
705 -- and the \s is a real-world state token abstraction. Such
706 -- abstractions are almost invariably 1-shot, so we want to
707 -- pull the \s out, past the let x=E.
708 -- The hack is in Id.isOneShotLambda
711 -- f = \x -> error "foo"
712 -- Here, arity 1 is fine. But if it is
713 -- f = \x -> case e of
714 -- True -> error "foo"
715 -- False -> \y -> x+y
716 -- then we want to get arity 2.
717 -- Hence the ABot/ATop in ArityType
720 exprEtaExpandArity e = arityDepth (arityType e)
722 -- A limited sort of function type
723 data ArityType = AFun Bool ArityType -- True <=> one-shot
724 | ATop -- Know nothing
727 arityDepth :: ArityType -> Arity
728 arityDepth (AFun _ ty) = 1 + arityDepth ty
731 andArityType ABot at2 = at2
732 andArityType ATop at2 = ATop
733 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
734 andArityType at1 at2 = andArityType at2 at1
736 arityType :: CoreExpr -> ArityType
737 -- (go1 e) = [b1,..,bn]
738 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
739 -- where bi is True <=> the lambda is one-shot
741 arityType (Note n e) = arityType e
742 -- Not needed any more: etaExpand is cleverer
743 -- | ok_note n = arityType e
744 -- | otherwise = ATop
749 mk :: Arity -> ArityType
750 mk 0 | isBottomingId v = ABot
752 mk n = AFun False (mk (n-1))
754 -- When the type of the Id encodes one-shot-ness,
755 -- use the idinfo here
757 -- Lambdas; increase arity
758 arityType (Lam x e) | isId x = AFun (isOneShotLambda x) (arityType e)
759 | otherwise = arityType e
761 -- Applications; decrease arity
762 arityType (App f (Type _)) = arityType f
763 arityType (App f a) = case arityType f of
764 AFun one_shot xs | one_shot -> xs
765 | exprIsCheap a -> xs
768 -- Case/Let; keep arity if either the expression is cheap
769 -- or it's a 1-shot lambda
770 arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
771 xs@(AFun one_shot _) | one_shot -> xs
772 xs | exprIsCheap scrut -> xs
775 arityType (Let b e) = case arityType e of
776 xs@(AFun one_shot _) | one_shot -> xs
777 xs | all exprIsCheap (rhssOfBind b) -> xs
780 arityType other = ATop
782 {- NOT NEEDED ANY MORE: etaExpand is cleverer
783 ok_note InlineMe = False
785 -- Notice that we do not look through __inline_me__
786 -- This may seem surprising, but consider
787 -- f = _inline_me (\x -> e)
788 -- We DO NOT want to eta expand this to
789 -- f = \x -> (_inline_me (\x -> e)) x
790 -- because the _inline_me gets dropped now it is applied,
799 etaExpand :: Arity -- Result should have this number of value args
801 -> CoreExpr -> Type -- Expression and its type
803 -- (etaExpand n us e ty) returns an expression with
804 -- the same meaning as 'e', but with arity 'n'.
806 -- Given e' = etaExpand n us e ty
808 -- ty = exprType e = exprType e'
810 etaExpand n us expr ty
811 | manifestArity expr >= n = expr -- The no-op case
812 | otherwise = eta_expand n us expr ty
815 -- manifestArity sees how many leading value lambdas there are
816 manifestArity :: CoreExpr -> Arity
817 manifestArity (Lam v e) | isId v = 1 + manifestArity e
818 | otherwise = manifestArity e
819 manifestArity (Note _ e) = manifestArity e
822 -- etaExpand deals with for-alls. For example:
824 -- where E :: forall a. a -> a
826 -- (/\b. \y::a -> E b y)
828 -- It deals with coerces too, though they are now rare
829 -- so perhaps the extra code isn't worth it
831 eta_expand n us expr ty
833 -- The ILX code generator requires eta expansion for type arguments
834 -- too, but alas the 'n' doesn't tell us how many of them there
835 -- may be. So we eagerly eta expand any big lambdas, and just
836 -- cross our fingers about possible loss of sharing in the
838 -- The Right Thing is probably to make 'arity' include
839 -- type variables throughout the compiler. (ToDo.)
841 -- Saturated, so nothing to do
844 eta_expand n us (Note note@(Coerce _ ty) e) _
845 = Note note (eta_expand n us e ty)
847 -- Use mkNote so that _scc_s get pushed inside any lambdas that
848 -- are generated as part of the eta expansion. We rely on this
849 -- behaviour in CorePrep, when we eta expand an already-prepped RHS.
850 eta_expand n us (Note note e) ty
851 = mkNote note (eta_expand n us e ty)
853 -- Short cut for the case where there already
854 -- is a lambda; no point in gratuitously adding more
855 eta_expand n us (Lam v body) ty
857 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
860 = Lam v (eta_expand (n-1) us body (funResultTy ty))
862 eta_expand n us expr ty
863 = case splitForAllTy_maybe ty of {
864 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
868 case splitFunTy_maybe ty of {
869 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
871 arg1 = mkSysLocal SLIT("eta") uniq arg_ty
876 case splitNewType_maybe ty of {
877 Just ty' -> mkCoerce ty ty' (eta_expand n us (mkCoerce ty' ty expr) ty') ;
878 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
882 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
883 It tells how many things the expression can be applied to before doing
884 any work. It doesn't look inside cases, lets, etc. The idea is that
885 exprEtaExpandArity will do the hard work, leaving something that's easy
886 for exprArity to grapple with. In particular, Simplify uses exprArity to
887 compute the ArityInfo for the Id.
889 Originally I thought that it was enough just to look for top-level lambdas, but
890 it isn't. I've seen this
892 foo = PrelBase.timesInt
894 We want foo to get arity 2 even though the eta-expander will leave it
895 unchanged, in the expectation that it'll be inlined. But occasionally it
896 isn't, because foo is blacklisted (used in a rule).
898 Similarly, see the ok_note check in exprEtaExpandArity. So
899 f = __inline_me (\x -> e)
900 won't be eta-expanded.
902 And in any case it seems more robust to have exprArity be a bit more intelligent.
903 But note that (\x y z -> f x y z)
904 should have arity 3, regardless of f's arity.
907 exprArity :: CoreExpr -> Arity
910 go (Var v) = idArity v
911 go (Lam x e) | isId x = go e + 1
914 go (App e (Type t)) = go e
915 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
916 -- NB: exprIsCheap a!
917 -- f (fac x) does not have arity 2,
918 -- even if f has arity 3!
919 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
920 -- unknown, hence arity 0
924 %************************************************************************
926 \subsection{Equality}
928 %************************************************************************
930 @cheapEqExpr@ is a cheap equality test which bales out fast!
931 True => definitely equal
932 False => may or may not be equal
935 cheapEqExpr :: Expr b -> Expr b -> Bool
937 cheapEqExpr (Var v1) (Var v2) = v1==v2
938 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
939 cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
941 cheapEqExpr (App f1 a1) (App f2 a2)
942 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
944 cheapEqExpr _ _ = False
946 exprIsBig :: Expr b -> Bool
947 -- Returns True of expressions that are too big to be compared by cheapEqExpr
948 exprIsBig (Lit _) = False
949 exprIsBig (Var v) = False
950 exprIsBig (Type t) = False
951 exprIsBig (App f a) = exprIsBig f || exprIsBig a
952 exprIsBig other = True
957 eqExpr :: CoreExpr -> CoreExpr -> Bool
958 -- Works ok at more general type, but only needed at CoreExpr
959 -- Used in rule matching, so when we find a type we use
960 -- eqTcType, which doesn't look through newtypes
961 -- [And it doesn't risk falling into a black hole either.]
963 = eq emptyVarEnv e1 e2
965 -- The "env" maps variables in e1 to variables in ty2
966 -- So when comparing lambdas etc,
967 -- we in effect substitute v2 for v1 in e1 before continuing
968 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
969 Just v1' -> v1' == v2
972 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
973 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
974 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
975 eq env (Let (NonRec v1 r1) e1)
976 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
977 eq env (Let (Rec ps1) e1)
978 (Let (Rec ps2) e2) = equalLength ps1 ps2 &&
979 and (zipWith eq_rhs ps1 ps2) &&
982 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
983 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
984 eq env (Case e1 v1 a1)
985 (Case e2 v2 a2) = eq env e1 e2 &&
987 and (zipWith (eq_alt env') a1 a2)
989 env' = extendVarEnv env v1 v2
991 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
992 eq env (Type t1) (Type t2) = t1 `eqType` t2
995 eq_list env [] [] = True
996 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
997 eq_list env es1 es2 = False
999 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
1000 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
1002 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1003 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
1004 eq_note env InlineCall InlineCall = True
1005 eq_note env other1 other2 = False
1009 %************************************************************************
1011 \subsection{The size of an expression}
1013 %************************************************************************
1016 coreBindsSize :: [CoreBind] -> Int
1017 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1019 exprSize :: CoreExpr -> Int
1020 -- A measure of the size of the expressions
1021 -- It also forces the expression pretty drastically as a side effect
1022 exprSize (Var v) = v `seq` 1
1023 exprSize (Lit lit) = lit `seq` 1
1024 exprSize (App f a) = exprSize f + exprSize a
1025 exprSize (Lam b e) = varSize b + exprSize e
1026 exprSize (Let b e) = bindSize b + exprSize e
1027 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
1028 exprSize (Note n e) = noteSize n + exprSize e
1029 exprSize (Type t) = seqType t `seq` 1
1031 noteSize (SCC cc) = cc `seq` 1
1032 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1033 noteSize InlineCall = 1
1034 noteSize InlineMe = 1
1036 varSize :: Var -> Int
1037 varSize b | isTyVar b = 1
1038 | otherwise = seqType (idType b) `seq`
1039 megaSeqIdInfo (idInfo b) `seq`
1042 varsSize = foldr ((+) . varSize) 0
1044 bindSize (NonRec b e) = varSize b + exprSize e
1045 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1047 pairSize (b,e) = varSize b + exprSize e
1049 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1053 %************************************************************************
1055 \subsection{Hashing}
1057 %************************************************************************
1060 hashExpr :: CoreExpr -> Int
1061 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1064 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1066 hash_expr (Note _ e) = hash_expr e
1067 hash_expr (Let (NonRec b r) e) = hashId b
1068 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1069 hash_expr (Case _ b _) = hashId b
1070 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1071 hash_expr (Var v) = hashId v
1072 hash_expr (Lit lit) = hashLiteral lit
1073 hash_expr (Lam b _) = hashId b
1074 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1076 fast_hash_expr (Var v) = hashId v
1077 fast_hash_expr (Lit lit) = hashLiteral lit
1078 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1079 fast_hash_expr (App f a) = fast_hash_expr a
1080 fast_hash_expr (Lam b _) = hashId b
1081 fast_hash_expr other = 1
1084 hashId id = hashName (idName id)