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,
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, dataConArgTys, isExistentialDataCon, dataConTyCon )
52 import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
53 import Id ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo,
54 mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
55 isDataConId_maybe, mkSysLocal, hasNoBinding, isDataConId, isBottomingId
57 import IdInfo ( LBVarInfo(..),
60 import NewDemand ( appIsBottom )
61 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
62 applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
63 splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
64 splitTyConApp_maybe, eqType
66 import TyCon ( tyConArity )
67 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
68 import CostCentre ( CostCentre )
69 import BasicTypes ( Arity )
70 import Unique ( Unique )
72 import TysPrim ( alphaTy ) -- Debugging only
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 doesn't work...
109 mkPiType v ty | isId v = (case idLBVarInfo v of
110 LBVarInfo u -> mkUTy u
112 mkFunTy (idType v) ty
113 | isTyVar v = mkForAllTy v ty
117 -- The first argument is just for debugging
118 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
119 applyTypeToArgs e op_ty [] = op_ty
121 applyTypeToArgs e op_ty (Type ty : args)
122 = -- Accumulate type arguments so we can instantiate all at once
123 applyTypeToArgs e (applyTys op_ty tys) rest_args
125 (tys, rest_args) = go [ty] args
126 go tys (Type ty : args) = go (ty:tys) args
127 go tys rest_args = (reverse tys, rest_args)
129 applyTypeToArgs e op_ty (other_arg : args)
130 = case (splitFunTy_maybe op_ty) of
131 Just (_, res_ty) -> applyTypeToArgs e res_ty args
132 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
137 %************************************************************************
139 \subsection{Attaching notes}
141 %************************************************************************
143 mkNote removes redundant coercions, and SCCs where possible
146 mkNote :: Note -> CoreExpr -> CoreExpr
147 mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr
148 mkNote (SCC cc) expr = mkSCC cc expr
149 mkNote InlineMe expr = mkInlineMe expr
150 mkNote note expr = Note note expr
152 -- Slide InlineCall in around the function
153 -- No longer necessary I think (SLPJ Apr 99)
154 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
155 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
156 -- mkNote InlineCall expr = expr
159 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
160 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
161 not be *applied* to anything.
163 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
166 f = inline_me (coerce t fw)
167 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
168 We want the split, so that the coerces can cancel at the call site.
170 However, we can get left with tiresome type applications. Notably, consider
171 f = /\ a -> let t = e in (t, w)
172 Then lifting the let out of the big lambda gives
174 f = /\ a -> let t = inline_me (t' a) in (t, w)
175 The inline_me is to stop the simplifier inlining t' right back
176 into t's RHS. In the next phase we'll substitute for t (since
177 its rhs is trivial) and *then* we could get rid of the inline_me.
178 But it hardly seems worth it, so I don't bother.
181 mkInlineMe (Var v) = Var v
182 mkInlineMe e = Note InlineMe e
188 mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
190 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
191 = ASSERT( from_ty `eqType` to_ty2 )
192 mkCoerce to_ty from_ty2 expr
194 mkCoerce to_ty from_ty expr
195 | to_ty `eqType` from_ty = expr
196 | otherwise = ASSERT( from_ty `eqType` exprType expr )
197 Note (Coerce to_ty from_ty) expr
201 mkSCC :: CostCentre -> Expr b -> Expr b
202 -- Note: Nested SCC's *are* preserved for the benefit of
203 -- cost centre stack profiling
204 mkSCC cc (Lit lit) = Lit lit
205 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
206 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
207 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
208 mkSCC cc expr = Note (SCC cc) expr
212 %************************************************************************
214 \subsection{Other expression construction}
216 %************************************************************************
219 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
220 -- (bindNonRec x r b) produces either
223 -- case r of x { _DEFAULT_ -> b }
225 -- depending on whether x is unlifted or not
226 -- It's used by the desugarer to avoid building bindings
227 -- that give Core Lint a heart attack. Actually the simplifier
228 -- deals with them perfectly well.
229 bindNonRec bndr rhs body
230 | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
231 | otherwise = Let (NonRec bndr rhs) body
233 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
234 -- Make a case expression instead of a let
235 -- These can arise either from the desugarer,
236 -- or from beta reductions: (\x.e) (x +# y)
240 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
241 -- This guy constructs the value that the scrutinee must have
242 -- when you are in one particular branch of a case
243 mkAltExpr (DataAlt con) args inst_tys
244 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
245 mkAltExpr (LitAlt lit) [] []
248 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
249 mkIfThenElse guard then_expr else_expr
250 = Case guard (mkWildId boolTy)
251 [ (DataAlt trueDataCon, [], then_expr),
252 (DataAlt falseDataCon, [], else_expr) ]
256 %************************************************************************
258 \subsection{Taking expressions apart}
260 %************************************************************************
262 The default alternative must be first, if it exists at all.
263 This makes it easy to find, though it makes matching marginally harder.
266 hasDefault :: [CoreAlt] -> Bool
267 hasDefault ((DEFAULT,_,_) : alts) = True
270 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
271 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
272 findDefault alts = (alts, Nothing)
274 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
277 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
278 other -> go alts panic_deflt
281 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
284 go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
285 | otherwise = ASSERT( not (con1 == DEFAULT) )
290 %************************************************************************
292 \subsection{Figuring out things about expressions}
294 %************************************************************************
296 @exprIsTrivial@ is true of expressions we are unconditionally happy to
297 duplicate; simple variables and constants, and type
298 applications. Note that primop Ids aren't considered
301 @exprIsBottom@ is true of expressions that are guaranteed to diverge
305 exprIsTrivial (Var v)
306 | hasNoBinding v = idArity v == 0
307 -- WAS: | Just op <- isPrimOpId_maybe v = primOpIsDupable op
308 -- The idea here is that a constructor worker, like $wJust, is
309 -- really short for (\x -> $wJust x), becuase $wJust has no binding.
310 -- So it should be treated like a lambda.
311 -- Ditto unsaturated primops.
312 -- This came up when dealing with eta expansion/reduction for
314 -- Here we want to eta-expand. This looks like an optimisation,
315 -- but it's important (albeit tiresome) that CoreSat doesn't increase
318 exprIsTrivial (Type _) = True
319 exprIsTrivial (Lit lit) = True
320 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
321 exprIsTrivial (Note _ e) = exprIsTrivial e
322 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
323 exprIsTrivial other = False
325 exprIsAtom :: CoreExpr -> Bool
326 -- Used to decide whether to let-binding an STG argument
327 -- when compiling to ILX => type applications are not allowed
328 exprIsAtom (Var v) = True -- primOpIsDupable?
329 exprIsAtom (Lit lit) = True
330 exprIsAtom (Type ty) = True
331 exprIsAtom (Note (SCC _) e) = False
332 exprIsAtom (Note _ e) = exprIsAtom e
333 exprIsAtom other = False
337 @exprIsDupable@ is true of expressions that can be duplicated at a modest
338 cost in code size. This will only happen in different case
339 branches, so there's no issue about duplicating work.
341 That is, exprIsDupable returns True of (f x) even if
342 f is very very expensive to call.
344 Its only purpose is to avoid fruitless let-binding
345 and then inlining of case join points
349 exprIsDupable (Type _) = True
350 exprIsDupable (Var v) = True
351 exprIsDupable (Lit lit) = litIsDupable lit
352 exprIsDupable (Note InlineMe e) = True
353 exprIsDupable (Note _ e) = exprIsDupable e
357 go (Var v) n_args = True
358 go (App f a) n_args = n_args < dupAppSize
361 go other n_args = False
364 dupAppSize = 4 -- Size of application we are prepared to duplicate
367 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
368 it is obviously in weak head normal form, or is cheap to get to WHNF.
369 [Note that that's not the same as exprIsDupable; an expression might be
370 big, and hence not dupable, but still cheap.]
372 By ``cheap'' we mean a computation we're willing to:
373 push inside a lambda, or
374 inline at more than one place
375 That might mean it gets evaluated more than once, instead of being
376 shared. The main examples of things which aren't WHNF but are
381 (where e, and all the ei are cheap)
384 (where e and b are cheap)
387 (where op is a cheap primitive operator)
390 (because we are happy to substitute it inside a lambda)
392 Notice that a variable is considered 'cheap': we can push it inside a lambda,
393 because sharing will make sure it is only evaluated once.
396 exprIsCheap :: CoreExpr -> Bool
397 exprIsCheap (Lit lit) = True
398 exprIsCheap (Type _) = True
399 exprIsCheap (Var _) = True
400 exprIsCheap (Note InlineMe e) = True
401 exprIsCheap (Note _ e) = exprIsCheap e
402 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
403 exprIsCheap (Case e _ alts) = exprIsCheap e &&
404 and [exprIsCheap rhs | (_,_,rhs) <- alts]
405 -- Experimentally, treat (case x of ...) as cheap
406 -- (and case __coerce x etc.)
407 -- This improves arities of overloaded functions where
408 -- there is only dictionary selection (no construction) involved
409 exprIsCheap (Let (NonRec x _) e)
410 | isUnLiftedType (idType x) = exprIsCheap e
412 -- strict lets always have cheap right hand sides, and
415 exprIsCheap other_expr
416 = go other_expr 0 True
418 go (Var f) n_args args_cheap
419 = (idAppIsCheap f n_args && args_cheap)
420 -- A constructor, cheap primop, or partial application
422 || idAppIsBottom f n_args
423 -- Application of a function which
424 -- always gives bottom; we treat this as cheap
425 -- because it certainly doesn't need to be shared!
427 go (App f a) n_args args_cheap
428 | not (isRuntimeArg a) = go f n_args args_cheap
429 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
431 go other n_args args_cheap = False
433 idAppIsCheap :: Id -> Int -> Bool
434 idAppIsCheap id n_val_args
435 | n_val_args == 0 = True -- Just a type application of
436 -- a variable (f t1 t2 t3)
438 | otherwise = case globalIdDetails id of
440 RecordSelId _ -> True -- I'm experimenting with making record selection
441 -- look cheap, so we will substitute it inside a
442 -- lambda. Particularly for dictionary field selection
444 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
445 -- that return a type variable, since the result
446 -- might be applied to something, but I'm not going
447 -- to bother to check the number of args
448 other -> n_val_args < idArity id
451 exprOkForSpeculation returns True of an expression that it is
453 * safe to evaluate even if normal order eval might not
454 evaluate the expression at all, or
456 * safe *not* to evaluate even if normal order would do so
460 the expression guarantees to terminate,
462 without raising an exception,
463 without causing a side effect (e.g. writing a mutable variable)
466 let x = case y# +# 1# of { r# -> I# r# }
469 case y# +# 1# of { r# ->
474 We can only do this if the (y+1) is ok for speculation: it has no
475 side effects, and can't diverge or raise an exception.
478 exprOkForSpeculation :: CoreExpr -> Bool
479 exprOkForSpeculation (Lit _) = True
480 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
481 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
482 exprOkForSpeculation other_expr
483 = go other_expr 0 True
485 go (Var f) n_args args_ok
486 = case globalIdDetails f of
487 DataConId _ -> True -- The strictness of the constructor has already
488 -- been expressed by its "wrapper", so we don't need
489 -- to take the arguments into account
491 PrimOpId op -> primOpOkForSpeculation op && args_ok
492 -- A bit conservative: we don't really need
493 -- to care about lazy arguments, but this is easy
497 go (App f a) n_args args_ok
498 | not (isRuntimeArg a) = go f n_args args_ok
499 | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
501 go other n_args args_ok = False
506 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
507 exprIsBottom e = go 0 e
509 -- n is the number of args
510 go n (Note _ e) = go n e
511 go n (Let _ e) = go n e
512 go n (Case e _ _) = go 0 e -- Just check the scrut
513 go n (App e _) = go (n+1) e
514 go n (Var v) = idAppIsBottom v n
516 go n (Lam _ _) = False
518 idAppIsBottom :: Id -> Int -> Bool
519 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
522 @exprIsValue@ returns true for expressions that are certainly *already*
523 evaluated to *head* normal form. This is used to decide whether it's ok
526 case x of _ -> e ===> e
528 and to decide whether it's safe to discard a `seq`
530 So, it does *not* treat variables as evaluated, unless they say they are.
532 But it *does* treat partial applications and constructor applications
533 as values, even if their arguments are non-trivial, provided the argument
535 e.g. (:) (f x) (map f xs) is a value
536 map (...redex...) is a value
537 Because `seq` on such things completes immediately
539 For unlifted argument types, we have to be careful:
541 Suppose (f x) diverges; then C (f x) is not a value. True, but
542 this form is illegal (see the invariants in CoreSyn). Args of unboxed
543 type must be ok-for-speculation (or trivial).
546 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
547 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
549 exprIsValue (Lit l) = True
550 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
551 exprIsValue (Note _ e) = exprIsValue e
552 exprIsValue (Var v) = idArity v > 0 || isEvaldUnfolding (idUnfolding v)
553 -- The idArity case catches data cons and primops that
554 -- don't have unfoldings
555 -- A worry: what if an Id's unfolding is just itself:
556 -- then we could get an infinite loop...
557 exprIsValue other_expr
558 | (Var fun, args) <- collectArgs other_expr,
559 isDataConId fun || valArgCount args < idArity fun
560 = check (idType fun) args
564 -- 'check' checks that unlifted-type args are in
565 -- fact guaranteed non-divergent
566 check fun_ty [] = True
567 check fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
568 Just (_, ty) -> check ty args
569 check fun_ty (arg : args)
570 | isUnLiftedType arg_ty = exprOkForSpeculation arg
571 | otherwise = check res_ty args
573 (arg_ty, res_ty) = splitFunTy fun_ty
577 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
578 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
579 = -- Maybe this is over the top, but here we try to turn
580 -- coerce (S,T) ( x, y )
582 -- ( coerce S x, coerce T y )
583 -- This happens in anger in PrelArrExts which has a coerce
584 -- case coerce memcpy a b of
586 -- where the memcpy is in the IO monad, but the call is in
588 case exprIsConApp_maybe expr of {
592 case splitTyConApp_maybe to_ty of {
594 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
595 | isExistentialDataCon dc -> Nothing
597 -- Type constructor must match
598 -- We knock out existentials to keep matters simple(r)
600 arity = tyConArity tc
601 val_args = drop arity args
602 to_arg_tys = dataConArgTys dc tc_arg_tys
603 mk_coerce ty arg = mkCoerce ty (exprType arg) arg
604 new_val_args = zipWith mk_coerce to_arg_tys val_args
606 ASSERT( all isTypeArg (take arity args) )
607 ASSERT( length val_args == length to_arg_tys )
608 Just (dc, map Type tc_arg_tys ++ new_val_args)
611 exprIsConApp_maybe (Note _ expr)
612 = exprIsConApp_maybe expr
613 -- We ignore InlineMe notes in case we have
614 -- x = __inline_me__ (a,b)
615 -- All part of making sure that INLINE pragmas never hurt
616 -- Marcin tripped on this one when making dictionaries more inlinable
618 -- In fact, we ignore all notes. For example,
619 -- case _scc_ "foo" (C a b) of
621 -- should be optimised away, but it will be only if we look
622 -- through the SCC note.
624 exprIsConApp_maybe expr = analyse (collectArgs expr)
626 analyse (Var fun, args)
627 | Just con <- isDataConId_maybe fun,
628 length args >= dataConRepArity con
629 -- Might be > because the arity excludes type args
632 -- Look through unfoldings, but only cheap ones, because
633 -- we are effectively duplicating the unfolding
634 analyse (Var fun, [])
635 | let unf = idUnfolding fun,
637 = exprIsConApp_maybe (unfoldingTemplate unf)
639 analyse other = Nothing
644 %************************************************************************
646 \subsection{Eta reduction and expansion}
648 %************************************************************************
650 @etaReduce@ trys an eta reduction at the top level of a Core Expr.
652 e.g. \ x y -> f x y ===> f
654 But we only do this if it gets rid of a whole lambda, not part.
655 The idea is that lambdas are often quite helpful: they indicate
656 head normal forms, so we don't want to chuck them away lightly.
659 etaReduce :: CoreExpr -> CoreExpr
660 -- ToDo: we should really check that we don't turn a non-bottom
661 -- lambda into a bottom variable. Sigh
663 etaReduce expr@(Lam bndr body)
664 = check (reverse binders) body
666 (binders, body) = collectBinders expr
669 | not (any (`elemVarSet` body_fvs) binders)
672 body_fvs = exprFreeVars body
674 check (b : bs) (App fun arg)
675 | (varToCoreExpr b `cheapEqExpr` arg)
678 check _ _ = expr -- Bale out
680 etaReduce expr = expr -- The common case
685 exprEtaExpandArity :: CoreExpr -> (Int, Bool)
686 -- The Int is number of value args the thing can be
687 -- applied to without doing much work
688 -- The Bool is True iff there are enough explicit value lambdas
689 -- at the top to make this arity apparent
690 -- (but ignore it when arity==0)
692 -- This is used when eta expanding
693 -- e ==> \xy -> e x y
695 -- It returns 1 (or more) to:
696 -- case x of p -> \s -> ...
697 -- because for I/O ish things we really want to get that \s to the top.
698 -- We are prepared to evaluate x each time round the loop in order to get that
700 -- It's all a bit more subtle than it looks. Consider one-shot lambdas
701 -- let x = expensive in \y z -> E
702 -- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
703 -- Hence the ArityType returned by arityType
705 -- NB: this is particularly important/useful for IO state
706 -- transformers, where we often get
707 -- let x = E in \ s -> ...
708 -- and the \s is a real-world state token abstraction. Such
709 -- abstractions are almost invariably 1-shot, so we want to
710 -- pull the \s out, past the let x=E.
711 -- The hack is in Id.isOneShotLambda
714 -- f = \x -> error "foo"
715 -- Here, arity 1 is fine. But if it is
716 -- f = \x -> case e of
717 -- True -> error "foo"
718 -- False -> \y -> x+y
719 -- then we want to get arity 2.
720 -- Hence the ABot/ATop in ArityType
726 go :: Int -> CoreExpr -> (Int,Bool)
727 go ar (Lam x e) | isId x = go (ar+1) e
728 | otherwise = go ar e
729 go ar (Note n e) | ok_note n = go ar e
730 go ar other = (ar + ar', ar' == 0)
732 ar' = arityDepth (arityType other)
734 -- A limited sort of function type
735 data ArityType = AFun Bool ArityType -- True <=> one-shot
736 | ATop -- Know nothing
739 arityDepth :: ArityType -> Arity
740 arityDepth (AFun _ ty) = 1 + arityDepth ty
743 andArityType ABot at2 = at2
744 andArityType ATop at2 = ATop
745 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
746 andArityType at1 at2 = andArityType at2 at1
748 arityType :: CoreExpr -> ArityType
749 -- (go1 e) = [b1,..,bn]
750 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
751 -- where bi is True <=> the lambda is one-shot
754 | ok_note n = arityType e
760 mk :: Arity -> ArityType
761 mk 0 | isBottomingId v = ABot
763 mk n = AFun False (mk (n-1))
765 -- When the type of the Id encodes one-shot-ness,
766 -- use the idinfo here
768 -- Lambdas; increase arity
769 arityType (Lam x e) | isId x = AFun (isOneShotLambda x) (arityType e)
770 | otherwise = arityType e
772 -- Applications; decrease arity
773 arityType (App f (Type _)) = arityType f
774 arityType (App f a) = case arityType f of
775 AFun one_shot xs | one_shot -> xs
776 | exprIsCheap a -> xs
779 -- Case/Let; keep arity if either the expression is cheap
780 -- or it's a 1-shot lambda
781 arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
782 xs@(AFun one_shot _) | one_shot -> xs
783 xs | exprIsCheap scrut -> xs
786 arityType (Let b e) = case arityType e of
787 xs@(AFun one_shot _) | one_shot -> xs
788 xs | all exprIsCheap (rhssOfBind b) -> xs
791 arityType other = ATop
793 ok_note InlineMe = False
795 -- Notice that we do not look through __inline_me__
796 -- This may seem surprising, but consider
797 -- f = _inline_me (\x -> e)
798 -- We DO NOT want to eta expand this to
799 -- f = \x -> (_inline_me (\x -> e)) x
800 -- because the _inline_me gets dropped now it is applied,
809 etaExpand :: Int -- Add this number of value args
811 -> CoreExpr -> Type -- Expression and its type
813 -- (etaExpand n us e ty) returns an expression with
814 -- the same meaning as 'e', but with arity 'n'.
816 -- Given e' = etaExpand n us e ty
818 -- ty = exprType e = exprType e'
820 -- etaExpand deals with for-alls. For example:
822 -- where E :: forall a. a -> a
824 -- (/\b. \y::a -> E b y)
826 -- It deals with coerces too, though they are now rare
827 -- so perhaps the extra code isn't worth it
829 etaExpand n us expr ty
831 -- The ILX code generator requires eta expansion for type arguments
832 -- too, but alas the 'n' doesn't tell us how many of them there
833 -- may be. So we eagerly eta expand any big lambdas, and just
834 -- cross our fingers about possible loss of sharing in the
836 -- The Right Thing is probably to make 'arity' include
837 -- type variables throughout the compiler. (ToDo.)
839 -- Saturated, so nothing to do
842 | otherwise -- An unsaturated constructor or primop; eta expand it
843 = case splitForAllTy_maybe ty of {
844 Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
848 case splitFunTy_maybe ty of {
849 Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
851 arg1 = mkSysLocal SLIT("eta") uniq arg_ty
856 case splitNewType_maybe ty of {
857 Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
858 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
862 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
863 It tells how many things the expression can be applied to before doing
864 any work. It doesn't look inside cases, lets, etc. The idea is that
865 exprEtaExpandArity will do the hard work, leaving something that's easy
866 for exprArity to grapple with. In particular, Simplify uses exprArity to
867 compute the ArityInfo for the Id.
869 Originally I thought that it was enough just to look for top-level lambdas, but
870 it isn't. I've seen this
872 foo = PrelBase.timesInt
874 We want foo to get arity 2 even though the eta-expander will leave it
875 unchanged, in the expectation that it'll be inlined. But occasionally it
876 isn't, because foo is blacklisted (used in a rule).
878 Similarly, see the ok_note check in exprEtaExpandArity. So
879 f = __inline_me (\x -> e)
880 won't be eta-expanded.
882 And in any case it seems more robust to have exprArity be a bit more intelligent.
883 But note that (\x y z -> f x y z)
884 should have arity 3, regardless of f's arity.
887 exprArity :: CoreExpr -> Int
890 go (Var v) = idArity v
891 go (Lam x e) | isId x = go e + 1
894 go (App e (Type t)) = go e
895 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
896 -- NB: exprIsCheap a!
897 -- f (fac x) does not have arity 2,
898 -- even if f has arity 3!
899 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
900 -- unknown, hence arity 0
905 %************************************************************************
907 \subsection{Equality}
909 %************************************************************************
911 @cheapEqExpr@ is a cheap equality test which bales out fast!
912 True => definitely equal
913 False => may or may not be equal
916 cheapEqExpr :: Expr b -> Expr b -> Bool
918 cheapEqExpr (Var v1) (Var v2) = v1==v2
919 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
920 cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
922 cheapEqExpr (App f1 a1) (App f2 a2)
923 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
925 cheapEqExpr _ _ = False
927 exprIsBig :: Expr b -> Bool
928 -- Returns True of expressions that are too big to be compared by cheapEqExpr
929 exprIsBig (Lit _) = False
930 exprIsBig (Var v) = False
931 exprIsBig (Type t) = False
932 exprIsBig (App f a) = exprIsBig f || exprIsBig a
933 exprIsBig other = True
938 eqExpr :: CoreExpr -> CoreExpr -> Bool
939 -- Works ok at more general type, but only needed at CoreExpr
940 -- Used in rule matching, so when we find a type we use
941 -- eqTcType, which doesn't look through newtypes
942 -- [And it doesn't risk falling into a black hole either.]
944 = eq emptyVarEnv e1 e2
946 -- The "env" maps variables in e1 to variables in ty2
947 -- So when comparing lambdas etc,
948 -- we in effect substitute v2 for v1 in e1 before continuing
949 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
950 Just v1' -> v1' == v2
953 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
954 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
955 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
956 eq env (Let (NonRec v1 r1) e1)
957 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
958 eq env (Let (Rec ps1) e1)
959 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
960 and (zipWith eq_rhs ps1 ps2) &&
963 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
964 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
965 eq env (Case e1 v1 a1)
966 (Case e2 v2 a2) = eq env e1 e2 &&
967 length a1 == length a2 &&
968 and (zipWith (eq_alt env') a1 a2)
970 env' = extendVarEnv env v1 v2
972 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
973 eq env (Type t1) (Type t2) = t1 `eqType` t2
976 eq_list env [] [] = True
977 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
978 eq_list env es1 es2 = False
980 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
981 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
983 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
984 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
985 eq_note env InlineCall InlineCall = True
986 eq_note env other1 other2 = False
990 %************************************************************************
992 \subsection{The size of an expression}
994 %************************************************************************
997 coreBindsSize :: [CoreBind] -> Int
998 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1000 exprSize :: CoreExpr -> Int
1001 -- A measure of the size of the expressions
1002 -- It also forces the expression pretty drastically as a side effect
1003 exprSize (Var v) = varSize v
1004 exprSize (Lit lit) = lit `seq` 1
1005 exprSize (App f a) = exprSize f + exprSize a
1006 exprSize (Lam b e) = varSize b + exprSize e
1007 exprSize (Let b e) = bindSize b + exprSize e
1008 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
1009 exprSize (Note n e) = noteSize n + exprSize e
1010 exprSize (Type t) = seqType t `seq` 1
1012 noteSize (SCC cc) = cc `seq` 1
1013 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1014 noteSize InlineCall = 1
1015 noteSize InlineMe = 1
1017 varSize :: Var -> Int
1018 varSize b | isTyVar b = 1
1019 | otherwise = seqType (idType b) `seq`
1020 megaSeqIdInfo (idInfo b) `seq`
1023 varsSize = foldr ((+) . varSize) 0
1025 bindSize (NonRec b e) = varSize b + exprSize e
1026 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1028 pairSize (b,e) = varSize b + exprSize e
1030 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1034 %************************************************************************
1036 \subsection{Hashing}
1038 %************************************************************************
1041 hashExpr :: CoreExpr -> Int
1042 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1045 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1047 hash_expr (Note _ e) = hash_expr e
1048 hash_expr (Let (NonRec b r) e) = hashId b
1049 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1050 hash_expr (Case _ b _) = hashId b
1051 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1052 hash_expr (Var v) = hashId v
1053 hash_expr (Lit lit) = hashLiteral lit
1054 hash_expr (Lam b _) = hashId b
1055 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1057 fast_hash_expr (Var v) = hashId v
1058 fast_hash_expr (Lit lit) = hashLiteral lit
1059 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1060 fast_hash_expr (App f a) = fast_hash_expr a
1061 fast_hash_expr (Lam b _) = hashId b
1062 fast_hash_expr other = 1
1065 hashId id = hashName (idName id)