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, eqExpr, applyTypeToArgs, applyTypeToArg
37 #include "HsVersions.h"
40 import GLAEXTS -- For `xori`
43 import PprCore ( pprCoreExpr )
46 import Name ( hashName )
47 import Packages ( isDllName )
48 import CmdLineOpts ( DynFlags )
49 import Literal ( hashLiteral, literalType, litIsDupable,
50 litIsTrivial, isZeroLit, Literal( MachLabel ) )
51 import DataCon ( DataCon, dataConRepArity, dataConArgTys,
52 isVanillaDataCon, dataConTyCon )
53 import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
54 import Id ( Id, idType, globalIdDetails, idNewStrictness,
55 mkWildId, idArity, idName, idUnfolding, idInfo,
56 isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
57 isDataConWorkId, isBottomingId
59 import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
60 import NewDemand ( appIsBottom )
61 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
63 applyTys, isUnLiftedType, seqType, mkTyVarTy,
64 splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
65 splitTyConApp_maybe, eqType, funResultTy, applyTy
67 import TyCon ( tyConArity )
69 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
70 import CostCentre ( CostCentre )
71 import BasicTypes ( Arity )
72 import Unique ( Unique )
74 import TysPrim ( alphaTy ) -- Debugging only
75 import Util ( equalLength, lengthAtLeast )
79 %************************************************************************
81 \subsection{Find the type of a Core atom/expression}
83 %************************************************************************
86 exprType :: CoreExpr -> Type
88 exprType (Var var) = idType var
89 exprType (Lit lit) = literalType lit
90 exprType (Let _ body) = exprType body
92 exprType (Case _ _ ty alts) = ty
93 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
94 exprType (Note other_note e) = exprType e
95 exprType (Lam binder expr) = mkPiType binder (exprType expr)
97 = case collectArgs e of
98 (fun, args) -> applyTypeToArgs e (exprType fun) args
100 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
102 coreAltType :: CoreAlt -> Type
103 coreAltType (_,_,rhs) = exprType rhs
106 @mkPiType@ makes a (->) type or a forall type, depending on whether
107 it is given a type variable or a term variable. We cleverly use the
108 lbvarinfo field to figure out the right annotation for the arrove in
109 case of a term variable.
112 mkPiType :: Var -> Type -> Type -- The more polymorphic version
113 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
115 mkPiTypes vs ty = foldr mkPiType ty vs
118 | isId v = mkFunTy (idType v) ty
119 | otherwise = mkForAllTy v ty
123 applyTypeToArg :: Type -> CoreExpr -> Type
124 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
125 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
127 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
128 -- A more efficient version of applyTypeToArg
129 -- when we have several args
130 -- The first argument is just for debugging
131 applyTypeToArgs e op_ty [] = op_ty
133 applyTypeToArgs e op_ty (Type ty : args)
134 = -- Accumulate type arguments so we can instantiate all at once
137 go rev_tys (Type ty : args) = go (ty:rev_tys) args
138 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
140 op_ty' = applyTys op_ty (reverse rev_tys)
142 applyTypeToArgs e op_ty (other_arg : args)
143 = case (splitFunTy_maybe op_ty) of
144 Just (_, res_ty) -> applyTypeToArgs e res_ty args
145 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
150 %************************************************************************
152 \subsection{Attaching notes}
154 %************************************************************************
156 mkNote removes redundant coercions, and SCCs where possible
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
167 -- Slide InlineCall in around the function
168 -- No longer necessary I think (SLPJ Apr 99)
169 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
170 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
171 -- mkNote InlineCall expr = expr
174 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
175 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
176 not be *applied* to anything.
178 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
181 f = inline_me (coerce t fw)
182 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
183 We want the split, so that the coerces can cancel at the call site.
185 However, we can get left with tiresome type applications. Notably, consider
186 f = /\ a -> let t = e in (t, w)
187 Then lifting the let out of the big lambda gives
189 f = /\ a -> let t = inline_me (t' a) in (t, w)
190 The inline_me is to stop the simplifier inlining t' right back
191 into t's RHS. In the next phase we'll substitute for t (since
192 its rhs is trivial) and *then* we could get rid of the inline_me.
193 But it hardly seems worth it, so I don't bother.
196 mkInlineMe (Var v) = Var v
197 mkInlineMe e = Note InlineMe e
203 mkCoerce :: Type -> CoreExpr -> CoreExpr
204 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
206 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
207 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
208 = ASSERT( from_ty `eqType` to_ty2 )
209 mkCoerce2 to_ty from_ty2 expr
211 mkCoerce2 to_ty from_ty expr
212 | to_ty `eqType` from_ty = expr
213 | otherwise = ASSERT( from_ty `eqType` exprType expr )
214 Note (Coerce to_ty from_ty) expr
218 mkSCC :: CostCentre -> Expr b -> Expr b
219 -- Note: Nested SCC's *are* preserved for the benefit of
220 -- cost centre stack profiling
221 mkSCC cc (Lit lit) = Lit lit
222 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
223 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
224 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
225 mkSCC cc expr = Note (SCC cc) expr
229 %************************************************************************
231 \subsection{Other expression construction}
233 %************************************************************************
236 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
237 -- (bindNonRec x r b) produces either
240 -- case r of x { _DEFAULT_ -> b }
242 -- depending on whether x is unlifted or not
243 -- It's used by the desugarer to avoid building bindings
244 -- that give Core Lint a heart attack. Actually the simplifier
245 -- deals with them perfectly well.
247 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
270 -- Not going to be refining, so okay to take the type of the "then" clause
271 = Case guard (mkWildId boolTy) (exprType then_expr)
272 [ (DataAlt trueDataCon, [], then_expr),
273 (DataAlt falseDataCon, [], else_expr) ]
277 %************************************************************************
279 \subsection{Taking expressions apart}
281 %************************************************************************
283 The default alternative must be first, if it exists at all.
284 This makes it easy to find, though it makes matching marginally harder.
287 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
288 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
289 findDefault alts = (alts, Nothing)
291 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
294 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
295 other -> go alts panic_deflt
298 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
301 go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
302 | otherwise = ASSERT( not (con1 == DEFAULT) )
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
416 exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
417 and [exprIsCheap rhs | (_,_,rhs) <- alts]
418 -- Experimentally, treat (case x of ...) as cheap
419 -- (and case __coerce x etc.)
420 -- This improves arities of overloaded functions where
421 -- there is only dictionary selection (no construction) involved
422 exprIsCheap (Let (NonRec x _) e)
423 | isUnLiftedType (idType x) = exprIsCheap e
425 -- strict lets always have cheap right hand sides, and
428 exprIsCheap other_expr
429 = go other_expr 0 True
431 go (Var f) n_args args_cheap
432 = (idAppIsCheap f n_args && args_cheap)
433 -- A constructor, cheap primop, or partial application
435 || idAppIsBottom f n_args
436 -- Application of a function which
437 -- always gives bottom; we treat this as cheap
438 -- because it certainly doesn't need to be shared!
440 go (App f a) n_args args_cheap
441 | not (isRuntimeArg a) = go f n_args args_cheap
442 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
444 go other n_args args_cheap = False
446 idAppIsCheap :: Id -> Int -> Bool
447 idAppIsCheap id n_val_args
448 | n_val_args == 0 = True -- Just a type application of
449 -- a variable (f t1 t2 t3)
451 | otherwise = case globalIdDetails id of
452 DataConWorkId _ -> True
453 RecordSelId _ _ -> True -- I'm experimenting with making record selection
454 ClassOpId _ -> True -- look cheap, so we will substitute it inside a
455 -- lambda. Particularly for dictionary field selection
457 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
458 -- that return a type variable, since the result
459 -- might be applied to something, but I'm not going
460 -- to bother to check the number of args
461 other -> n_val_args < idArity id
464 exprOkForSpeculation returns True of an expression that it is
466 * safe to evaluate even if normal order eval might not
467 evaluate the expression at all, or
469 * safe *not* to evaluate even if normal order would do so
473 the expression guarantees to terminate,
475 without raising an exception,
476 without causing a side effect (e.g. writing a mutable variable)
479 let x = case y# +# 1# of { r# -> I# r# }
482 case y# +# 1# of { r# ->
487 We can only do this if the (y+1) is ok for speculation: it has no
488 side effects, and can't diverge or raise an exception.
491 exprOkForSpeculation :: CoreExpr -> Bool
492 exprOkForSpeculation (Lit _) = True
493 exprOkForSpeculation (Type _) = True
494 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
495 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
496 exprOkForSpeculation other_expr
497 = case collectArgs other_expr of
498 (Var f, args) -> spec_ok (globalIdDetails f) args
502 spec_ok (DataConWorkId _) args
503 = True -- The strictness of the constructor has already
504 -- been expressed by its "wrapper", so we don't need
505 -- to take the arguments into account
507 spec_ok (PrimOpId op) args
508 | isDivOp op, -- Special case for dividing operations that fail
509 [arg1, Lit lit] <- args -- only if the divisor is zero
510 = not (isZeroLit lit) && exprOkForSpeculation arg1
511 -- Often there is a literal divisor, and this
512 -- can get rid of a thunk in an inner looop
515 = primOpOkForSpeculation op &&
516 all exprOkForSpeculation args
517 -- A bit conservative: we don't really need
518 -- to care about lazy arguments, but this is easy
520 spec_ok other args = False
522 isDivOp :: PrimOp -> Bool
523 -- True of dyadic operators that can fail
524 -- only if the second arg is zero
525 -- This function probably belongs in PrimOp, or even in
526 -- an automagically generated file.. but it's such a
527 -- special case I thought I'd leave it here for now.
528 isDivOp IntQuotOp = True
529 isDivOp IntRemOp = True
530 isDivOp WordQuotOp = True
531 isDivOp WordRemOp = True
532 isDivOp IntegerQuotRemOp = True
533 isDivOp IntegerDivModOp = True
534 isDivOp FloatDivOp = True
535 isDivOp DoubleDivOp = True
536 isDivOp other = False
541 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
542 exprIsBottom e = go 0 e
544 -- n is the number of args
545 go n (Note _ e) = go n e
546 go n (Let _ e) = go n e
548 go n (Case e _ _ _) = go 0 e -- Just check the scrut
549 go n (App e _) = go (n+1) e
550 go n (Var v) = idAppIsBottom v n
552 go n (Lam _ _) = False
554 idAppIsBottom :: Id -> Int -> Bool
555 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
558 @exprIsValue@ returns true for expressions that are certainly *already*
559 evaluated to *head* normal form. This is used to decide whether it's ok
562 case x of _ -> e ===> e
564 and to decide whether it's safe to discard a `seq`
566 So, it does *not* treat variables as evaluated, unless they say they are.
568 But it *does* treat partial applications and constructor applications
569 as values, even if their arguments are non-trivial, provided the argument
571 e.g. (:) (f x) (map f xs) is a value
572 map (...redex...) is a value
573 Because `seq` on such things completes immediately
575 For unlifted argument types, we have to be careful:
577 Suppose (f x) diverges; then C (f x) is not a value. True, but
578 this form is illegal (see the invariants in CoreSyn). Args of unboxed
579 type must be ok-for-speculation (or trivial).
582 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
583 exprIsValue (Var v) -- NB: There are no value args at this point
584 = isDataConWorkId v -- Catches nullary constructors,
585 -- so that [] and () are values, for example
586 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
587 || isEvaldUnfolding (idUnfolding v)
588 -- Check the thing's unfolding; it might be bound to a value
589 -- A worry: what if an Id's unfolding is just itself:
590 -- then we could get an infinite loop...
592 exprIsValue (Lit l) = True
593 exprIsValue (Type ty) = True -- Types are honorary Values;
594 -- we don't mind copying them
595 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
596 exprIsValue (Note _ e) = exprIsValue e
597 exprIsValue (App e (Type _)) = exprIsValue e
598 exprIsValue (App e a) = app_is_value e [a]
599 exprIsValue other = False
601 -- There is at least one value argument
602 app_is_value (Var fun) args
603 | isDataConWorkId fun -- Constructor apps are values
604 || idArity fun > valArgCount args -- Under-applied function
605 = check_args (idType fun) args
606 app_is_value (App f a) as = app_is_value f (a:as)
607 app_is_value other as = False
609 -- 'check_args' checks that unlifted-type args
610 -- are in fact guaranteed non-divergent
611 check_args fun_ty [] = True
612 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
613 Just (_, ty) -> check_args ty args
614 check_args fun_ty (arg : args)
615 | isUnLiftedType arg_ty = exprOkForSpeculation arg
616 | otherwise = check_args res_ty args
618 (arg_ty, res_ty) = splitFunTy fun_ty
622 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
623 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
624 = -- Maybe this is over the top, but here we try to turn
625 -- coerce (S,T) ( x, y )
627 -- ( coerce S x, coerce T y )
628 -- This happens in anger in PrelArrExts which has a coerce
629 -- case coerce memcpy a b of
631 -- where the memcpy is in the IO monad, but the call is in
633 case exprIsConApp_maybe expr of {
637 case splitTyConApp_maybe to_ty of {
639 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
640 | not (isVanillaDataCon dc) -> Nothing
642 -- Type constructor must match
643 -- We knock out existentials to keep matters simple(r)
645 arity = tyConArity tc
646 val_args = drop arity args
647 to_arg_tys = dataConArgTys dc tc_arg_tys
648 mk_coerce ty arg = mkCoerce ty arg
649 new_val_args = zipWith mk_coerce to_arg_tys val_args
651 ASSERT( all isTypeArg (take arity args) )
652 ASSERT( equalLength val_args to_arg_tys )
653 Just (dc, map Type tc_arg_tys ++ new_val_args)
656 exprIsConApp_maybe (Note _ expr)
657 = exprIsConApp_maybe expr
658 -- We ignore InlineMe notes in case we have
659 -- x = __inline_me__ (a,b)
660 -- All part of making sure that INLINE pragmas never hurt
661 -- Marcin tripped on this one when making dictionaries more inlinable
663 -- In fact, we ignore all notes. For example,
664 -- case _scc_ "foo" (C a b) of
666 -- should be optimised away, but it will be only if we look
667 -- through the SCC note.
669 exprIsConApp_maybe expr = analyse (collectArgs expr)
671 analyse (Var fun, args)
672 | Just con <- isDataConWorkId_maybe fun,
673 args `lengthAtLeast` dataConRepArity con
674 -- Might be > because the arity excludes type args
677 -- Look through unfoldings, but only cheap ones, because
678 -- we are effectively duplicating the unfolding
679 analyse (Var fun, [])
680 | let unf = idUnfolding fun,
682 = exprIsConApp_maybe (unfoldingTemplate unf)
684 analyse other = Nothing
689 %************************************************************************
691 \subsection{Eta reduction and expansion}
693 %************************************************************************
696 exprEtaExpandArity :: CoreExpr -> Arity
697 {- The Arity returned is the number of value args the
698 thing can be applied to without doing much work
700 exprEtaExpandArity is used when eta expanding
703 It returns 1 (or more) to:
704 case x of p -> \s -> ...
705 because for I/O ish things we really want to get that \s to the top.
706 We are prepared to evaluate x each time round the loop in order to get that
708 It's all a bit more subtle than it looks:
712 Consider one-shot lambdas
713 let x = expensive in \y z -> E
714 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
715 Hence the ArityType returned by arityType
717 2. The state-transformer hack
719 The one-shot lambda special cause is particularly important/useful for
720 IO state transformers, where we often get
721 let x = E in \ s -> ...
723 and the \s is a real-world state token abstraction. Such abstractions
724 are almost invariably 1-shot, so we want to pull the \s out, past the
725 let x=E, even if E is expensive. So we treat state-token lambdas as
726 one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
728 3. Dealing with bottom
731 f = \x -> error "foo"
732 Here, arity 1 is fine. But if it is
736 then we want to get arity 2. Tecnically, this isn't quite right, because
738 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
739 do so; it improves some programs significantly, and increasing convergence
740 isn't a bad thing. Hence the ABot/ATop in ArityType.
742 Actually, the situation is worse. Consider
746 Can we eta-expand here? At first the answer looks like "yes of course", but
749 This should diverge! But if we eta-expand, it won't. Again, we ignore this
750 "problem", because being scrupulous would lose an important transformation for
755 exprEtaExpandArity e = arityDepth (arityType e)
757 -- A limited sort of function type
758 data ArityType = AFun Bool ArityType -- True <=> one-shot
759 | ATop -- Know nothing
762 arityDepth :: ArityType -> Arity
763 arityDepth (AFun _ ty) = 1 + arityDepth ty
766 andArityType ABot at2 = at2
767 andArityType ATop at2 = ATop
768 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
769 andArityType at1 at2 = andArityType at2 at1
771 arityType :: CoreExpr -> ArityType
772 -- (go1 e) = [b1,..,bn]
773 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
774 -- where bi is True <=> the lambda is one-shot
776 arityType (Note n e) = arityType e
777 -- Not needed any more: etaExpand is cleverer
778 -- | ok_note n = arityType e
779 -- | otherwise = ATop
782 = mk (idArity v) (arg_tys (idType v))
784 mk :: Arity -> [Type] -> ArityType
785 -- The argument types are only to steer the "state hack"
786 -- Consider case x of
788 -- False -> \(s:RealWorld) -> e
789 -- where foo has arity 1. Then we want the state hack to
790 -- apply to foo too, so we can eta expand the case.
791 mk 0 tys | isBottomingId v = ABot
793 mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
794 mk n [] = AFun False (mk (n-1) [])
796 arg_tys :: Type -> [Type] -- Ignore for-alls
798 | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
799 | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
802 -- Lambdas; increase arity
803 arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
804 | otherwise = arityType e
806 -- Applications; decrease arity
807 arityType (App f (Type _)) = arityType f
808 arityType (App f a) = case arityType f of
809 AFun one_shot xs | exprIsCheap a -> xs
812 -- Case/Let; keep arity if either the expression is cheap
813 -- or it's a 1-shot lambda
814 -- The former is not really right for Haskell
815 -- f x = case x of { (a,b) -> \y. e }
817 -- f x y = case x of { (a,b) -> e }
818 -- The difference is observable using 'seq'
820 arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
821 xs@(AFun one_shot _) | one_shot -> xs
822 xs | exprIsCheap scrut -> xs
825 arityType (Let b e) = case arityType e of
826 xs@(AFun one_shot _) | one_shot -> xs
827 xs | all exprIsCheap (rhssOfBind b) -> xs
830 arityType other = ATop
832 {- NOT NEEDED ANY MORE: etaExpand is cleverer
833 ok_note InlineMe = False
835 -- Notice that we do not look through __inline_me__
836 -- This may seem surprising, but consider
837 -- f = _inline_me (\x -> e)
838 -- We DO NOT want to eta expand this to
839 -- f = \x -> (_inline_me (\x -> e)) x
840 -- because the _inline_me gets dropped now it is applied,
849 etaExpand :: Arity -- Result should have this number of value args
851 -> CoreExpr -> Type -- Expression and its type
853 -- (etaExpand n us e ty) returns an expression with
854 -- the same meaning as 'e', but with arity 'n'.
856 -- Given e' = etaExpand n us e ty
858 -- ty = exprType e = exprType e'
860 -- Note that SCCs are not treated specially. If we have
861 -- etaExpand 2 (\x -> scc "foo" e)
862 -- = (\xy -> (scc "foo" e) y)
863 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
865 etaExpand n us expr ty
866 | manifestArity expr >= n = expr -- The no-op case
867 | otherwise = eta_expand n us expr ty
870 -- manifestArity sees how many leading value lambdas there are
871 manifestArity :: CoreExpr -> Arity
872 manifestArity (Lam v e) | isId v = 1 + manifestArity e
873 | otherwise = manifestArity e
874 manifestArity (Note _ e) = manifestArity e
877 -- etaExpand deals with for-alls. For example:
879 -- where E :: forall a. a -> a
881 -- (/\b. \y::a -> E b y)
883 -- It deals with coerces too, though they are now rare
884 -- so perhaps the extra code isn't worth it
886 eta_expand n us expr ty
888 -- The ILX code generator requires eta expansion for type arguments
889 -- too, but alas the 'n' doesn't tell us how many of them there
890 -- may be. So we eagerly eta expand any big lambdas, and just
891 -- cross our fingers about possible loss of sharing in the ILX case.
892 -- The Right Thing is probably to make 'arity' include
893 -- type variables throughout the compiler. (ToDo.)
895 -- Saturated, so nothing to do
898 -- Short cut for the case where there already
899 -- is a lambda; no point in gratuitously adding more
900 eta_expand n us (Lam v body) ty
902 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
905 = Lam v (eta_expand (n-1) us body (funResultTy ty))
907 -- We used to have a special case that stepped inside Coerces here,
908 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
909 -- = Note note (eta_expand n us e ty)
910 -- BUT this led to an infinite loop
911 -- Example: newtype T = MkT (Int -> Int)
912 -- eta_expand 1 (coerce (Int->Int) e)
913 -- --> coerce (Int->Int) (eta_expand 1 T e)
915 -- --> coerce (Int->Int) (coerce T
916 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
917 -- by the splitNewType_maybe case below
920 eta_expand n us expr ty
921 = case splitForAllTy_maybe ty of {
922 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
926 case splitFunTy_maybe ty of {
927 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
929 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
935 -- newtype T = MkT ([T] -> Int)
936 -- Consider eta-expanding this
939 -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
940 -- Only try this for recursive newtypes; the non-recursive kind
941 -- are transparent anyway
943 case splitRecNewType_maybe ty of {
944 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
945 Nothing -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
949 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
950 It tells how many things the expression can be applied to before doing
951 any work. It doesn't look inside cases, lets, etc. The idea is that
952 exprEtaExpandArity will do the hard work, leaving something that's easy
953 for exprArity to grapple with. In particular, Simplify uses exprArity to
954 compute the ArityInfo for the Id.
956 Originally I thought that it was enough just to look for top-level lambdas, but
957 it isn't. I've seen this
959 foo = PrelBase.timesInt
961 We want foo to get arity 2 even though the eta-expander will leave it
962 unchanged, in the expectation that it'll be inlined. But occasionally it
963 isn't, because foo is blacklisted (used in a rule).
965 Similarly, see the ok_note check in exprEtaExpandArity. So
966 f = __inline_me (\x -> e)
967 won't be eta-expanded.
969 And in any case it seems more robust to have exprArity be a bit more intelligent.
970 But note that (\x y z -> f x y z)
971 should have arity 3, regardless of f's arity.
974 exprArity :: CoreExpr -> Arity
977 go (Var v) = idArity v
978 go (Lam x e) | isId x = go e + 1
981 go (App e (Type t)) = go e
982 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
983 -- NB: exprIsCheap a!
984 -- f (fac x) does not have arity 2,
985 -- even if f has arity 3!
986 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
987 -- unknown, hence arity 0
991 %************************************************************************
993 \subsection{Equality}
995 %************************************************************************
997 @cheapEqExpr@ is a cheap equality test which bales out fast!
998 True => definitely equal
999 False => may or may not be equal
1002 cheapEqExpr :: Expr b -> Expr b -> Bool
1004 cheapEqExpr (Var v1) (Var v2) = v1==v2
1005 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1006 cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
1008 cheapEqExpr (App f1 a1) (App f2 a2)
1009 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1011 cheapEqExpr _ _ = False
1013 exprIsBig :: Expr b -> Bool
1014 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1015 exprIsBig (Lit _) = False
1016 exprIsBig (Var v) = False
1017 exprIsBig (Type t) = False
1018 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1019 exprIsBig other = True
1024 eqExpr :: CoreExpr -> CoreExpr -> Bool
1025 -- Works ok at more general type, but only needed at CoreExpr
1026 -- Used in rule matching, so when we find a type we use
1027 -- eqTcType, which doesn't look through newtypes
1028 -- [And it doesn't risk falling into a black hole either.]
1030 = eq emptyVarEnv e1 e2
1032 -- The "env" maps variables in e1 to variables in ty2
1033 -- So when comparing lambdas etc,
1034 -- we in effect substitute v2 for v1 in e1 before continuing
1035 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
1036 Just v1' -> v1' == v2
1039 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
1040 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
1041 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
1042 eq env (Let (NonRec v1 r1) e1)
1043 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
1044 eq env (Let (Rec ps1) e1)
1045 (Let (Rec ps2) e2) = equalLength ps1 ps2 &&
1046 and (zipWith eq_rhs ps1 ps2) &&
1049 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
1050 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
1051 eq env (Case e1 v1 t1 a1)
1052 (Case e2 v2 t2 a2) = eq env e1 e2 &&
1054 equalLength a1 a2 &&
1055 and (zipWith (eq_alt env') a1 a2)
1057 env' = extendVarEnv env v1 v2
1059 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
1060 eq env (Type t1) (Type t2) = t1 `eqType` t2
1061 eq env e1 e2 = False
1063 eq_list env [] [] = True
1064 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
1065 eq_list env es1 es2 = False
1067 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
1068 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
1070 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1071 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
1072 eq_note env InlineCall InlineCall = True
1073 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1074 eq_note env other1 other2 = False
1078 %************************************************************************
1080 \subsection{The size of an expression}
1082 %************************************************************************
1085 coreBindsSize :: [CoreBind] -> Int
1086 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1088 exprSize :: CoreExpr -> Int
1089 -- A measure of the size of the expressions
1090 -- It also forces the expression pretty drastically as a side effect
1091 exprSize (Var v) = v `seq` 1
1092 exprSize (Lit lit) = lit `seq` 1
1093 exprSize (App f a) = exprSize f + exprSize a
1094 exprSize (Lam b e) = varSize b + exprSize e
1095 exprSize (Let b e) = bindSize b + exprSize e
1097 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1098 exprSize (Note n e) = noteSize n + exprSize e
1099 exprSize (Type t) = seqType t `seq` 1
1101 noteSize (SCC cc) = cc `seq` 1
1102 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1103 noteSize InlineCall = 1
1104 noteSize InlineMe = 1
1105 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1107 varSize :: Var -> Int
1108 varSize b | isTyVar b = 1
1109 | otherwise = seqType (idType b) `seq`
1110 megaSeqIdInfo (idInfo b) `seq`
1113 varsSize = foldr ((+) . varSize) 0
1115 bindSize (NonRec b e) = varSize b + exprSize e
1116 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1118 pairSize (b,e) = varSize b + exprSize e
1120 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1124 %************************************************************************
1126 \subsection{Hashing}
1128 %************************************************************************
1131 hashExpr :: CoreExpr -> Int
1132 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1135 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1137 hash_expr (Note _ e) = hash_expr e
1138 hash_expr (Let (NonRec b r) e) = hashId b
1139 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1141 hash_expr (Case _ b _ _) = hashId b
1142 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1143 hash_expr (Var v) = hashId v
1144 hash_expr (Lit lit) = hashLiteral lit
1145 hash_expr (Lam b _) = hashId b
1146 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1148 fast_hash_expr (Var v) = hashId v
1149 fast_hash_expr (Lit lit) = hashLiteral lit
1150 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1151 fast_hash_expr (App f a) = fast_hash_expr a
1152 fast_hash_expr (Lam b _) = hashId b
1153 fast_hash_expr other = 1
1156 hashId id = hashName (idName id)
1159 %************************************************************************
1161 \subsection{Determining non-updatable right-hand-sides}
1163 %************************************************************************
1165 Top-level constructor applications can usually be allocated
1166 statically, but they can't if the constructor, or any of the
1167 arguments, come from another DLL (because we can't refer to static
1168 labels in other DLLs).
1170 If this happens we simply make the RHS into an updatable thunk,
1171 and 'exectute' it rather than allocating it statically.
1174 rhsIsStatic :: DynFlags -> CoreExpr -> Bool
1175 -- This function is called only on *top-level* right-hand sides
1176 -- Returns True if the RHS can be allocated statically, with
1177 -- no thunks involved at all.
1179 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1180 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1181 -- update flag on it.
1183 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1184 -- (a) a value lambda
1185 -- (b) a saturated constructor application with static args
1187 -- BUT watch out for
1188 -- (i) Any cross-DLL references kill static-ness completely
1189 -- because they must be 'executed' not statically allocated
1191 -- (ii) We treat partial applications as redexes, because in fact we
1192 -- make a thunk for them that runs and builds a PAP
1193 -- at run-time. The only appliations that are treated as
1194 -- static are *saturated* applications of constructors.
1196 -- We used to try to be clever with nested structures like this:
1197 -- ys = (:) w ((:) w [])
1198 -- on the grounds that CorePrep will flatten ANF-ise it later.
1199 -- But supporting this special case made the function much more
1200 -- complicated, because the special case only applies if there are no
1201 -- enclosing type lambdas:
1202 -- ys = /\ a -> Foo (Baz ([] a))
1203 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1205 -- But in fact, even without -O, nested structures at top level are
1206 -- flattened by the simplifier, so we don't need to be super-clever here.
1210 -- f = \x::Int. x+7 TRUE
1211 -- p = (True,False) TRUE
1213 -- d = (fst p, False) FALSE because there's a redex inside
1214 -- (this particular one doesn't happen but...)
1216 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1217 -- n = /\a. Nil a TRUE
1219 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1222 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1223 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1225 -- b) (C x xs), where C is a contructors is updatable if the application is
1228 -- c) don't look through unfolding of f in (f x).
1230 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1231 -- them as making the RHS re-entrant (non-updatable).
1233 rhsIsStatic dflags rhs = is_static False rhs
1235 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1238 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1240 is_static in_arg (Note (SCC _) e) = False
1241 is_static in_arg (Note _ e) = is_static in_arg e
1243 is_static in_arg (Lit lit)
1245 MachLabel _ _ -> False
1247 -- A MachLabel (foreign import "&foo") in an argument
1248 -- prevents a constructor application from being static. The
1249 -- reason is that it might give rise to unresolvable symbols
1250 -- in the object file: under Linux, references to "weak"
1251 -- symbols from the data segment give rise to "unresolvable
1252 -- relocation" errors at link time This might be due to a bug
1253 -- in the linker, but we'll work around it here anyway.
1256 is_static in_arg other_expr = go other_expr 0
1258 go (Var f) n_val_args
1259 | not (isDllName dflags (idName f))
1260 = saturated_data_con f n_val_args
1261 || (in_arg && n_val_args == 0)
1262 -- A naked un-applied variable is *not* deemed a static RHS
1264 -- Reason: better to update so that the indirection gets shorted
1265 -- out, and the true value will be seen
1266 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1267 -- are always updatable. If you do so, make sure that non-updatable
1268 -- ones have enough space for their static link field!
1270 go (App f a) n_val_args
1271 | isTypeArg a = go f n_val_args
1272 | not in_arg && is_static True a = go f (n_val_args + 1)
1273 -- The (not in_arg) checks that we aren't in a constructor argument;
1274 -- if we are, we don't allow (value) applications of any sort
1276 -- NB. In case you wonder, args are sometimes not atomic. eg.
1277 -- x = D# (1.0## /## 2.0##)
1278 -- can't float because /## can fail.
1280 go (Note (SCC _) f) n_val_args = False
1281 go (Note _ f) n_val_args = go f n_val_args
1283 go other n_val_args = False
1285 saturated_data_con f n_val_args
1286 = case isDataConWorkId_maybe f of
1287 Just dc -> n_val_args == dataConRepArity dc