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, rhsIsNonUpd,
23 -- Arity and eta expansion
24 manifestArity, exprArity,
25 exprEtaExpandArity, etaExpand,
34 cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg,
36 -- Cross-DLL references
40 #include "HsVersions.h"
43 import GLAEXTS -- For `xori`
46 import PprCore ( pprCoreExpr )
47 import Var ( Var, isId, isTyVar )
49 import Name ( hashName, isDllName )
50 import Literal ( hashLiteral, literalType, litIsDupable,
51 litIsTrivial, isZeroLit, isLitLitLit )
52 import DataCon ( DataCon, dataConRepArity, dataConArgTys,
53 isExistentialDataCon, dataConTyCon, dataConName )
54 import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
55 import Id ( Id, idType, globalIdDetails, idNewStrictness,
56 mkWildId, idArity, idName, idUnfolding, idInfo,
57 isOneShotLambda, isDataConWorkId_maybe, mkSysLocal,
58 isDataConWorkId, isBottomingId
60 import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
61 import NewDemand ( appIsBottom )
62 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
64 applyTys, isUnLiftedType, seqType, mkTyVarTy,
65 splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
66 splitTyConApp_maybe, eqType, funResultTy, applyTy,
69 import TyCon ( tyConArity )
70 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
71 import CostCentre ( CostCentre )
72 import BasicTypes ( Arity )
73 import Unique ( Unique )
75 import TysPrim ( alphaTy ) -- Debugging only
76 import Util ( equalLength, lengthAtLeast )
77 import TysPrim ( statePrimTyCon )
81 %************************************************************************
83 \subsection{Find the type of a Core atom/expression}
85 %************************************************************************
88 exprType :: CoreExpr -> Type
90 exprType (Var var) = idType var
91 exprType (Lit lit) = literalType lit
92 exprType (Let _ body) = exprType body
93 exprType (Case _ _ alts) = coreAltsType alts
94 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
95 exprType (Note other_note e) = exprType e
96 exprType (Lam binder expr) = mkPiType binder (exprType expr)
98 = case collectArgs e of
99 (fun, args) -> applyTypeToArgs e (exprType fun) args
101 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
103 coreAltsType :: [CoreAlt] -> Type
104 coreAltsType ((_,_,rhs) : _) = exprType rhs
107 @mkPiType@ makes a (->) type or a forall type, depending on whether
108 it is given a type variable or a term variable. We cleverly use the
109 lbvarinfo field to figure out the right annotation for the arrove in
110 case of a term variable.
113 mkPiType :: Var -> Type -> Type -- The more polymorphic version
114 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
116 mkPiTypes vs ty = foldr mkPiType ty vs
119 | isId v = mkFunTy (idType v) ty
120 | otherwise = mkForAllTy v ty
124 applyTypeToArg :: Type -> CoreExpr -> Type
125 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
126 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
128 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
129 -- A more efficient version of applyTypeToArg
130 -- when we have several args
131 -- The first argument is just for debugging
132 applyTypeToArgs e op_ty [] = op_ty
134 applyTypeToArgs e op_ty (Type ty : args)
135 = -- Accumulate type arguments so we can instantiate all at once
138 go rev_tys (Type ty : args) = go (ty:rev_tys) args
139 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
141 op_ty' = applyTys op_ty (reverse rev_tys)
143 applyTypeToArgs e op_ty (other_arg : args)
144 = case (splitFunTy_maybe op_ty) of
145 Just (_, res_ty) -> applyTypeToArgs e res_ty args
146 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
151 %************************************************************************
153 \subsection{Attaching notes}
155 %************************************************************************
157 mkNote removes redundant coercions, and SCCs where possible
160 mkNote :: Note -> CoreExpr -> CoreExpr
161 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
162 mkNote (SCC cc) expr = mkSCC cc expr
163 mkNote InlineMe expr = mkInlineMe expr
164 mkNote note expr = Note note expr
166 -- Slide InlineCall in around the function
167 -- No longer necessary I think (SLPJ Apr 99)
168 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
169 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
170 -- mkNote InlineCall expr = expr
173 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
174 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
175 not be *applied* to anything.
177 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
180 f = inline_me (coerce t fw)
181 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
182 We want the split, so that the coerces can cancel at the call site.
184 However, we can get left with tiresome type applications. Notably, consider
185 f = /\ a -> let t = e in (t, w)
186 Then lifting the let out of the big lambda gives
188 f = /\ a -> let t = inline_me (t' a) in (t, w)
189 The inline_me is to stop the simplifier inlining t' right back
190 into t's RHS. In the next phase we'll substitute for t (since
191 its rhs is trivial) and *then* we could get rid of the inline_me.
192 But it hardly seems worth it, so I don't bother.
195 mkInlineMe (Var v) = Var v
196 mkInlineMe e = Note InlineMe e
202 mkCoerce :: Type -> CoreExpr -> CoreExpr
203 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
205 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
206 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
207 = ASSERT( from_ty `eqType` to_ty2 )
208 mkCoerce2 to_ty from_ty2 expr
210 mkCoerce2 to_ty from_ty expr
211 | to_ty `eqType` from_ty = expr
212 | otherwise = ASSERT( from_ty `eqType` exprType expr )
213 Note (Coerce to_ty from_ty) expr
217 mkSCC :: CostCentre -> Expr b -> Expr b
218 -- Note: Nested SCC's *are* preserved for the benefit of
219 -- cost centre stack profiling
220 mkSCC cc (Lit lit) = Lit lit
221 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
222 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
223 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
224 mkSCC cc expr = Note (SCC cc) expr
228 %************************************************************************
230 \subsection{Other expression construction}
232 %************************************************************************
235 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
236 -- (bindNonRec x r b) produces either
239 -- case r of x { _DEFAULT_ -> b }
241 -- depending on whether x is unlifted or not
242 -- It's used by the desugarer to avoid building bindings
243 -- that give Core Lint a heart attack. Actually the simplifier
244 -- deals with them perfectly well.
245 bindNonRec bndr rhs body
246 | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
247 | otherwise = Let (NonRec bndr rhs) body
249 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
250 -- Make a case expression instead of a let
251 -- These can arise either from the desugarer,
252 -- or from beta reductions: (\x.e) (x +# y)
256 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
257 -- This guy constructs the value that the scrutinee must have
258 -- when you are in one particular branch of a case
259 mkAltExpr (DataAlt con) args inst_tys
260 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
261 mkAltExpr (LitAlt lit) [] []
264 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
265 mkIfThenElse guard then_expr else_expr
266 = Case guard (mkWildId boolTy)
267 [ (DataAlt trueDataCon, [], then_expr),
268 (DataAlt falseDataCon, [], else_expr) ]
272 %************************************************************************
274 \subsection{Taking expressions apart}
276 %************************************************************************
278 The default alternative must be first, if it exists at all.
279 This makes it easy to find, though it makes matching marginally harder.
282 hasDefault :: [CoreAlt] -> Bool
283 hasDefault ((DEFAULT,_,_) : alts) = True
286 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
287 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
288 findDefault alts = (alts, Nothing)
290 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
293 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
294 other -> go alts panic_deflt
297 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
300 go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
301 | otherwise = ASSERT( not (con1 == DEFAULT) )
306 %************************************************************************
308 \subsection{Figuring out things about expressions}
310 %************************************************************************
312 @exprIsTrivial@ is true of expressions we are unconditionally happy to
313 duplicate; simple variables and constants, and type
314 applications. Note that primop Ids aren't considered
317 @exprIsBottom@ is true of expressions that are guaranteed to diverge
320 There used to be a gruesome test for (hasNoBinding v) in the
322 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
323 The idea here is that a constructor worker, like $wJust, is
324 really short for (\x -> $wJust x), becuase $wJust has no binding.
325 So it should be treated like a lambda. Ditto unsaturated primops.
326 But now constructor workers are not "have-no-binding" Ids. And
327 completely un-applied primops and foreign-call Ids are sufficiently
328 rare that I plan to allow them to be duplicated and put up with
332 exprIsTrivial (Var v) = True -- See notes above
333 exprIsTrivial (Type _) = True
334 exprIsTrivial (Lit lit) = litIsTrivial lit
335 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
336 exprIsTrivial (Note _ e) = exprIsTrivial e
337 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
338 exprIsTrivial other = False
340 exprIsAtom :: CoreExpr -> Bool
341 -- Used to decide whether to let-binding an STG argument
342 -- when compiling to ILX => type applications are not allowed
343 exprIsAtom (Var v) = True -- primOpIsDupable?
344 exprIsAtom (Lit lit) = True
345 exprIsAtom (Type ty) = True
346 exprIsAtom (Note (SCC _) e) = False
347 exprIsAtom (Note _ e) = exprIsAtom e
348 exprIsAtom other = False
352 @exprIsDupable@ is true of expressions that can be duplicated at a modest
353 cost in code size. This will only happen in different case
354 branches, so there's no issue about duplicating work.
356 That is, exprIsDupable returns True of (f x) even if
357 f is very very expensive to call.
359 Its only purpose is to avoid fruitless let-binding
360 and then inlining of case join points
364 exprIsDupable (Type _) = True
365 exprIsDupable (Var v) = True
366 exprIsDupable (Lit lit) = litIsDupable lit
367 exprIsDupable (Note InlineMe e) = True
368 exprIsDupable (Note _ e) = exprIsDupable e
372 go (Var v) n_args = True
373 go (App f a) n_args = n_args < dupAppSize
376 go other n_args = False
379 dupAppSize = 4 -- Size of application we are prepared to duplicate
382 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
383 it is obviously in weak head normal form, or is cheap to get to WHNF.
384 [Note that that's not the same as exprIsDupable; an expression might be
385 big, and hence not dupable, but still cheap.]
387 By ``cheap'' we mean a computation we're willing to:
388 push inside a lambda, or
389 inline at more than one place
390 That might mean it gets evaluated more than once, instead of being
391 shared. The main examples of things which aren't WHNF but are
396 (where e, and all the ei are cheap)
399 (where e and b are cheap)
402 (where op is a cheap primitive operator)
405 (because we are happy to substitute it inside a lambda)
407 Notice that a variable is considered 'cheap': we can push it inside a lambda,
408 because sharing will make sure it is only evaluated once.
411 exprIsCheap :: CoreExpr -> Bool
412 exprIsCheap (Lit lit) = True
413 exprIsCheap (Type _) = True
414 exprIsCheap (Var _) = True
415 exprIsCheap (Note InlineMe e) = True
416 exprIsCheap (Note _ e) = exprIsCheap e
417 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
418 exprIsCheap (Case e _ alts) = exprIsCheap e &&
419 and [exprIsCheap rhs | (_,_,rhs) <- alts]
420 -- Experimentally, treat (case x of ...) as cheap
421 -- (and case __coerce x etc.)
422 -- This improves arities of overloaded functions where
423 -- there is only dictionary selection (no construction) involved
424 exprIsCheap (Let (NonRec x _) e)
425 | isUnLiftedType (idType x) = exprIsCheap e
427 -- strict lets always have cheap right hand sides, and
430 exprIsCheap other_expr
431 = go other_expr 0 True
433 go (Var f) n_args args_cheap
434 = (idAppIsCheap f n_args && args_cheap)
435 -- A constructor, cheap primop, or partial application
437 || idAppIsBottom f n_args
438 -- Application of a function which
439 -- always gives bottom; we treat this as cheap
440 -- because it certainly doesn't need to be shared!
442 go (App f a) n_args args_cheap
443 | not (isRuntimeArg a) = go f n_args args_cheap
444 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
446 go other n_args args_cheap = False
448 idAppIsCheap :: Id -> Int -> Bool
449 idAppIsCheap id n_val_args
450 | n_val_args == 0 = True -- Just a type application of
451 -- a variable (f t1 t2 t3)
453 | otherwise = case globalIdDetails id of
454 DataConWorkId _ -> True
455 RecordSelId _ -> True -- I'm experimenting with making record selection
456 ClassOpId _ -> True -- look cheap, so we will substitute it inside a
457 -- lambda. Particularly for dictionary field selection
459 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
460 -- that return a type variable, since the result
461 -- might be applied to something, but I'm not going
462 -- to bother to check the number of args
463 other -> n_val_args < idArity id
466 exprOkForSpeculation returns True of an expression that it is
468 * safe to evaluate even if normal order eval might not
469 evaluate the expression at all, or
471 * safe *not* to evaluate even if normal order would do so
475 the expression guarantees to terminate,
477 without raising an exception,
478 without causing a side effect (e.g. writing a mutable variable)
481 let x = case y# +# 1# of { r# -> I# r# }
484 case y# +# 1# of { r# ->
489 We can only do this if the (y+1) is ok for speculation: it has no
490 side effects, and can't diverge or raise an exception.
493 exprOkForSpeculation :: CoreExpr -> Bool
494 exprOkForSpeculation (Lit _) = True
495 exprOkForSpeculation (Type _) = True
496 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
497 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
498 exprOkForSpeculation other_expr
499 = case collectArgs other_expr of
500 (Var f, args) -> spec_ok (globalIdDetails f) args
504 spec_ok (DataConWorkId _) args
505 = True -- The strictness of the constructor has already
506 -- been expressed by its "wrapper", so we don't need
507 -- to take the arguments into account
509 spec_ok (PrimOpId op) args
510 | isDivOp op, -- Special case for dividing operations that fail
511 [arg1, Lit lit] <- args -- only if the divisor is zero
512 = not (isZeroLit lit) && exprOkForSpeculation arg1
513 -- Often there is a literal divisor, and this
514 -- can get rid of a thunk in an inner looop
517 = primOpOkForSpeculation op &&
518 all exprOkForSpeculation args
519 -- A bit conservative: we don't really need
520 -- to care about lazy arguments, but this is easy
522 spec_ok other args = False
524 isDivOp :: PrimOp -> Bool
525 -- True of dyadic operators that can fail
526 -- only if the second arg is zero
527 -- This function probably belongs in PrimOp, or even in
528 -- an automagically generated file.. but it's such a
529 -- special case I thought I'd leave it here for now.
530 isDivOp IntQuotOp = True
531 isDivOp IntRemOp = True
532 isDivOp WordQuotOp = True
533 isDivOp WordRemOp = True
534 isDivOp IntegerQuotRemOp = True
535 isDivOp IntegerDivModOp = True
536 isDivOp FloatDivOp = True
537 isDivOp DoubleDivOp = True
538 isDivOp other = False
543 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
544 exprIsBottom e = go 0 e
546 -- n is the number of args
547 go n (Note _ e) = go n e
548 go n (Let _ e) = go n e
549 go n (Case e _ _) = go 0 e -- Just check the scrut
550 go n (App e _) = go (n+1) e
551 go n (Var v) = idAppIsBottom v n
553 go n (Lam _ _) = False
555 idAppIsBottom :: Id -> Int -> Bool
556 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
559 @exprIsValue@ returns true for expressions that are certainly *already*
560 evaluated to *head* normal form. This is used to decide whether it's ok
563 case x of _ -> e ===> e
565 and to decide whether it's safe to discard a `seq`
567 So, it does *not* treat variables as evaluated, unless they say they are.
569 But it *does* treat partial applications and constructor applications
570 as values, even if their arguments are non-trivial, provided the argument
572 e.g. (:) (f x) (map f xs) is a value
573 map (...redex...) is a value
574 Because `seq` on such things completes immediately
576 For unlifted argument types, we have to be careful:
578 Suppose (f x) diverges; then C (f x) is not a value. True, but
579 this form is illegal (see the invariants in CoreSyn). Args of unboxed
580 type must be ok-for-speculation (or trivial).
583 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
584 exprIsValue (Var v) -- NB: There are no value args at this point
585 = isDataConWorkId v -- Catches nullary constructors,
586 -- so that [] and () are values, for example
587 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
588 || isEvaldUnfolding (idUnfolding v)
589 -- Check the thing's unfolding; it might be bound to a value
590 -- A worry: what if an Id's unfolding is just itself:
591 -- then we could get an infinite loop...
593 exprIsValue (Lit l) = True
594 exprIsValue (Type ty) = True -- Types are honorary Values;
595 -- we don't mind copying them
596 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
597 exprIsValue (Note _ e) = exprIsValue e
598 exprIsValue (App e (Type _)) = exprIsValue e
599 exprIsValue (App e a) = app_is_value e [a]
600 exprIsValue other = False
602 -- There is at least one value argument
603 app_is_value (Var fun) args
604 | isDataConWorkId fun -- Constructor apps are values
605 || idArity fun > valArgCount args -- Under-applied function
606 = check_args (idType fun) args
607 app_is_value (App f a) as = app_is_value f (a:as)
608 app_is_value other as = False
610 -- 'check_args' checks that unlifted-type args
611 -- are in fact guaranteed non-divergent
612 check_args fun_ty [] = True
613 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
614 Just (_, ty) -> check_args ty args
615 check_args fun_ty (arg : args)
616 | isUnLiftedType arg_ty = exprOkForSpeculation arg
617 | otherwise = check_args res_ty args
619 (arg_ty, res_ty) = splitFunTy fun_ty
623 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
624 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
625 = -- Maybe this is over the top, but here we try to turn
626 -- coerce (S,T) ( x, y )
628 -- ( coerce S x, coerce T y )
629 -- This happens in anger in PrelArrExts which has a coerce
630 -- case coerce memcpy a b of
632 -- where the memcpy is in the IO monad, but the call is in
634 case exprIsConApp_maybe expr of {
638 case splitTyConApp_maybe to_ty of {
640 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
641 | isExistentialDataCon dc -> Nothing
643 -- Type constructor must match
644 -- We knock out existentials to keep matters simple(r)
646 arity = tyConArity tc
647 val_args = drop arity args
648 to_arg_tys = dataConArgTys dc tc_arg_tys
649 mk_coerce ty arg = mkCoerce ty arg
650 new_val_args = zipWith mk_coerce to_arg_tys val_args
652 ASSERT( all isTypeArg (take arity args) )
653 ASSERT( equalLength val_args to_arg_tys )
654 Just (dc, map Type tc_arg_tys ++ new_val_args)
657 exprIsConApp_maybe (Note _ expr)
658 = exprIsConApp_maybe expr
659 -- We ignore InlineMe notes in case we have
660 -- x = __inline_me__ (a,b)
661 -- All part of making sure that INLINE pragmas never hurt
662 -- Marcin tripped on this one when making dictionaries more inlinable
664 -- In fact, we ignore all notes. For example,
665 -- case _scc_ "foo" (C a b) of
667 -- should be optimised away, but it will be only if we look
668 -- through the SCC note.
670 exprIsConApp_maybe expr = analyse (collectArgs expr)
672 analyse (Var fun, args)
673 | Just con <- isDataConWorkId_maybe fun,
674 args `lengthAtLeast` dataConRepArity con
675 -- Might be > because the arity excludes type args
678 -- Look through unfoldings, but only cheap ones, because
679 -- we are effectively duplicating the unfolding
680 analyse (Var fun, [])
681 | let unf = idUnfolding fun,
683 = exprIsConApp_maybe (unfoldingTemplate unf)
685 analyse other = Nothing
690 %************************************************************************
692 \subsection{Eta reduction and expansion}
694 %************************************************************************
697 exprEtaExpandArity :: CoreExpr -> Arity
698 -- The Int is number of value args the thing can be
699 -- applied to without doing much work
701 -- This is used when eta expanding
702 -- e ==> \xy -> e x y
704 -- It returns 1 (or more) to:
705 -- case x of p -> \s -> ...
706 -- because for I/O ish things we really want to get that \s to the top.
707 -- We are prepared to evaluate x each time round the loop in order to get that
709 -- It's all a bit more subtle than it looks. Consider one-shot lambdas
710 -- let x = expensive in \y z -> E
711 -- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
712 -- Hence the ArityType returned by arityType
714 -- NB: this is particularly important/useful for IO state
715 -- transformers, where we often get
716 -- let x = E in \ s -> ...
717 -- and the \s is a real-world state token abstraction. Such
718 -- abstractions are almost invariably 1-shot, so we want to
719 -- pull the \s out, past the let x=E.
720 -- The hack is in Id.isOneShotLambda
723 -- f = \x -> error "foo"
724 -- Here, arity 1 is fine. But if it is
725 -- f = \x -> case e of
726 -- True -> error "foo"
727 -- False -> \y -> x+y
728 -- then we want to get arity 2.
729 -- Hence the ABot/ATop in ArityType
732 exprEtaExpandArity e = arityDepth (arityType e)
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
753 arityType (Note n e) = arityType e
754 -- Not needed any more: etaExpand is cleverer
755 -- | ok_note n = arityType e
756 -- | otherwise = ATop
761 mk :: Arity -> ArityType
762 mk 0 | isBottomingId v = ABot
764 mk n = AFun False (mk (n-1))
766 -- When the type of the Id encodes one-shot-ness,
767 -- use the idinfo here
769 -- Lambdas; increase arity
770 arityType (Lam x e) | isId x = AFun (isOneShotLambda x || isStateHack x) (arityType e)
771 | otherwise = arityType e
773 -- Applications; decrease arity
774 arityType (App f (Type _)) = arityType f
775 arityType (App f a) = case arityType f of
776 AFun one_shot xs | 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 isStateHack id = case splitTyConApp_maybe (idType id) of
794 Just (tycon,_) | tycon == statePrimTyCon -> True
797 -- The last clause is a gross hack. It claims that
798 -- every function over realWorldStatePrimTy is a one-shot
799 -- function. This is pretty true in practice, and makes a big
800 -- difference. For example, consider
801 -- a `thenST` \ r -> ...E...
802 -- The early full laziness pass, if it doesn't know that r is one-shot
803 -- will pull out E (let's say it doesn't mention r) to give
804 -- let lvl = E in a `thenST` \ r -> ...lvl...
805 -- When `thenST` gets inlined, we end up with
806 -- let lvl = E in \s -> case a s of (r, s') -> ...lvl...
807 -- and we don't re-inline E.
809 -- It would be better to spot that r was one-shot to start with, but
810 -- I don't want to rely on that.
812 -- Another good example is in fill_in in PrelPack.lhs. We should be able to
813 -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
815 {- NOT NEEDED ANY MORE: etaExpand is cleverer
816 ok_note InlineMe = False
818 -- Notice that we do not look through __inline_me__
819 -- This may seem surprising, but consider
820 -- f = _inline_me (\x -> e)
821 -- We DO NOT want to eta expand this to
822 -- f = \x -> (_inline_me (\x -> e)) x
823 -- because the _inline_me gets dropped now it is applied,
832 etaExpand :: Arity -- Result should have this number of value args
834 -> CoreExpr -> Type -- Expression and its type
836 -- (etaExpand n us e ty) returns an expression with
837 -- the same meaning as 'e', but with arity 'n'.
839 -- Given e' = etaExpand n us e ty
841 -- ty = exprType e = exprType e'
843 -- Note that SCCs are not treated specially. If we have
844 -- etaExpand 2 (\x -> scc "foo" e)
845 -- = (\xy -> (scc "foo" e) y)
846 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
848 etaExpand n us expr ty
849 | manifestArity expr >= n = expr -- The no-op case
850 | otherwise = eta_expand n us expr ty
853 -- manifestArity sees how many leading value lambdas there are
854 manifestArity :: CoreExpr -> Arity
855 manifestArity (Lam v e) | isId v = 1 + manifestArity e
856 | otherwise = manifestArity e
857 manifestArity (Note _ e) = manifestArity e
860 -- etaExpand deals with for-alls. For example:
862 -- where E :: forall a. a -> a
864 -- (/\b. \y::a -> E b y)
866 -- It deals with coerces too, though they are now rare
867 -- so perhaps the extra code isn't worth it
869 eta_expand n us expr ty
871 -- The ILX code generator requires eta expansion for type arguments
872 -- too, but alas the 'n' doesn't tell us how many of them there
873 -- may be. So we eagerly eta expand any big lambdas, and just
874 -- cross our fingers about possible loss of sharing in the ILX case.
875 -- The Right Thing is probably to make 'arity' include
876 -- type variables throughout the compiler. (ToDo.)
878 -- Saturated, so nothing to do
881 -- Short cut for the case where there already
882 -- is a lambda; no point in gratuitously adding more
883 eta_expand n us (Lam v body) ty
885 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
888 = Lam v (eta_expand (n-1) us body (funResultTy ty))
890 -- We used to have a special case that stepped inside Coerces here,
891 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
892 -- = Note note (eta_expand n us e ty)
893 -- BUT this led to an infinite loop
894 -- Example: newtype T = MkT (Int -> Int)
895 -- eta_expand 1 (coerce (Int->Int) e)
896 -- --> coerce (Int->Int) (eta_expand 1 T e)
898 -- --> coerce (Int->Int) (coerce T
899 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
900 -- by the splitNewType_maybe case below
903 eta_expand n us expr ty
904 = case splitForAllTy_maybe ty of {
905 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
909 case splitFunTy_maybe ty of {
910 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
912 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
918 -- newtype T = MkT (Int -> Int)
919 -- Consider eta-expanding this
922 -- coerce T (\x::Int -> (coerce (Int->Int) e) x)
924 case splitNewType_maybe ty of {
925 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
926 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
930 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
931 It tells how many things the expression can be applied to before doing
932 any work. It doesn't look inside cases, lets, etc. The idea is that
933 exprEtaExpandArity will do the hard work, leaving something that's easy
934 for exprArity to grapple with. In particular, Simplify uses exprArity to
935 compute the ArityInfo for the Id.
937 Originally I thought that it was enough just to look for top-level lambdas, but
938 it isn't. I've seen this
940 foo = PrelBase.timesInt
942 We want foo to get arity 2 even though the eta-expander will leave it
943 unchanged, in the expectation that it'll be inlined. But occasionally it
944 isn't, because foo is blacklisted (used in a rule).
946 Similarly, see the ok_note check in exprEtaExpandArity. So
947 f = __inline_me (\x -> e)
948 won't be eta-expanded.
950 And in any case it seems more robust to have exprArity be a bit more intelligent.
951 But note that (\x y z -> f x y z)
952 should have arity 3, regardless of f's arity.
955 exprArity :: CoreExpr -> Arity
958 go (Var v) = idArity v
959 go (Lam x e) | isId x = go e + 1
962 go (App e (Type t)) = go e
963 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
964 -- NB: exprIsCheap a!
965 -- f (fac x) does not have arity 2,
966 -- even if f has arity 3!
967 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
968 -- unknown, hence arity 0
972 %************************************************************************
974 \subsection{Equality}
976 %************************************************************************
978 @cheapEqExpr@ is a cheap equality test which bales out fast!
979 True => definitely equal
980 False => may or may not be equal
983 cheapEqExpr :: Expr b -> Expr b -> Bool
985 cheapEqExpr (Var v1) (Var v2) = v1==v2
986 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
987 cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
989 cheapEqExpr (App f1 a1) (App f2 a2)
990 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
992 cheapEqExpr _ _ = False
994 exprIsBig :: Expr b -> Bool
995 -- Returns True of expressions that are too big to be compared by cheapEqExpr
996 exprIsBig (Lit _) = False
997 exprIsBig (Var v) = False
998 exprIsBig (Type t) = False
999 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1000 exprIsBig other = True
1005 eqExpr :: CoreExpr -> CoreExpr -> Bool
1006 -- Works ok at more general type, but only needed at CoreExpr
1007 -- Used in rule matching, so when we find a type we use
1008 -- eqTcType, which doesn't look through newtypes
1009 -- [And it doesn't risk falling into a black hole either.]
1011 = eq emptyVarEnv e1 e2
1013 -- The "env" maps variables in e1 to variables in ty2
1014 -- So when comparing lambdas etc,
1015 -- we in effect substitute v2 for v1 in e1 before continuing
1016 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
1017 Just v1' -> v1' == v2
1020 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
1021 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
1022 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
1023 eq env (Let (NonRec v1 r1) e1)
1024 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
1025 eq env (Let (Rec ps1) e1)
1026 (Let (Rec ps2) e2) = equalLength ps1 ps2 &&
1027 and (zipWith eq_rhs ps1 ps2) &&
1030 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
1031 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
1032 eq env (Case e1 v1 a1)
1033 (Case e2 v2 a2) = eq env e1 e2 &&
1034 equalLength a1 a2 &&
1035 and (zipWith (eq_alt env') a1 a2)
1037 env' = extendVarEnv env v1 v2
1039 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
1040 eq env (Type t1) (Type t2) = t1 `eqType` t2
1041 eq env e1 e2 = False
1043 eq_list env [] [] = True
1044 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
1045 eq_list env es1 es2 = False
1047 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
1048 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
1050 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1051 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
1052 eq_note env InlineCall InlineCall = True
1053 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1054 eq_note env other1 other2 = False
1058 %************************************************************************
1060 \subsection{The size of an expression}
1062 %************************************************************************
1065 coreBindsSize :: [CoreBind] -> Int
1066 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1068 exprSize :: CoreExpr -> Int
1069 -- A measure of the size of the expressions
1070 -- It also forces the expression pretty drastically as a side effect
1071 exprSize (Var v) = v `seq` 1
1072 exprSize (Lit lit) = lit `seq` 1
1073 exprSize (App f a) = exprSize f + exprSize a
1074 exprSize (Lam b e) = varSize b + exprSize e
1075 exprSize (Let b e) = bindSize b + exprSize e
1076 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
1077 exprSize (Note n e) = noteSize n + exprSize e
1078 exprSize (Type t) = seqType t `seq` 1
1080 noteSize (SCC cc) = cc `seq` 1
1081 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1082 noteSize InlineCall = 1
1083 noteSize InlineMe = 1
1084 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1086 varSize :: Var -> Int
1087 varSize b | isTyVar b = 1
1088 | otherwise = seqType (idType b) `seq`
1089 megaSeqIdInfo (idInfo b) `seq`
1092 varsSize = foldr ((+) . varSize) 0
1094 bindSize (NonRec b e) = varSize b + exprSize e
1095 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1097 pairSize (b,e) = varSize b + exprSize e
1099 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1103 %************************************************************************
1105 \subsection{Hashing}
1107 %************************************************************************
1110 hashExpr :: CoreExpr -> Int
1111 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1114 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1116 hash_expr (Note _ e) = hash_expr e
1117 hash_expr (Let (NonRec b r) e) = hashId b
1118 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1119 hash_expr (Case _ b _) = hashId b
1120 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1121 hash_expr (Var v) = hashId v
1122 hash_expr (Lit lit) = hashLiteral lit
1123 hash_expr (Lam b _) = hashId b
1124 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1126 fast_hash_expr (Var v) = hashId v
1127 fast_hash_expr (Lit lit) = hashLiteral lit
1128 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1129 fast_hash_expr (App f a) = fast_hash_expr a
1130 fast_hash_expr (Lam b _) = hashId b
1131 fast_hash_expr other = 1
1134 hashId id = hashName (idName id)
1137 %************************************************************************
1139 \subsection{Cross-DLL references}
1141 %************************************************************************
1143 Top-level constructor applications can usually be allocated
1144 statically, but they can't if
1145 a) the constructor, or any of the arguments, come from another DLL
1146 b) any of the arguments are LitLits
1147 (because we can't refer to static labels in other DLLs).
1149 If this happens we simply make the RHS into an updatable thunk,
1150 and 'exectute' it rather than allocating it statically.
1152 We also catch lit-lit arguments here, because those cannot be used in
1153 static constructors either. (litlits are deprecated, so I'm not going
1154 to bother cleaning up this infelicity --SDM).
1157 isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
1158 isCrossDllConApp con args =
1159 isDllName (dataConName con) || any isCrossDllArg args
1161 isCrossDllArg :: CoreExpr -> Bool
1162 -- True if somewhere in the expression there's a cross-DLL reference
1163 isCrossDllArg (Type _) = False
1164 isCrossDllArg (Var v) = isDllName (idName v)
1165 isCrossDllArg (Note _ e) = isCrossDllArg e
1166 isCrossDllArg (Lit lit) = isLitLitLit lit
1167 isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2
1168 -- must be a type app
1169 isCrossDllArg (Lam v e) = isCrossDllArg e
1170 -- must be a type lam
1173 %************************************************************************
1175 \subsection{Determining non-updatable right-hand-sides}
1177 %************************************************************************
1180 rhsIsNonUpd :: CoreExpr -> Bool
1181 -- True => Value-lambda, saturated constructor
1182 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1183 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1185 -- b) (C x xs), where C is a contructors is updatable if the application is
1188 -- c) don't look through unfolding of f in (f x).
1190 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1191 -- them as making the RHS re-entrant (non-updatable).
1193 rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e
1194 rhsIsNonUpd (Note (SCC _) e) = False
1195 rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
1196 rhsIsNonUpd other_expr
1197 = go other_expr 0 []
1199 go (Var f) n_args args = idAppIsNonUpd f n_args args
1201 go (App f a) n_args args
1202 | isTypeArg a = go f n_args args
1203 | otherwise = go f (n_args + 1) (a:args)
1205 go (Note (SCC _) f) n_args args = False
1206 go (Note _ f) n_args args = go f n_args args
1208 go other n_args args = False
1210 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
1211 idAppIsNonUpd id n_val_args args
1212 -- saturated constructors are not updatable
1213 | Just con <- isDataConWorkId_maybe id,
1214 n_val_args == dataConRepArity con,
1215 not (isCrossDllConApp con args),
1218 -- NB. args sometimes not atomic. eg.
1219 -- x = D# (1.0## /## 2.0##)
1220 -- can't float because /## can fail.
1223 -- Historical note: we used to make partial applications
1224 -- non-updatable, so they behaved just like PAPs, but this
1225 -- doesn't work too well with eval/apply so it is disabled