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,
23 -- Arity and eta expansion
24 manifestArity, exprArity,
25 exprEtaExpandArity, etaExpand,
34 cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
37 #include "HsVersions.h"
40 import GLAEXTS -- For `xori`
43 import PprCore ( pprCoreExpr )
44 import Var ( Var, isId, isTyVar )
46 import Name ( hashName, isDllName )
47 import Literal ( hashLiteral, literalType, litIsDupable,
48 litIsTrivial, isZeroLit, isLitLitLit )
49 import DataCon ( DataCon, dataConRepArity, dataConArgTys,
50 isExistentialDataCon, dataConTyCon, dataConName )
51 import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
52 import Id ( Id, idType, globalIdDetails, idNewStrictness,
53 mkWildId, idArity, idName, idUnfolding, idInfo,
54 isOneShotLambda, isDataConWorkId_maybe, mkSysLocal,
55 isDataConWorkId, isBottomingId
57 import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
58 import NewDemand ( appIsBottom )
59 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
61 applyTys, isUnLiftedType, seqType, mkTyVarTy,
62 splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
63 splitTyConApp_maybe, eqType, funResultTy, applyTy,
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
73 import Util ( equalLength, lengthAtLeast )
74 import TysPrim ( statePrimTyCon )
78 %************************************************************************
80 \subsection{Find the type of a Core atom/expression}
82 %************************************************************************
85 exprType :: CoreExpr -> Type
87 exprType (Var var) = idType var
88 exprType (Lit lit) = literalType lit
89 exprType (Let _ body) = exprType body
90 exprType (Case _ _ alts) = coreAltsType alts
91 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
92 exprType (Note other_note e) = exprType e
93 exprType (Lam binder expr) = mkPiType binder (exprType expr)
95 = case collectArgs e of
96 (fun, args) -> applyTypeToArgs e (exprType fun) args
98 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
100 coreAltsType :: [CoreAlt] -> Type
101 coreAltsType ((_,_,rhs) : _) = exprType rhs
104 @mkPiType@ makes a (->) type or a forall type, depending on whether
105 it is given a type variable or a term variable. We cleverly use the
106 lbvarinfo field to figure out the right annotation for the arrove in
107 case of a term variable.
110 mkPiType :: Var -> Type -> Type -- The more polymorphic version
111 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
113 mkPiTypes vs ty = foldr mkPiType ty vs
116 | isId v = mkFunTy (idType v) ty
117 | otherwise = mkForAllTy v ty
121 applyTypeToArg :: Type -> CoreExpr -> Type
122 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
123 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
125 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
126 -- A more efficient version of applyTypeToArg
127 -- when we have several args
128 -- The first argument is just for debugging
129 applyTypeToArgs e op_ty [] = op_ty
131 applyTypeToArgs e op_ty (Type ty : args)
132 = -- Accumulate type arguments so we can instantiate all at once
135 go rev_tys (Type ty : args) = go (ty:rev_tys) args
136 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
138 op_ty' = applyTys op_ty (reverse rev_tys)
140 applyTypeToArgs e op_ty (other_arg : args)
141 = case (splitFunTy_maybe op_ty) of
142 Just (_, res_ty) -> applyTypeToArgs e res_ty args
143 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
148 %************************************************************************
150 \subsection{Attaching notes}
152 %************************************************************************
154 mkNote removes redundant coercions, and SCCs where possible
157 mkNote :: Note -> CoreExpr -> CoreExpr
158 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
159 mkNote (SCC cc) expr = mkSCC cc expr
160 mkNote InlineMe expr = mkInlineMe expr
161 mkNote note expr = Note note expr
163 -- Slide InlineCall in around the function
164 -- No longer necessary I think (SLPJ Apr 99)
165 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
166 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
167 -- mkNote InlineCall expr = expr
170 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
171 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
172 not be *applied* to anything.
174 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
177 f = inline_me (coerce t fw)
178 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
179 We want the split, so that the coerces can cancel at the call site.
181 However, we can get left with tiresome type applications. Notably, consider
182 f = /\ a -> let t = e in (t, w)
183 Then lifting the let out of the big lambda gives
185 f = /\ a -> let t = inline_me (t' a) in (t, w)
186 The inline_me is to stop the simplifier inlining t' right back
187 into t's RHS. In the next phase we'll substitute for t (since
188 its rhs is trivial) and *then* we could get rid of the inline_me.
189 But it hardly seems worth it, so I don't bother.
192 mkInlineMe (Var v) = Var v
193 mkInlineMe e = Note InlineMe e
199 mkCoerce :: Type -> CoreExpr -> CoreExpr
200 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
202 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
203 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
204 = ASSERT( from_ty `eqType` to_ty2 )
205 mkCoerce2 to_ty from_ty2 expr
207 mkCoerce2 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) = litIsTrivial lit
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
339 @exprIsDupable@ is true of expressions that can be duplicated at a modest
340 cost in code size. This will only happen in different case
341 branches, so there's no issue about duplicating work.
343 That is, exprIsDupable returns True of (f x) even if
344 f is very very expensive to call.
346 Its only purpose is to avoid fruitless let-binding
347 and then inlining of case join points
351 exprIsDupable (Type _) = True
352 exprIsDupable (Var v) = True
353 exprIsDupable (Lit lit) = litIsDupable lit
354 exprIsDupable (Note InlineMe e) = True
355 exprIsDupable (Note _ e) = exprIsDupable e
359 go (Var v) n_args = True
360 go (App f a) n_args = n_args < dupAppSize
363 go other n_args = False
366 dupAppSize = 4 -- Size of application we are prepared to duplicate
369 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
370 it is obviously in weak head normal form, or is cheap to get to WHNF.
371 [Note that that's not the same as exprIsDupable; an expression might be
372 big, and hence not dupable, but still cheap.]
374 By ``cheap'' we mean a computation we're willing to:
375 push inside a lambda, or
376 inline at more than one place
377 That might mean it gets evaluated more than once, instead of being
378 shared. The main examples of things which aren't WHNF but are
383 (where e, and all the ei are cheap)
386 (where e and b are cheap)
389 (where op is a cheap primitive operator)
392 (because we are happy to substitute it inside a lambda)
394 Notice that a variable is considered 'cheap': we can push it inside a lambda,
395 because sharing will make sure it is only evaluated once.
398 exprIsCheap :: CoreExpr -> Bool
399 exprIsCheap (Lit lit) = True
400 exprIsCheap (Type _) = True
401 exprIsCheap (Var _) = True
402 exprIsCheap (Note InlineMe e) = True
403 exprIsCheap (Note _ e) = exprIsCheap e
404 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
405 exprIsCheap (Case e _ alts) = exprIsCheap e &&
406 and [exprIsCheap rhs | (_,_,rhs) <- alts]
407 -- Experimentally, treat (case x of ...) as cheap
408 -- (and case __coerce x etc.)
409 -- This improves arities of overloaded functions where
410 -- there is only dictionary selection (no construction) involved
411 exprIsCheap (Let (NonRec x _) e)
412 | isUnLiftedType (idType x) = exprIsCheap e
414 -- strict lets always have cheap right hand sides, and
417 exprIsCheap other_expr
418 = go other_expr 0 True
420 go (Var f) n_args args_cheap
421 = (idAppIsCheap f n_args && args_cheap)
422 -- A constructor, cheap primop, or partial application
424 || idAppIsBottom f n_args
425 -- Application of a function which
426 -- always gives bottom; we treat this as cheap
427 -- because it certainly doesn't need to be shared!
429 go (App f a) n_args args_cheap
430 | not (isRuntimeArg a) = go f n_args args_cheap
431 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
433 go other n_args args_cheap = False
435 idAppIsCheap :: Id -> Int -> Bool
436 idAppIsCheap id n_val_args
437 | n_val_args == 0 = True -- Just a type application of
438 -- a variable (f t1 t2 t3)
440 | otherwise = case globalIdDetails id of
441 DataConWorkId _ -> True
442 RecordSelId _ -> True -- I'm experimenting with making record selection
443 ClassOpId _ -> True -- look cheap, so we will substitute it inside a
444 -- lambda. Particularly for dictionary field selection
446 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
447 -- that return a type variable, since the result
448 -- might be applied to something, but I'm not going
449 -- to bother to check the number of args
450 other -> n_val_args < idArity id
453 exprOkForSpeculation returns True of an expression that it is
455 * safe to evaluate even if normal order eval might not
456 evaluate the expression at all, or
458 * safe *not* to evaluate even if normal order would do so
462 the expression guarantees to terminate,
464 without raising an exception,
465 without causing a side effect (e.g. writing a mutable variable)
468 let x = case y# +# 1# of { r# -> I# r# }
471 case y# +# 1# of { r# ->
476 We can only do this if the (y+1) is ok for speculation: it has no
477 side effects, and can't diverge or raise an exception.
480 exprOkForSpeculation :: CoreExpr -> Bool
481 exprOkForSpeculation (Lit _) = True
482 exprOkForSpeculation (Type _) = True
483 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
484 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
485 exprOkForSpeculation other_expr
486 = case collectArgs other_expr of
487 (Var f, args) -> spec_ok (globalIdDetails f) args
491 spec_ok (DataConWorkId _) args
492 = True -- The strictness of the constructor has already
493 -- been expressed by its "wrapper", so we don't need
494 -- to take the arguments into account
496 spec_ok (PrimOpId op) args
497 | isDivOp op, -- Special case for dividing operations that fail
498 [arg1, Lit lit] <- args -- only if the divisor is zero
499 = not (isZeroLit lit) && exprOkForSpeculation arg1
500 -- Often there is a literal divisor, and this
501 -- can get rid of a thunk in an inner looop
504 = primOpOkForSpeculation op &&
505 all exprOkForSpeculation args
506 -- A bit conservative: we don't really need
507 -- to care about lazy arguments, but this is easy
509 spec_ok other args = False
511 isDivOp :: PrimOp -> Bool
512 -- True of dyadic operators that can fail
513 -- only if the second arg is zero
514 -- This function probably belongs in PrimOp, or even in
515 -- an automagically generated file.. but it's such a
516 -- special case I thought I'd leave it here for now.
517 isDivOp IntQuotOp = True
518 isDivOp IntRemOp = True
519 isDivOp WordQuotOp = True
520 isDivOp WordRemOp = True
521 isDivOp IntegerQuotRemOp = True
522 isDivOp IntegerDivModOp = True
523 isDivOp FloatDivOp = True
524 isDivOp DoubleDivOp = True
525 isDivOp other = False
530 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
531 exprIsBottom e = go 0 e
533 -- n is the number of args
534 go n (Note _ e) = go n e
535 go n (Let _ e) = go n e
536 go n (Case e _ _) = go 0 e -- Just check the scrut
537 go n (App e _) = go (n+1) e
538 go n (Var v) = idAppIsBottom v n
540 go n (Lam _ _) = False
542 idAppIsBottom :: Id -> Int -> Bool
543 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
546 @exprIsValue@ returns true for expressions that are certainly *already*
547 evaluated to *head* normal form. This is used to decide whether it's ok
550 case x of _ -> e ===> e
552 and to decide whether it's safe to discard a `seq`
554 So, it does *not* treat variables as evaluated, unless they say they are.
556 But it *does* treat partial applications and constructor applications
557 as values, even if their arguments are non-trivial, provided the argument
559 e.g. (:) (f x) (map f xs) is a value
560 map (...redex...) is a value
561 Because `seq` on such things completes immediately
563 For unlifted argument types, we have to be careful:
565 Suppose (f x) diverges; then C (f x) is not a value. True, but
566 this form is illegal (see the invariants in CoreSyn). Args of unboxed
567 type must be ok-for-speculation (or trivial).
570 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
571 exprIsValue (Var v) -- NB: There are no value args at this point
572 = isDataConWorkId v -- Catches nullary constructors,
573 -- so that [] and () are values, for example
574 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
575 || isEvaldUnfolding (idUnfolding v)
576 -- Check the thing's unfolding; it might be bound to a value
577 -- A worry: what if an Id's unfolding is just itself:
578 -- then we could get an infinite loop...
580 exprIsValue (Lit l) = True
581 exprIsValue (Type ty) = True -- Types are honorary Values;
582 -- we don't mind copying them
583 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
584 exprIsValue (Note _ e) = exprIsValue e
585 exprIsValue (App e (Type _)) = exprIsValue e
586 exprIsValue (App e a) = app_is_value e [a]
587 exprIsValue other = False
589 -- There is at least one value argument
590 app_is_value (Var fun) args
591 | isDataConWorkId fun -- Constructor apps are values
592 || idArity fun > valArgCount args -- Under-applied function
593 = check_args (idType fun) args
594 app_is_value (App f a) as = app_is_value f (a:as)
595 app_is_value other as = False
597 -- 'check_args' checks that unlifted-type args
598 -- are in fact guaranteed non-divergent
599 check_args fun_ty [] = True
600 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
601 Just (_, ty) -> check_args ty args
602 check_args fun_ty (arg : args)
603 | isUnLiftedType arg_ty = exprOkForSpeculation arg
604 | otherwise = check_args res_ty args
606 (arg_ty, res_ty) = splitFunTy fun_ty
610 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
611 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
612 = -- Maybe this is over the top, but here we try to turn
613 -- coerce (S,T) ( x, y )
615 -- ( coerce S x, coerce T y )
616 -- This happens in anger in PrelArrExts which has a coerce
617 -- case coerce memcpy a b of
619 -- where the memcpy is in the IO monad, but the call is in
621 case exprIsConApp_maybe expr of {
625 case splitTyConApp_maybe to_ty of {
627 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
628 | isExistentialDataCon dc -> Nothing
630 -- Type constructor must match
631 -- We knock out existentials to keep matters simple(r)
633 arity = tyConArity tc
634 val_args = drop arity args
635 to_arg_tys = dataConArgTys dc tc_arg_tys
636 mk_coerce ty arg = mkCoerce ty arg
637 new_val_args = zipWith mk_coerce to_arg_tys val_args
639 ASSERT( all isTypeArg (take arity args) )
640 ASSERT( equalLength val_args to_arg_tys )
641 Just (dc, map Type tc_arg_tys ++ new_val_args)
644 exprIsConApp_maybe (Note _ expr)
645 = exprIsConApp_maybe expr
646 -- We ignore InlineMe notes in case we have
647 -- x = __inline_me__ (a,b)
648 -- All part of making sure that INLINE pragmas never hurt
649 -- Marcin tripped on this one when making dictionaries more inlinable
651 -- In fact, we ignore all notes. For example,
652 -- case _scc_ "foo" (C a b) of
654 -- should be optimised away, but it will be only if we look
655 -- through the SCC note.
657 exprIsConApp_maybe expr = analyse (collectArgs expr)
659 analyse (Var fun, args)
660 | Just con <- isDataConWorkId_maybe fun,
661 args `lengthAtLeast` dataConRepArity con
662 -- Might be > because the arity excludes type args
665 -- Look through unfoldings, but only cheap ones, because
666 -- we are effectively duplicating the unfolding
667 analyse (Var fun, [])
668 | let unf = idUnfolding fun,
670 = exprIsConApp_maybe (unfoldingTemplate unf)
672 analyse other = Nothing
677 %************************************************************************
679 \subsection{Eta reduction and expansion}
681 %************************************************************************
684 exprEtaExpandArity :: CoreExpr -> Arity
685 {- The Arity returned is the number of value args the
686 thing can be applied to without doing much work
688 exprEtaExpandArity is used when eta expanding
691 It returns 1 (or more) to:
692 case x of p -> \s -> ...
693 because for I/O ish things we really want to get that \s to the top.
694 We are prepared to evaluate x each time round the loop in order to get that
696 It's all a bit more subtle than it looks:
700 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 2. The state-transformer hack
707 The one-shot lambda special cause is particularly important/useful for
708 IO state transformers, where we often get
709 let x = E in \ s -> ...
711 and the \s is a real-world state token abstraction. Such abstractions
712 are almost invariably 1-shot, so we want to pull the \s out, past the
713 let x=E, even if E is expensive. So we treat state-token lambdas as
714 one-shot even if they aren't really. The hack is in Id.isOneShotLambda.
716 3. Dealing with bottom
719 f = \x -> error "foo"
720 Here, arity 1 is fine. But if it is
724 then we want to get arity 2. Tecnically, this isn't quite right, because
726 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
727 do so; it improves some programs significantly, and increasing convergence
728 isn't a bad thing. Hence the ABot/ATop in ArityType.
730 Actually, the situation is worse. Consider
734 Can we eta-expand here? At first the answer looks like "yes of course", but
737 This should diverge! But if we eta-expand, it won't. Again, we ignore this
738 "problem", because being scrupulous would lose an important transformation for
743 exprEtaExpandArity e = arityDepth (arityType e)
745 -- A limited sort of function type
746 data ArityType = AFun Bool ArityType -- True <=> one-shot
747 | ATop -- Know nothing
750 arityDepth :: ArityType -> Arity
751 arityDepth (AFun _ ty) = 1 + arityDepth ty
754 andArityType ABot at2 = at2
755 andArityType ATop at2 = ATop
756 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
757 andArityType at1 at2 = andArityType at2 at1
759 arityType :: CoreExpr -> ArityType
760 -- (go1 e) = [b1,..,bn]
761 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
762 -- where bi is True <=> the lambda is one-shot
764 arityType (Note n e) = arityType e
765 -- Not needed any more: etaExpand is cleverer
766 -- | ok_note n = arityType e
767 -- | otherwise = ATop
772 mk :: Arity -> ArityType
773 mk 0 | isBottomingId v = ABot
775 mk n = AFun False (mk (n-1))
777 -- When the type of the Id encodes one-shot-ness,
778 -- use the idinfo here
780 -- Lambdas; increase arity
781 arityType (Lam x e) | isId x = AFun (isOneShotLambda x || isStateHack x) (arityType e)
782 | otherwise = arityType e
784 -- Applications; decrease arity
785 arityType (App f (Type _)) = arityType f
786 arityType (App f a) = case arityType f of
787 AFun one_shot xs | exprIsCheap a -> xs
790 -- Case/Let; keep arity if either the expression is cheap
791 -- or it's a 1-shot lambda
792 arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
793 xs@(AFun one_shot _) | one_shot -> xs
794 xs | exprIsCheap scrut -> xs
797 arityType (Let b e) = case arityType e of
798 xs@(AFun one_shot _) | one_shot -> xs
799 xs | all exprIsCheap (rhssOfBind b) -> xs
802 arityType other = ATop
804 isStateHack id = case splitTyConApp_maybe (idType id) of
805 Just (tycon,_) | tycon == statePrimTyCon -> True
808 -- The last clause is a gross hack. It claims that
809 -- every function over realWorldStatePrimTy is a one-shot
810 -- function. This is pretty true in practice, and makes a big
811 -- difference. For example, consider
812 -- a `thenST` \ r -> ...E...
813 -- The early full laziness pass, if it doesn't know that r is one-shot
814 -- will pull out E (let's say it doesn't mention r) to give
815 -- let lvl = E in a `thenST` \ r -> ...lvl...
816 -- When `thenST` gets inlined, we end up with
817 -- let lvl = E in \s -> case a s of (r, s') -> ...lvl...
818 -- and we don't re-inline E.
820 -- It would be better to spot that r was one-shot to start with, but
821 -- I don't want to rely on that.
823 -- Another good example is in fill_in in PrelPack.lhs. We should be able to
824 -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
826 {- NOT NEEDED ANY MORE: etaExpand is cleverer
827 ok_note InlineMe = False
829 -- Notice that we do not look through __inline_me__
830 -- This may seem surprising, but consider
831 -- f = _inline_me (\x -> e)
832 -- We DO NOT want to eta expand this to
833 -- f = \x -> (_inline_me (\x -> e)) x
834 -- because the _inline_me gets dropped now it is applied,
843 etaExpand :: Arity -- Result should have this number of value args
845 -> CoreExpr -> Type -- Expression and its type
847 -- (etaExpand n us e ty) returns an expression with
848 -- the same meaning as 'e', but with arity 'n'.
850 -- Given e' = etaExpand n us e ty
852 -- ty = exprType e = exprType e'
854 -- Note that SCCs are not treated specially. If we have
855 -- etaExpand 2 (\x -> scc "foo" e)
856 -- = (\xy -> (scc "foo" e) y)
857 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
859 etaExpand n us expr ty
860 | manifestArity expr >= n = expr -- The no-op case
861 | otherwise = eta_expand n us expr ty
864 -- manifestArity sees how many leading value lambdas there are
865 manifestArity :: CoreExpr -> Arity
866 manifestArity (Lam v e) | isId v = 1 + manifestArity e
867 | otherwise = manifestArity e
868 manifestArity (Note _ e) = manifestArity e
871 -- etaExpand deals with for-alls. For example:
873 -- where E :: forall a. a -> a
875 -- (/\b. \y::a -> E b y)
877 -- It deals with coerces too, though they are now rare
878 -- so perhaps the extra code isn't worth it
880 eta_expand n us expr ty
882 -- The ILX code generator requires eta expansion for type arguments
883 -- too, but alas the 'n' doesn't tell us how many of them there
884 -- may be. So we eagerly eta expand any big lambdas, and just
885 -- cross our fingers about possible loss of sharing in the ILX case.
886 -- The Right Thing is probably to make 'arity' include
887 -- type variables throughout the compiler. (ToDo.)
889 -- Saturated, so nothing to do
892 -- Short cut for the case where there already
893 -- is a lambda; no point in gratuitously adding more
894 eta_expand n us (Lam v body) ty
896 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
899 = Lam v (eta_expand (n-1) us body (funResultTy ty))
901 -- We used to have a special case that stepped inside Coerces here,
902 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
903 -- = Note note (eta_expand n us e ty)
904 -- BUT this led to an infinite loop
905 -- Example: newtype T = MkT (Int -> Int)
906 -- eta_expand 1 (coerce (Int->Int) e)
907 -- --> coerce (Int->Int) (eta_expand 1 T e)
909 -- --> coerce (Int->Int) (coerce T
910 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
911 -- by the splitNewType_maybe case below
914 eta_expand n us expr ty
915 = case splitForAllTy_maybe ty of {
916 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
920 case splitFunTy_maybe ty of {
921 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
923 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
929 -- newtype T = MkT (Int -> Int)
930 -- Consider eta-expanding this
933 -- coerce T (\x::Int -> (coerce (Int->Int) e) x)
935 case splitNewType_maybe ty of {
936 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
937 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
941 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
942 It tells how many things the expression can be applied to before doing
943 any work. It doesn't look inside cases, lets, etc. The idea is that
944 exprEtaExpandArity will do the hard work, leaving something that's easy
945 for exprArity to grapple with. In particular, Simplify uses exprArity to
946 compute the ArityInfo for the Id.
948 Originally I thought that it was enough just to look for top-level lambdas, but
949 it isn't. I've seen this
951 foo = PrelBase.timesInt
953 We want foo to get arity 2 even though the eta-expander will leave it
954 unchanged, in the expectation that it'll be inlined. But occasionally it
955 isn't, because foo is blacklisted (used in a rule).
957 Similarly, see the ok_note check in exprEtaExpandArity. So
958 f = __inline_me (\x -> e)
959 won't be eta-expanded.
961 And in any case it seems more robust to have exprArity be a bit more intelligent.
962 But note that (\x y z -> f x y z)
963 should have arity 3, regardless of f's arity.
966 exprArity :: CoreExpr -> Arity
969 go (Var v) = idArity v
970 go (Lam x e) | isId x = go e + 1
973 go (App e (Type t)) = go e
974 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
975 -- NB: exprIsCheap a!
976 -- f (fac x) does not have arity 2,
977 -- even if f has arity 3!
978 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
979 -- unknown, hence arity 0
983 %************************************************************************
985 \subsection{Equality}
987 %************************************************************************
989 @cheapEqExpr@ is a cheap equality test which bales out fast!
990 True => definitely equal
991 False => may or may not be equal
994 cheapEqExpr :: Expr b -> Expr b -> Bool
996 cheapEqExpr (Var v1) (Var v2) = v1==v2
997 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
998 cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
1000 cheapEqExpr (App f1 a1) (App f2 a2)
1001 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1003 cheapEqExpr _ _ = False
1005 exprIsBig :: Expr b -> Bool
1006 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1007 exprIsBig (Lit _) = False
1008 exprIsBig (Var v) = False
1009 exprIsBig (Type t) = False
1010 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1011 exprIsBig other = True
1016 eqExpr :: CoreExpr -> CoreExpr -> Bool
1017 -- Works ok at more general type, but only needed at CoreExpr
1018 -- Used in rule matching, so when we find a type we use
1019 -- eqTcType, which doesn't look through newtypes
1020 -- [And it doesn't risk falling into a black hole either.]
1022 = eq emptyVarEnv e1 e2
1024 -- The "env" maps variables in e1 to variables in ty2
1025 -- So when comparing lambdas etc,
1026 -- we in effect substitute v2 for v1 in e1 before continuing
1027 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
1028 Just v1' -> v1' == v2
1031 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
1032 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
1033 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
1034 eq env (Let (NonRec v1 r1) e1)
1035 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
1036 eq env (Let (Rec ps1) e1)
1037 (Let (Rec ps2) e2) = equalLength ps1 ps2 &&
1038 and (zipWith eq_rhs ps1 ps2) &&
1041 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
1042 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
1043 eq env (Case e1 v1 a1)
1044 (Case e2 v2 a2) = eq env e1 e2 &&
1045 equalLength a1 a2 &&
1046 and (zipWith (eq_alt env') a1 a2)
1048 env' = extendVarEnv env v1 v2
1050 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
1051 eq env (Type t1) (Type t2) = t1 `eqType` t2
1052 eq env e1 e2 = False
1054 eq_list env [] [] = True
1055 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
1056 eq_list env es1 es2 = False
1058 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
1059 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
1061 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1062 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
1063 eq_note env InlineCall InlineCall = True
1064 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1065 eq_note env other1 other2 = False
1069 %************************************************************************
1071 \subsection{The size of an expression}
1073 %************************************************************************
1076 coreBindsSize :: [CoreBind] -> Int
1077 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1079 exprSize :: CoreExpr -> Int
1080 -- A measure of the size of the expressions
1081 -- It also forces the expression pretty drastically as a side effect
1082 exprSize (Var v) = v `seq` 1
1083 exprSize (Lit lit) = lit `seq` 1
1084 exprSize (App f a) = exprSize f + exprSize a
1085 exprSize (Lam b e) = varSize b + exprSize e
1086 exprSize (Let b e) = bindSize b + exprSize e
1087 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
1088 exprSize (Note n e) = noteSize n + exprSize e
1089 exprSize (Type t) = seqType t `seq` 1
1091 noteSize (SCC cc) = cc `seq` 1
1092 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1093 noteSize InlineCall = 1
1094 noteSize InlineMe = 1
1095 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1097 varSize :: Var -> Int
1098 varSize b | isTyVar b = 1
1099 | otherwise = seqType (idType b) `seq`
1100 megaSeqIdInfo (idInfo b) `seq`
1103 varsSize = foldr ((+) . varSize) 0
1105 bindSize (NonRec b e) = varSize b + exprSize e
1106 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1108 pairSize (b,e) = varSize b + exprSize e
1110 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1114 %************************************************************************
1116 \subsection{Hashing}
1118 %************************************************************************
1121 hashExpr :: CoreExpr -> Int
1122 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1125 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1127 hash_expr (Note _ e) = hash_expr e
1128 hash_expr (Let (NonRec b r) e) = hashId b
1129 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1130 hash_expr (Case _ b _) = hashId b
1131 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1132 hash_expr (Var v) = hashId v
1133 hash_expr (Lit lit) = hashLiteral lit
1134 hash_expr (Lam b _) = hashId b
1135 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1137 fast_hash_expr (Var v) = hashId v
1138 fast_hash_expr (Lit lit) = hashLiteral lit
1139 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1140 fast_hash_expr (App f a) = fast_hash_expr a
1141 fast_hash_expr (Lam b _) = hashId b
1142 fast_hash_expr other = 1
1145 hashId id = hashName (idName id)
1148 %************************************************************************
1150 \subsection{Determining non-updatable right-hand-sides}
1152 %************************************************************************
1154 Top-level constructor applications can usually be allocated
1155 statically, but they can't if
1156 a) the constructor, or any of the arguments, come from another DLL
1157 b) any of the arguments are LitLits
1158 (because we can't refer to static labels in other DLLs).
1160 If this happens we simply make the RHS into an updatable thunk,
1161 and 'exectute' it rather than allocating it statically.
1164 rhsIsStatic :: CoreExpr -> Bool
1165 -- This function is called only on *top-level* right-hand sides
1166 -- Returns True if the RHS can be allocated statically, with
1167 -- no thunks involved at all.
1169 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1170 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1171 -- update flag on it.
1173 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1174 -- (a) a value lambda
1175 -- (b) a saturated constructor application with static args
1177 -- BUT watch out for
1178 -- (i) Any cross-DLL references kill static-ness completely
1179 -- because they must be 'executed' not statically allocated
1181 -- (ii) We treat partial applications as redexes, because in fact we
1182 -- make a thunk for them that runs and builds a PAP
1183 -- at run-time. The only appliations that are treated as
1184 -- static are *saturated* applications of constructors.
1186 -- We used to try to be clever with nested structures like this:
1187 -- ys = (:) w ((:) w [])
1188 -- on the grounds that CorePrep will flatten ANF-ise it later.
1189 -- But supporting this special case made the function much more
1190 -- complicated, because the special case only applies if there are no
1191 -- enclosing type lambdas:
1192 -- ys = /\ a -> Foo (Baz ([] a))
1193 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1195 -- But in fact, even without -O, nested structures at top level are
1196 -- flattened by the simplifier, so we don't need to be super-clever here.
1200 -- f = \x::Int. x+7 TRUE
1201 -- p = (True,False) TRUE
1203 -- d = (fst p, False) FALSE because there's a redex inside
1204 -- (this particular one doesn't happen but...)
1206 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1207 -- n = /\a. Nil a TRUE
1209 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1212 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1213 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1215 -- b) (C x xs), where C is a contructors is updatable if the application is
1218 -- c) don't look through unfolding of f in (f x).
1220 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1221 -- them as making the RHS re-entrant (non-updatable).
1223 rhsIsStatic rhs = is_static False rhs
1225 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1228 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1230 is_static in_arg (Note (SCC _) e) = False
1231 is_static in_arg (Note _ e) = is_static in_arg e
1233 is_static in_arg (Lit lit) = not (isLitLitLit lit)
1234 -- lit-lit arguments cannot be used in static constructors either.
1235 -- (litlits are deprecated, so I'm not going to bother cleaning up this infelicity --SDM).
1237 is_static in_arg other_expr = go other_expr 0
1239 go (Var f) n_val_args
1240 | not (isDllName (idName f))
1241 = saturated_data_con f n_val_args
1242 || (in_arg && n_val_args == 0)
1243 -- A naked un-applied variable is *not* deemed a static RHS
1245 -- Reason: better to update so that the indirection gets shorted
1246 -- out, and the true value will be seen
1247 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1248 -- are always updatable. If you do so, make sure that non-updatable
1249 -- ones have enough space for their static link field!
1251 go (App f a) n_val_args
1252 | isTypeArg a = go f n_val_args
1253 | not in_arg && is_static True a = go f (n_val_args + 1)
1254 -- The (not in_arg) checks that we aren't in a constructor argument;
1255 -- if we are, we don't allow (value) applications of any sort
1257 -- NB. In case you wonder, args are sometimes not atomic. eg.
1258 -- x = D# (1.0## /## 2.0##)
1259 -- can't float because /## can fail.
1261 go (Note (SCC _) f) n_val_args = False
1262 go (Note _ f) n_val_args = go f n_val_args
1264 go other n_val_args = False
1266 saturated_data_con f n_val_args
1267 = case isDataConWorkId_maybe f of
1268 Just dc -> n_val_args == dataConRepArity dc