2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
10 bindNonRec, needsCaseBinding,
11 mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
13 -- Taking expressions apart
16 -- Properties of expressions
17 exprType, coreAltType,
18 exprIsDupable, exprIsTrivial, exprIsCheap,
19 exprIsValue,exprOkForSpeculation, exprIsBig,
20 exprIsConApp_maybe, exprIsBottom,
23 -- Arity and eta expansion
24 manifestArity, exprArity,
25 exprEtaExpandArity, etaExpand,
34 cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg
37 #include "HsVersions.h"
40 import GLAEXTS -- For `xori`
43 import CoreFVs ( exprFreeVars )
44 import PprCore ( pprCoreExpr )
46 import VarSet ( unionVarSet )
48 import Name ( hashName )
49 import Packages ( isDllName )
50 import DynFlags ( DynFlags )
51 import Literal ( hashLiteral, literalType, litIsDupable,
52 litIsTrivial, isZeroLit, Literal( MachLabel ) )
53 import DataCon ( DataCon, dataConRepArity, dataConArgTys,
54 isVanillaDataCon, dataConTyCon )
55 import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
56 import Id ( Id, idType, globalIdDetails, idNewStrictness,
57 mkWildId, idArity, idName, idUnfolding, idInfo,
58 isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
59 isDataConWorkId, isBottomingId
61 import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
62 import NewDemand ( appIsBottom )
63 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
64 splitFunTy, tcEqTypeX,
65 applyTys, isUnLiftedType, seqType, mkTyVarTy,
66 splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
67 splitTyConApp_maybe, coreEqType, funResultTy, applyTy
69 import TyCon ( tyConArity )
71 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
72 import CostCentre ( CostCentre )
73 import BasicTypes ( Arity )
74 import Unique ( Unique )
76 import TysPrim ( alphaTy ) -- Debugging only
77 import Util ( equalLength, lengthAtLeast, foldl2 )
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 _ _ ty alts) = ty
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 coreAltType :: CoreAlt -> Type
104 coreAltType (_,_,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
161 mkNote :: Note -> CoreExpr -> CoreExpr
162 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
163 mkNote (SCC cc) expr = mkSCC cc expr
164 mkNote InlineMe expr = mkInlineMe expr
165 mkNote note expr = Note note expr
168 -- Slide InlineCall in around the function
169 -- No longer necessary I think (SLPJ Apr 99)
170 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
171 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
172 -- mkNote InlineCall expr = expr
175 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
176 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
177 not be *applied* to anything.
179 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
182 f = inline_me (coerce t fw)
183 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
184 We want the split, so that the coerces can cancel at the call site.
186 However, we can get left with tiresome type applications. Notably, consider
187 f = /\ a -> let t = e in (t, w)
188 Then lifting the let out of the big lambda gives
190 f = /\ a -> let t = inline_me (t' a) in (t, w)
191 The inline_me is to stop the simplifier inlining t' right back
192 into t's RHS. In the next phase we'll substitute for t (since
193 its rhs is trivial) and *then* we could get rid of the inline_me.
194 But it hardly seems worth it, so I don't bother.
197 mkInlineMe (Var v) = Var v
198 mkInlineMe e = Note InlineMe e
204 mkCoerce :: Type -> CoreExpr -> CoreExpr
205 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
207 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
208 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
209 = ASSERT( from_ty `coreEqType` to_ty2 )
210 mkCoerce2 to_ty from_ty2 expr
212 mkCoerce2 to_ty from_ty expr
213 | to_ty `coreEqType` from_ty = expr
214 | otherwise = ASSERT( from_ty `coreEqType` exprType expr )
215 Note (Coerce to_ty from_ty) expr
219 mkSCC :: CostCentre -> Expr b -> Expr b
220 -- Note: Nested SCC's *are* preserved for the benefit of
221 -- cost centre stack profiling
222 mkSCC cc (Lit lit) = Lit lit
223 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
224 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
225 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
226 mkSCC cc expr = Note (SCC cc) expr
230 %************************************************************************
232 \subsection{Other expression construction}
234 %************************************************************************
237 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
238 -- (bindNonRec x r b) produces either
241 -- case r of x { _DEFAULT_ -> b }
243 -- depending on whether x is unlifted or not
244 -- It's used by the desugarer to avoid building bindings
245 -- that give Core Lint a heart attack. Actually the simplifier
246 -- deals with them perfectly well.
248 bindNonRec bndr rhs body
249 | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
250 | otherwise = Let (NonRec bndr rhs) body
252 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
253 -- Make a case expression instead of a let
254 -- These can arise either from the desugarer,
255 -- or from beta reductions: (\x.e) (x +# y)
259 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
260 -- This guy constructs the value that the scrutinee must have
261 -- when you are in one particular branch of a case
262 mkAltExpr (DataAlt con) args inst_tys
263 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
264 mkAltExpr (LitAlt lit) [] []
267 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
268 mkIfThenElse guard then_expr else_expr
269 -- Not going to be refining, so okay to take the type of the "then" clause
270 = Case guard (mkWildId boolTy) (exprType then_expr)
271 [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
272 (DataAlt trueDataCon, [], then_expr) ]
276 %************************************************************************
278 \subsection{Taking expressions apart}
280 %************************************************************************
282 The default alternative must be first, if it exists at all.
283 This makes it easy to find, though it makes matching marginally harder.
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
296 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
299 go (alt@(con1,_,_) : alts) deflt
300 = case con `cmpAltCon` con1 of
301 LT -> deflt -- Missed it already; the alts are in increasing order
303 GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
307 %************************************************************************
309 \subsection{Figuring out things about expressions}
311 %************************************************************************
313 @exprIsTrivial@ is true of expressions we are unconditionally happy to
314 duplicate; simple variables and constants, and type
315 applications. Note that primop Ids aren't considered
318 @exprIsBottom@ is true of expressions that are guaranteed to diverge
321 There used to be a gruesome test for (hasNoBinding v) in the
323 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
324 The idea here is that a constructor worker, like $wJust, is
325 really short for (\x -> $wJust x), becuase $wJust has no binding.
326 So it should be treated like a lambda. Ditto unsaturated primops.
327 But now constructor workers are not "have-no-binding" Ids. And
328 completely un-applied primops and foreign-call Ids are sufficiently
329 rare that I plan to allow them to be duplicated and put up with
332 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
333 a) it really generates code, (and a heap object when it's
334 a function arg) to capture the cost centre
335 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
338 exprIsTrivial (Var v) = True -- See notes above
339 exprIsTrivial (Type _) = True
340 exprIsTrivial (Lit lit) = litIsTrivial lit
341 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
342 exprIsTrivial (Note (SCC _) e) = False -- See notes above
343 exprIsTrivial (Note _ e) = exprIsTrivial e
344 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
345 exprIsTrivial other = False
349 @exprIsDupable@ is true of expressions that can be duplicated at a modest
350 cost in code size. This will only happen in different case
351 branches, so there's no issue about duplicating work.
353 That is, exprIsDupable returns True of (f x) even if
354 f is very very expensive to call.
356 Its only purpose is to avoid fruitless let-binding
357 and then inlining of case join points
361 exprIsDupable (Type _) = True
362 exprIsDupable (Var v) = True
363 exprIsDupable (Lit lit) = litIsDupable lit
364 exprIsDupable (Note InlineMe e) = True
365 exprIsDupable (Note _ e) = exprIsDupable e
369 go (Var v) n_args = True
370 go (App f a) n_args = n_args < dupAppSize
373 go other n_args = False
376 dupAppSize = 4 -- Size of application we are prepared to duplicate
379 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
380 it is obviously in weak head normal form, or is cheap to get to WHNF.
381 [Note that that's not the same as exprIsDupable; an expression might be
382 big, and hence not dupable, but still cheap.]
384 By ``cheap'' we mean a computation we're willing to:
385 push inside a lambda, or
386 inline at more than one place
387 That might mean it gets evaluated more than once, instead of being
388 shared. The main examples of things which aren't WHNF but are
393 (where e, and all the ei are cheap)
396 (where e and b are cheap)
399 (where op is a cheap primitive operator)
402 (because we are happy to substitute it inside a lambda)
404 Notice that a variable is considered 'cheap': we can push it inside a lambda,
405 because sharing will make sure it is only evaluated once.
408 exprIsCheap :: CoreExpr -> Bool
409 exprIsCheap (Lit lit) = True
410 exprIsCheap (Type _) = True
411 exprIsCheap (Var _) = True
412 exprIsCheap (Note InlineMe e) = True
413 exprIsCheap (Note _ e) = exprIsCheap e
414 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
415 exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
416 and [exprIsCheap rhs | (_,_,rhs) <- alts]
417 -- Experimentally, treat (case x of ...) as cheap
418 -- (and case __coerce x etc.)
419 -- This improves arities of overloaded functions where
420 -- there is only dictionary selection (no construction) involved
421 exprIsCheap (Let (NonRec x _) e)
422 | isUnLiftedType (idType x) = exprIsCheap e
424 -- strict lets always have cheap right hand sides, and
427 exprIsCheap other_expr
428 = go other_expr 0 True
430 go (Var f) n_args args_cheap
431 = (idAppIsCheap f n_args && args_cheap)
432 -- A constructor, cheap primop, or partial application
434 || idAppIsBottom f n_args
435 -- Application of a function which
436 -- always gives bottom; we treat this as cheap
437 -- because it certainly doesn't need to be shared!
439 go (App f a) n_args args_cheap
440 | not (isRuntimeArg a) = go f n_args args_cheap
441 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
443 go other n_args args_cheap = False
445 idAppIsCheap :: Id -> Int -> Bool
446 idAppIsCheap id n_val_args
447 | n_val_args == 0 = True -- Just a type application of
448 -- a variable (f t1 t2 t3)
450 | otherwise = case globalIdDetails id of
451 DataConWorkId _ -> True
452 RecordSelId _ _ -> True -- I'm experimenting with making record selection
453 ClassOpId _ -> True -- look cheap, so we will substitute it inside a
454 -- lambda. Particularly for dictionary field selection
456 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
457 -- that return a type variable, since the result
458 -- might be applied to something, but I'm not going
459 -- to bother to check the number of args
460 other -> n_val_args < idArity id
463 exprOkForSpeculation returns True of an expression that it is
465 * safe to evaluate even if normal order eval might not
466 evaluate the expression at all, or
468 * safe *not* to evaluate even if normal order would do so
472 the expression guarantees to terminate,
474 without raising an exception,
475 without causing a side effect (e.g. writing a mutable variable)
478 let x = case y# +# 1# of { r# -> I# r# }
481 case y# +# 1# of { r# ->
486 We can only do this if the (y+1) is ok for speculation: it has no
487 side effects, and can't diverge or raise an exception.
490 exprOkForSpeculation :: CoreExpr -> Bool
491 exprOkForSpeculation (Lit _) = True
492 exprOkForSpeculation (Type _) = True
493 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
494 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
495 exprOkForSpeculation other_expr
496 = case collectArgs other_expr of
497 (Var f, args) -> spec_ok (globalIdDetails f) args
501 spec_ok (DataConWorkId _) args
502 = True -- The strictness of the constructor has already
503 -- been expressed by its "wrapper", so we don't need
504 -- to take the arguments into account
506 spec_ok (PrimOpId op) args
507 | isDivOp op, -- Special case for dividing operations that fail
508 [arg1, Lit lit] <- args -- only if the divisor is zero
509 = not (isZeroLit lit) && exprOkForSpeculation arg1
510 -- Often there is a literal divisor, and this
511 -- can get rid of a thunk in an inner looop
514 = primOpOkForSpeculation op &&
515 all exprOkForSpeculation args
516 -- A bit conservative: we don't really need
517 -- to care about lazy arguments, but this is easy
519 spec_ok other args = False
521 isDivOp :: PrimOp -> Bool
522 -- True of dyadic operators that can fail
523 -- only if the second arg is zero
524 -- This function probably belongs in PrimOp, or even in
525 -- an automagically generated file.. but it's such a
526 -- special case I thought I'd leave it here for now.
527 isDivOp IntQuotOp = True
528 isDivOp IntRemOp = True
529 isDivOp WordQuotOp = True
530 isDivOp WordRemOp = True
531 isDivOp IntegerQuotRemOp = True
532 isDivOp IntegerDivModOp = True
533 isDivOp FloatDivOp = True
534 isDivOp DoubleDivOp = True
535 isDivOp other = False
540 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
541 exprIsBottom e = go 0 e
543 -- n is the number of args
544 go n (Note _ e) = go n e
545 go n (Let _ e) = go n e
546 go n (Case e _ _ _) = go 0 e -- Just check the scrut
547 go n (App e _) = go (n+1) e
548 go n (Var v) = idAppIsBottom v n
550 go n (Lam _ _) = False
551 go n (Type _) = False
553 idAppIsBottom :: Id -> Int -> Bool
554 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
557 @exprIsValue@ returns true for expressions that are certainly *already*
558 evaluated to *head* normal form. This is used to decide whether it's ok
561 case x of _ -> e ===> e
563 and to decide whether it's safe to discard a `seq`
565 So, it does *not* treat variables as evaluated, unless they say they are.
567 But it *does* treat partial applications and constructor applications
568 as values, even if their arguments are non-trivial, provided the argument
570 e.g. (:) (f x) (map f xs) is a value
571 map (...redex...) is a value
572 Because `seq` on such things completes immediately
574 For unlifted argument types, we have to be careful:
576 Suppose (f x) diverges; then C (f x) is not a value. True, but
577 this form is illegal (see the invariants in CoreSyn). Args of unboxed
578 type must be ok-for-speculation (or trivial).
581 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
582 exprIsValue (Var v) -- NB: There are no value args at this point
583 = isDataConWorkId v -- Catches nullary constructors,
584 -- so that [] and () are values, for example
585 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
586 || isEvaldUnfolding (idUnfolding v)
587 -- Check the thing's unfolding; it might be bound to a value
588 -- A worry: what if an Id's unfolding is just itself:
589 -- then we could get an infinite loop...
591 exprIsValue (Lit l) = True
592 exprIsValue (Type ty) = True -- Types are honorary Values;
593 -- we don't mind copying them
594 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
595 exprIsValue (Note _ e) = exprIsValue e
596 exprIsValue (App e (Type _)) = exprIsValue e
597 exprIsValue (App e a) = app_is_value e [a]
598 exprIsValue other = False
600 -- There is at least one value argument
601 app_is_value (Var fun) args
602 | isDataConWorkId fun -- Constructor apps are values
603 || idArity fun > valArgCount args -- Under-applied function
604 = check_args (idType fun) args
605 app_is_value (App f a) as = app_is_value f (a:as)
606 app_is_value other as = False
608 -- 'check_args' checks that unlifted-type args
609 -- are in fact guaranteed non-divergent
610 check_args fun_ty [] = True
611 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
612 Just (_, ty) -> check_args ty args
613 check_args fun_ty (arg : args)
614 | isUnLiftedType arg_ty = exprOkForSpeculation arg
615 | otherwise = check_args res_ty args
617 (arg_ty, res_ty) = splitFunTy fun_ty
621 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
622 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
623 = -- Maybe this is over the top, but here we try to turn
624 -- coerce (S,T) ( x, y )
626 -- ( coerce S x, coerce T y )
627 -- This happens in anger in PrelArrExts which has a coerce
628 -- case coerce memcpy a b of
630 -- where the memcpy is in the IO monad, but the call is in
632 case exprIsConApp_maybe expr of {
636 case splitTyConApp_maybe to_ty of {
638 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
639 | not (isVanillaDataCon dc) -> Nothing
641 -- Type constructor must match
642 -- We knock out existentials to keep matters simple(r)
644 arity = tyConArity tc
645 val_args = drop arity args
646 to_arg_tys = dataConArgTys dc tc_arg_tys
647 mk_coerce ty arg = mkCoerce ty arg
648 new_val_args = zipWith mk_coerce to_arg_tys val_args
650 ASSERT( all isTypeArg (take arity args) )
651 ASSERT( equalLength val_args to_arg_tys )
652 Just (dc, map Type tc_arg_tys ++ new_val_args)
655 exprIsConApp_maybe (Note _ expr)
656 = exprIsConApp_maybe expr
657 -- We ignore InlineMe notes in case we have
658 -- x = __inline_me__ (a,b)
659 -- All part of making sure that INLINE pragmas never hurt
660 -- Marcin tripped on this one when making dictionaries more inlinable
662 -- In fact, we ignore all notes. For example,
663 -- case _scc_ "foo" (C a b) of
665 -- should be optimised away, but it will be only if we look
666 -- through the SCC note.
668 exprIsConApp_maybe expr = analyse (collectArgs expr)
670 analyse (Var fun, args)
671 | Just con <- isDataConWorkId_maybe fun,
672 args `lengthAtLeast` dataConRepArity con
673 -- Might be > because the arity excludes type args
676 -- Look through unfoldings, but only cheap ones, because
677 -- we are effectively duplicating the unfolding
678 analyse (Var fun, [])
679 | let unf = idUnfolding fun,
681 = exprIsConApp_maybe (unfoldingTemplate unf)
683 analyse other = Nothing
688 %************************************************************************
690 \subsection{Eta reduction and expansion}
692 %************************************************************************
695 exprEtaExpandArity :: CoreExpr -> Arity
696 {- The Arity returned is the number of value args the
697 thing can be applied to without doing much work
699 exprEtaExpandArity is used when eta expanding
702 It returns 1 (or more) to:
703 case x of p -> \s -> ...
704 because for I/O ish things we really want to get that \s to the top.
705 We are prepared to evaluate x each time round the loop in order to get that
707 It's all a bit more subtle than it looks:
711 Consider one-shot lambdas
712 let x = expensive in \y z -> E
713 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
714 Hence the ArityType returned by arityType
716 2. The state-transformer hack
718 The one-shot lambda special cause is particularly important/useful for
719 IO state transformers, where we often get
720 let x = E in \ s -> ...
722 and the \s is a real-world state token abstraction. Such abstractions
723 are almost invariably 1-shot, so we want to pull the \s out, past the
724 let x=E, even if E is expensive. So we treat state-token lambdas as
725 one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
727 3. Dealing with bottom
730 f = \x -> error "foo"
731 Here, arity 1 is fine. But if it is
735 then we want to get arity 2. Tecnically, this isn't quite right, because
737 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
738 do so; it improves some programs significantly, and increasing convergence
739 isn't a bad thing. Hence the ABot/ATop in ArityType.
741 Actually, the situation is worse. Consider
745 Can we eta-expand here? At first the answer looks like "yes of course", but
748 This should diverge! But if we eta-expand, it won't. Again, we ignore this
749 "problem", because being scrupulous would lose an important transformation for
754 exprEtaExpandArity e = arityDepth (arityType e)
756 -- A limited sort of function type
757 data ArityType = AFun Bool ArityType -- True <=> one-shot
758 | ATop -- Know nothing
761 arityDepth :: ArityType -> Arity
762 arityDepth (AFun _ ty) = 1 + arityDepth ty
765 andArityType ABot at2 = at2
766 andArityType ATop at2 = ATop
767 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
768 andArityType at1 at2 = andArityType at2 at1
770 arityType :: CoreExpr -> ArityType
771 -- (go1 e) = [b1,..,bn]
772 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
773 -- where bi is True <=> the lambda is one-shot
775 arityType (Note n e) = arityType e
776 -- Not needed any more: etaExpand is cleverer
777 -- | ok_note n = arityType e
778 -- | otherwise = ATop
781 = mk (idArity v) (arg_tys (idType v))
783 mk :: Arity -> [Type] -> ArityType
784 -- The argument types are only to steer the "state hack"
785 -- Consider case x of
787 -- False -> \(s:RealWorld) -> e
788 -- where foo has arity 1. Then we want the state hack to
789 -- apply to foo too, so we can eta expand the case.
790 mk 0 tys | isBottomingId v = ABot
792 mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
793 mk n [] = AFun False (mk (n-1) [])
795 arg_tys :: Type -> [Type] -- Ignore for-alls
797 | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
798 | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
801 -- Lambdas; increase arity
802 arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
803 | otherwise = arityType e
805 -- Applications; decrease arity
806 arityType (App f (Type _)) = arityType f
807 arityType (App f a) = case arityType f of
808 AFun one_shot xs | exprIsCheap a -> xs
811 -- Case/Let; keep arity if either the expression is cheap
812 -- or it's a 1-shot lambda
813 -- The former is not really right for Haskell
814 -- f x = case x of { (a,b) -> \y. e }
816 -- f x y = case x of { (a,b) -> e }
817 -- The difference is observable using 'seq'
818 arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
819 xs@(AFun one_shot _) | one_shot -> xs
820 xs | exprIsCheap scrut -> xs
823 arityType (Let b e) = case arityType e of
824 xs@(AFun one_shot _) | one_shot -> xs
825 xs | all exprIsCheap (rhssOfBind b) -> xs
828 arityType other = ATop
830 {- NOT NEEDED ANY MORE: etaExpand is cleverer
831 ok_note InlineMe = False
833 -- Notice that we do not look through __inline_me__
834 -- This may seem surprising, but consider
835 -- f = _inline_me (\x -> e)
836 -- We DO NOT want to eta expand this to
837 -- f = \x -> (_inline_me (\x -> e)) x
838 -- because the _inline_me gets dropped now it is applied,
847 etaExpand :: Arity -- Result should have this number of value args
849 -> CoreExpr -> Type -- Expression and its type
851 -- (etaExpand n us e ty) returns an expression with
852 -- the same meaning as 'e', but with arity 'n'.
854 -- Given e' = etaExpand n us e ty
856 -- ty = exprType e = exprType e'
858 -- Note that SCCs are not treated specially. If we have
859 -- etaExpand 2 (\x -> scc "foo" e)
860 -- = (\xy -> (scc "foo" e) y)
861 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
863 etaExpand n us expr ty
864 | manifestArity expr >= n = expr -- The no-op case
865 | otherwise = eta_expand n us expr ty
868 -- manifestArity sees how many leading value lambdas there are
869 manifestArity :: CoreExpr -> Arity
870 manifestArity (Lam v e) | isId v = 1 + manifestArity e
871 | otherwise = manifestArity e
872 manifestArity (Note _ e) = manifestArity e
875 -- etaExpand deals with for-alls. For example:
877 -- where E :: forall a. a -> a
879 -- (/\b. \y::a -> E b y)
881 -- It deals with coerces too, though they are now rare
882 -- so perhaps the extra code isn't worth it
884 eta_expand n us expr ty
886 -- The ILX code generator requires eta expansion for type arguments
887 -- too, but alas the 'n' doesn't tell us how many of them there
888 -- may be. So we eagerly eta expand any big lambdas, and just
889 -- cross our fingers about possible loss of sharing in the ILX case.
890 -- The Right Thing is probably to make 'arity' include
891 -- type variables throughout the compiler. (ToDo.)
893 -- Saturated, so nothing to do
896 -- Short cut for the case where there already
897 -- is a lambda; no point in gratuitously adding more
898 eta_expand n us (Lam v body) ty
900 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
903 = Lam v (eta_expand (n-1) us body (funResultTy ty))
905 -- We used to have a special case that stepped inside Coerces here,
906 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
907 -- = Note note (eta_expand n us e ty)
908 -- BUT this led to an infinite loop
909 -- Example: newtype T = MkT (Int -> Int)
910 -- eta_expand 1 (coerce (Int->Int) e)
911 -- --> coerce (Int->Int) (eta_expand 1 T e)
913 -- --> coerce (Int->Int) (coerce T
914 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
915 -- by the splitNewType_maybe case below
918 eta_expand n us expr ty
919 = case splitForAllTy_maybe ty of {
920 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
924 case splitFunTy_maybe ty of {
925 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
927 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
933 -- newtype T = MkT ([T] -> Int)
934 -- Consider eta-expanding this
937 -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
938 -- Only try this for recursive newtypes; the non-recursive kind
939 -- are transparent anyway
941 case splitRecNewType_maybe ty of {
942 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
943 Nothing -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
947 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
948 It tells how many things the expression can be applied to before doing
949 any work. It doesn't look inside cases, lets, etc. The idea is that
950 exprEtaExpandArity will do the hard work, leaving something that's easy
951 for exprArity to grapple with. In particular, Simplify uses exprArity to
952 compute the ArityInfo for the Id.
954 Originally I thought that it was enough just to look for top-level lambdas, but
955 it isn't. I've seen this
957 foo = PrelBase.timesInt
959 We want foo to get arity 2 even though the eta-expander will leave it
960 unchanged, in the expectation that it'll be inlined. But occasionally it
961 isn't, because foo is blacklisted (used in a rule).
963 Similarly, see the ok_note check in exprEtaExpandArity. So
964 f = __inline_me (\x -> e)
965 won't be eta-expanded.
967 And in any case it seems more robust to have exprArity be a bit more intelligent.
968 But note that (\x y z -> f x y z)
969 should have arity 3, regardless of f's arity.
972 exprArity :: CoreExpr -> Arity
975 go (Var v) = idArity v
976 go (Lam x e) | isId x = go e + 1
979 go (App e (Type t)) = go e
980 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
981 -- NB: exprIsCheap a!
982 -- f (fac x) does not have arity 2,
983 -- even if f has arity 3!
984 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
985 -- unknown, hence arity 0
989 %************************************************************************
991 \subsection{Equality}
993 %************************************************************************
995 @cheapEqExpr@ is a cheap equality test which bales out fast!
996 True => definitely equal
997 False => may or may not be equal
1000 cheapEqExpr :: Expr b -> Expr b -> Bool
1002 cheapEqExpr (Var v1) (Var v2) = v1==v2
1003 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1004 cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
1006 cheapEqExpr (App f1 a1) (App f2 a2)
1007 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1009 cheapEqExpr _ _ = False
1011 exprIsBig :: Expr b -> Bool
1012 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1013 exprIsBig (Lit _) = False
1014 exprIsBig (Var v) = False
1015 exprIsBig (Type t) = False
1016 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1017 exprIsBig other = True
1022 tcEqExpr :: CoreExpr -> CoreExpr -> Bool
1023 -- Used in rule matching, so does *not* look through
1024 -- newtypes, predicate types; hence tcEqExpr
1026 tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
1028 rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
1030 tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
1031 tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
1032 tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2
1033 tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
1034 tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
1035 tcEqExprX env (Let (NonRec v1 r1) e1)
1036 (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
1037 && tcEqExprX (rnBndr2 env v1 v2) e1 e2
1038 tcEqExprX env (Let (Rec ps1) e1)
1039 (Let (Rec ps2) e2) = equalLength ps1 ps2
1040 && and (zipWith eq_rhs ps1 ps2)
1041 && tcEqExprX env' e1 e2
1043 env' = foldl2 rn_bndr2 env ps2 ps2
1044 rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
1045 eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
1046 tcEqExprX env (Case e1 v1 t1 a1)
1047 (Case e2 v2 t2 a2) = tcEqExprX env e1 e2
1048 && tcEqTypeX env t1 t2
1049 && equalLength a1 a2
1050 && and (zipWith (eq_alt env') a1 a2)
1052 env' = rnBndr2 env v1 v2
1054 tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
1055 tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
1056 tcEqExprX env e1 e2 = False
1058 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
1060 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1061 eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2
1062 eq_note env InlineCall InlineCall = True
1063 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1064 eq_note env other1 other2 = False
1068 %************************************************************************
1070 \subsection{The size of an expression}
1072 %************************************************************************
1075 coreBindsSize :: [CoreBind] -> Int
1076 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1078 exprSize :: CoreExpr -> Int
1079 -- A measure of the size of the expressions
1080 -- It also forces the expression pretty drastically as a side effect
1081 exprSize (Var v) = v `seq` 1
1082 exprSize (Lit lit) = lit `seq` 1
1083 exprSize (App f a) = exprSize f + exprSize a
1084 exprSize (Lam b e) = varSize b + exprSize e
1085 exprSize (Let b e) = bindSize b + exprSize e
1086 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1087 exprSize (Note n e) = noteSize n + exprSize e
1088 exprSize (Type t) = seqType t `seq` 1
1090 noteSize (SCC cc) = cc `seq` 1
1091 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1092 noteSize InlineCall = 1
1093 noteSize InlineMe = 1
1094 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1096 varSize :: Var -> Int
1097 varSize b | isTyVar b = 1
1098 | otherwise = seqType (idType b) `seq`
1099 megaSeqIdInfo (idInfo b) `seq`
1102 varsSize = foldr ((+) . varSize) 0
1104 bindSize (NonRec b e) = varSize b + exprSize e
1105 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1107 pairSize (b,e) = varSize b + exprSize e
1109 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1113 %************************************************************************
1115 \subsection{Hashing}
1117 %************************************************************************
1120 hashExpr :: CoreExpr -> Int
1121 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1124 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1126 hash_expr (Note _ e) = hash_expr e
1127 hash_expr (Let (NonRec b r) e) = hashId b
1128 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1129 hash_expr (Case _ b _ _) = hashId b
1130 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1131 hash_expr (Var v) = hashId v
1132 hash_expr (Lit lit) = hashLiteral lit
1133 hash_expr (Lam b _) = hashId b
1134 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1136 fast_hash_expr (Var v) = hashId v
1137 fast_hash_expr (Lit lit) = hashLiteral lit
1138 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1139 fast_hash_expr (App f a) = fast_hash_expr a
1140 fast_hash_expr (Lam b _) = hashId b
1141 fast_hash_expr other = 1
1144 hashId id = hashName (idName id)
1147 %************************************************************************
1149 \subsection{Determining non-updatable right-hand-sides}
1151 %************************************************************************
1153 Top-level constructor applications can usually be allocated
1154 statically, but they can't if the constructor, or any of the
1155 arguments, come from another DLL (because we can't refer to static
1156 labels in other DLLs).
1158 If this happens we simply make the RHS into an updatable thunk,
1159 and 'exectute' it rather than allocating it statically.
1162 rhsIsStatic :: DynFlags -> CoreExpr -> Bool
1163 -- This function is called only on *top-level* right-hand sides
1164 -- Returns True if the RHS can be allocated statically, with
1165 -- no thunks involved at all.
1167 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1168 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1169 -- update flag on it.
1171 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1172 -- (a) a value lambda
1173 -- (b) a saturated constructor application with static args
1175 -- BUT watch out for
1176 -- (i) Any cross-DLL references kill static-ness completely
1177 -- because they must be 'executed' not statically allocated
1178 -- ("DLL" here really only refers to Windows DLLs, on other platforms,
1179 -- this is not necessary)
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 dflags 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)
1235 MachLabel _ _ -> False
1237 -- A MachLabel (foreign import "&foo") in an argument
1238 -- prevents a constructor application from being static. The
1239 -- reason is that it might give rise to unresolvable symbols
1240 -- in the object file: under Linux, references to "weak"
1241 -- symbols from the data segment give rise to "unresolvable
1242 -- relocation" errors at link time This might be due to a bug
1243 -- in the linker, but we'll work around it here anyway.
1246 is_static in_arg other_expr = go other_expr 0
1248 go (Var f) n_val_args
1249 #if mingw32_TARGET_OS
1250 | not (isDllName dflags (idName f))
1252 = saturated_data_con f n_val_args
1253 || (in_arg && n_val_args == 0)
1254 -- A naked un-applied variable is *not* deemed a static RHS
1256 -- Reason: better to update so that the indirection gets shorted
1257 -- out, and the true value will be seen
1258 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1259 -- are always updatable. If you do so, make sure that non-updatable
1260 -- ones have enough space for their static link field!
1262 go (App f a) n_val_args
1263 | isTypeArg a = go f n_val_args
1264 | not in_arg && is_static True a = go f (n_val_args + 1)
1265 -- The (not in_arg) checks that we aren't in a constructor argument;
1266 -- if we are, we don't allow (value) applications of any sort
1268 -- NB. In case you wonder, args are sometimes not atomic. eg.
1269 -- x = D# (1.0## /## 2.0##)
1270 -- can't float because /## can fail.
1272 go (Note (SCC _) f) n_val_args = False
1273 go (Note _ f) n_val_args = go f n_val_args
1275 go other n_val_args = False
1277 saturated_data_con f n_val_args
1278 = case isDataConWorkId_maybe f of
1279 Just dc -> n_val_args == dataConRepArity dc