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 )
44 import Var ( Var, isId, isTyVar )
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,
68 import TyCon ( tyConArity )
70 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
71 import CostCentre ( CostCentre )
72 import BasicTypes ( Arity )
73 import Unique ( Unique )
75 import TysPrim ( alphaTy ) -- Debugging only
76 import Util ( equalLength, lengthAtLeast )
80 %************************************************************************
82 \subsection{Find the type of a Core atom/expression}
84 %************************************************************************
87 exprType :: CoreExpr -> Type
89 exprType (Var var) = idType var
90 exprType (Lit lit) = literalType lit
91 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 `eqType` to_ty2 )
210 mkCoerce2 to_ty from_ty2 expr
212 mkCoerce2 to_ty from_ty expr
213 | to_ty `eqType` from_ty = expr
214 | otherwise = ASSERT( from_ty `eqType` 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
250 | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
251 | otherwise = Let (NonRec bndr rhs) body
253 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
254 -- Make a case expression instead of a let
255 -- These can arise either from the desugarer,
256 -- or from beta reductions: (\x.e) (x +# y)
260 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
261 -- This guy constructs the value that the scrutinee must have
262 -- when you are in one particular branch of a case
263 mkAltExpr (DataAlt con) args inst_tys
264 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
265 mkAltExpr (LitAlt lit) [] []
268 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
269 mkIfThenElse guard then_expr else_expr
271 -- Not going to be refining, so okay to take the type of the "then" clause
272 = Case guard (mkWildId boolTy) (exprType then_expr)
273 [ (DataAlt trueDataCon, [], then_expr),
274 (DataAlt falseDataCon, [], else_expr) ]
278 %************************************************************************
280 \subsection{Taking expressions apart}
282 %************************************************************************
284 The default alternative must be first, if it exists at all.
285 This makes it easy to find, though it makes matching marginally harder.
288 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
289 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
290 findDefault alts = (alts, Nothing)
292 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
295 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
296 other -> go alts panic_deflt
299 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
302 go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
303 | otherwise = ASSERT( not (con1 == DEFAULT) )
308 %************************************************************************
310 \subsection{Figuring out things about expressions}
312 %************************************************************************
314 @exprIsTrivial@ is true of expressions we are unconditionally happy to
315 duplicate; simple variables and constants, and type
316 applications. Note that primop Ids aren't considered
319 @exprIsBottom@ is true of expressions that are guaranteed to diverge
322 There used to be a gruesome test for (hasNoBinding v) in the
324 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
325 The idea here is that a constructor worker, like $wJust, is
326 really short for (\x -> $wJust x), becuase $wJust has no binding.
327 So it should be treated like a lambda. Ditto unsaturated primops.
328 But now constructor workers are not "have-no-binding" Ids. And
329 completely un-applied primops and foreign-call Ids are sufficiently
330 rare that I plan to allow them to be duplicated and put up with
333 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
334 a) it really generates code, (and a heap object when it's
335 a function arg) to capture the cost centre
336 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
339 exprIsTrivial (Var v) = True -- See notes above
340 exprIsTrivial (Type _) = True
341 exprIsTrivial (Lit lit) = litIsTrivial lit
342 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
343 exprIsTrivial (Note (SCC _) e) = False -- See notes above
344 exprIsTrivial (Note _ e) = exprIsTrivial e
345 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
346 exprIsTrivial other = False
350 @exprIsDupable@ is true of expressions that can be duplicated at a modest
351 cost in code size. This will only happen in different case
352 branches, so there's no issue about duplicating work.
354 That is, exprIsDupable returns True of (f x) even if
355 f is very very expensive to call.
357 Its only purpose is to avoid fruitless let-binding
358 and then inlining of case join points
362 exprIsDupable (Type _) = True
363 exprIsDupable (Var v) = True
364 exprIsDupable (Lit lit) = litIsDupable lit
365 exprIsDupable (Note InlineMe e) = True
366 exprIsDupable (Note _ e) = exprIsDupable e
370 go (Var v) n_args = True
371 go (App f a) n_args = n_args < dupAppSize
374 go other n_args = False
377 dupAppSize = 4 -- Size of application we are prepared to duplicate
380 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
381 it is obviously in weak head normal form, or is cheap to get to WHNF.
382 [Note that that's not the same as exprIsDupable; an expression might be
383 big, and hence not dupable, but still cheap.]
385 By ``cheap'' we mean a computation we're willing to:
386 push inside a lambda, or
387 inline at more than one place
388 That might mean it gets evaluated more than once, instead of being
389 shared. The main examples of things which aren't WHNF but are
394 (where e, and all the ei are cheap)
397 (where e and b are cheap)
400 (where op is a cheap primitive operator)
403 (because we are happy to substitute it inside a lambda)
405 Notice that a variable is considered 'cheap': we can push it inside a lambda,
406 because sharing will make sure it is only evaluated once.
409 exprIsCheap :: CoreExpr -> Bool
410 exprIsCheap (Lit lit) = True
411 exprIsCheap (Type _) = True
412 exprIsCheap (Var _) = True
413 exprIsCheap (Note InlineMe e) = True
414 exprIsCheap (Note _ e) = exprIsCheap e
415 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
417 exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
418 and [exprIsCheap rhs | (_,_,rhs) <- alts]
419 -- Experimentally, treat (case x of ...) as cheap
420 -- (and case __coerce x etc.)
421 -- This improves arities of overloaded functions where
422 -- there is only dictionary selection (no construction) involved
423 exprIsCheap (Let (NonRec x _) e)
424 | isUnLiftedType (idType x) = exprIsCheap e
426 -- strict lets always have cheap right hand sides, and
429 exprIsCheap other_expr
430 = go other_expr 0 True
432 go (Var f) n_args args_cheap
433 = (idAppIsCheap f n_args && args_cheap)
434 -- A constructor, cheap primop, or partial application
436 || idAppIsBottom f n_args
437 -- Application of a function which
438 -- always gives bottom; we treat this as cheap
439 -- because it certainly doesn't need to be shared!
441 go (App f a) n_args args_cheap
442 | not (isRuntimeArg a) = go f n_args args_cheap
443 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
445 go other n_args args_cheap = False
447 idAppIsCheap :: Id -> Int -> Bool
448 idAppIsCheap id n_val_args
449 | n_val_args == 0 = True -- Just a type application of
450 -- a variable (f t1 t2 t3)
452 | otherwise = case globalIdDetails id of
453 DataConWorkId _ -> True
454 RecordSelId _ _ -> True -- I'm experimenting with making record selection
455 ClassOpId _ -> True -- look cheap, so we will substitute it inside a
456 -- lambda. Particularly for dictionary field selection
458 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
459 -- that return a type variable, since the result
460 -- might be applied to something, but I'm not going
461 -- to bother to check the number of args
462 other -> n_val_args < idArity id
465 exprOkForSpeculation returns True of an expression that it is
467 * safe to evaluate even if normal order eval might not
468 evaluate the expression at all, or
470 * safe *not* to evaluate even if normal order would do so
474 the expression guarantees to terminate,
476 without raising an exception,
477 without causing a side effect (e.g. writing a mutable variable)
480 let x = case y# +# 1# of { r# -> I# r# }
483 case y# +# 1# of { r# ->
488 We can only do this if the (y+1) is ok for speculation: it has no
489 side effects, and can't diverge or raise an exception.
492 exprOkForSpeculation :: CoreExpr -> Bool
493 exprOkForSpeculation (Lit _) = True
494 exprOkForSpeculation (Type _) = True
495 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
496 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
497 exprOkForSpeculation other_expr
498 = case collectArgs other_expr of
499 (Var f, args) -> spec_ok (globalIdDetails f) args
503 spec_ok (DataConWorkId _) args
504 = True -- The strictness of the constructor has already
505 -- been expressed by its "wrapper", so we don't need
506 -- to take the arguments into account
508 spec_ok (PrimOpId op) args
509 | isDivOp op, -- Special case for dividing operations that fail
510 [arg1, Lit lit] <- args -- only if the divisor is zero
511 = not (isZeroLit lit) && exprOkForSpeculation arg1
512 -- Often there is a literal divisor, and this
513 -- can get rid of a thunk in an inner looop
516 = primOpOkForSpeculation op &&
517 all exprOkForSpeculation args
518 -- A bit conservative: we don't really need
519 -- to care about lazy arguments, but this is easy
521 spec_ok other args = False
523 isDivOp :: PrimOp -> Bool
524 -- True of dyadic operators that can fail
525 -- only if the second arg is zero
526 -- This function probably belongs in PrimOp, or even in
527 -- an automagically generated file.. but it's such a
528 -- special case I thought I'd leave it here for now.
529 isDivOp IntQuotOp = True
530 isDivOp IntRemOp = True
531 isDivOp WordQuotOp = True
532 isDivOp WordRemOp = True
533 isDivOp IntegerQuotRemOp = True
534 isDivOp IntegerDivModOp = True
535 isDivOp FloatDivOp = True
536 isDivOp DoubleDivOp = True
537 isDivOp other = False
542 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
543 exprIsBottom e = go 0 e
545 -- n is the number of args
546 go n (Note _ e) = go n e
547 go n (Let _ e) = go n e
549 go n (Case e _ _ _) = go 0 e -- Just check the scrut
550 go n (App e _) = go (n+1) e
551 go n (Var v) = idAppIsBottom v n
553 go n (Lam _ _) = False
555 idAppIsBottom :: Id -> Int -> Bool
556 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
559 @exprIsValue@ returns true for expressions that are certainly *already*
560 evaluated to *head* normal form. This is used to decide whether it's ok
563 case x of _ -> e ===> e
565 and to decide whether it's safe to discard a `seq`
567 So, it does *not* treat variables as evaluated, unless they say they are.
569 But it *does* treat partial applications and constructor applications
570 as values, even if their arguments are non-trivial, provided the argument
572 e.g. (:) (f x) (map f xs) is a value
573 map (...redex...) is a value
574 Because `seq` on such things completes immediately
576 For unlifted argument types, we have to be careful:
578 Suppose (f x) diverges; then C (f x) is not a value. True, but
579 this form is illegal (see the invariants in CoreSyn). Args of unboxed
580 type must be ok-for-speculation (or trivial).
583 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
584 exprIsValue (Var v) -- NB: There are no value args at this point
585 = isDataConWorkId v -- Catches nullary constructors,
586 -- so that [] and () are values, for example
587 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
588 || isEvaldUnfolding (idUnfolding v)
589 -- Check the thing's unfolding; it might be bound to a value
590 -- A worry: what if an Id's unfolding is just itself:
591 -- then we could get an infinite loop...
593 exprIsValue (Lit l) = True
594 exprIsValue (Type ty) = True -- Types are honorary Values;
595 -- we don't mind copying them
596 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
597 exprIsValue (Note _ e) = exprIsValue e
598 exprIsValue (App e (Type _)) = exprIsValue e
599 exprIsValue (App e a) = app_is_value e [a]
600 exprIsValue other = False
602 -- There is at least one value argument
603 app_is_value (Var fun) args
604 | isDataConWorkId fun -- Constructor apps are values
605 || idArity fun > valArgCount args -- Under-applied function
606 = check_args (idType fun) args
607 app_is_value (App f a) as = app_is_value f (a:as)
608 app_is_value other as = False
610 -- 'check_args' checks that unlifted-type args
611 -- are in fact guaranteed non-divergent
612 check_args fun_ty [] = True
613 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
614 Just (_, ty) -> check_args ty args
615 check_args fun_ty (arg : args)
616 | isUnLiftedType arg_ty = exprOkForSpeculation arg
617 | otherwise = check_args res_ty args
619 (arg_ty, res_ty) = splitFunTy fun_ty
623 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
624 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
625 = -- Maybe this is over the top, but here we try to turn
626 -- coerce (S,T) ( x, y )
628 -- ( coerce S x, coerce T y )
629 -- This happens in anger in PrelArrExts which has a coerce
630 -- case coerce memcpy a b of
632 -- where the memcpy is in the IO monad, but the call is in
634 case exprIsConApp_maybe expr of {
638 case splitTyConApp_maybe to_ty of {
640 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
641 | not (isVanillaDataCon dc) -> Nothing
643 -- Type constructor must match
644 -- We knock out existentials to keep matters simple(r)
646 arity = tyConArity tc
647 val_args = drop arity args
648 to_arg_tys = dataConArgTys dc tc_arg_tys
649 mk_coerce ty arg = mkCoerce ty arg
650 new_val_args = zipWith mk_coerce to_arg_tys val_args
652 ASSERT( all isTypeArg (take arity args) )
653 ASSERT( equalLength val_args to_arg_tys )
654 Just (dc, map Type tc_arg_tys ++ new_val_args)
657 exprIsConApp_maybe (Note _ expr)
658 = exprIsConApp_maybe expr
659 -- We ignore InlineMe notes in case we have
660 -- x = __inline_me__ (a,b)
661 -- All part of making sure that INLINE pragmas never hurt
662 -- Marcin tripped on this one when making dictionaries more inlinable
664 -- In fact, we ignore all notes. For example,
665 -- case _scc_ "foo" (C a b) of
667 -- should be optimised away, but it will be only if we look
668 -- through the SCC note.
670 exprIsConApp_maybe expr = analyse (collectArgs expr)
672 analyse (Var fun, args)
673 | Just con <- isDataConWorkId_maybe fun,
674 args `lengthAtLeast` dataConRepArity con
675 -- Might be > because the arity excludes type args
678 -- Look through unfoldings, but only cheap ones, because
679 -- we are effectively duplicating the unfolding
680 analyse (Var fun, [])
681 | let unf = idUnfolding fun,
683 = exprIsConApp_maybe (unfoldingTemplate unf)
685 analyse other = Nothing
690 %************************************************************************
692 \subsection{Eta reduction and expansion}
694 %************************************************************************
697 exprEtaExpandArity :: CoreExpr -> Arity
698 {- The Arity returned is the number of value args the
699 thing can be applied to without doing much work
701 exprEtaExpandArity is used when eta expanding
704 It returns 1 (or more) to:
705 case x of p -> \s -> ...
706 because for I/O ish things we really want to get that \s to the top.
707 We are prepared to evaluate x each time round the loop in order to get that
709 It's all a bit more subtle than it looks:
713 Consider one-shot lambdas
714 let x = expensive in \y z -> E
715 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
716 Hence the ArityType returned by arityType
718 2. The state-transformer hack
720 The one-shot lambda special cause is particularly important/useful for
721 IO state transformers, where we often get
722 let x = E in \ s -> ...
724 and the \s is a real-world state token abstraction. Such abstractions
725 are almost invariably 1-shot, so we want to pull the \s out, past the
726 let x=E, even if E is expensive. So we treat state-token lambdas as
727 one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
729 3. Dealing with bottom
732 f = \x -> error "foo"
733 Here, arity 1 is fine. But if it is
737 then we want to get arity 2. Tecnically, this isn't quite right, because
739 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
740 do so; it improves some programs significantly, and increasing convergence
741 isn't a bad thing. Hence the ABot/ATop in ArityType.
743 Actually, the situation is worse. Consider
747 Can we eta-expand here? At first the answer looks like "yes of course", but
750 This should diverge! But if we eta-expand, it won't. Again, we ignore this
751 "problem", because being scrupulous would lose an important transformation for
756 exprEtaExpandArity e = arityDepth (arityType e)
758 -- A limited sort of function type
759 data ArityType = AFun Bool ArityType -- True <=> one-shot
760 | ATop -- Know nothing
763 arityDepth :: ArityType -> Arity
764 arityDepth (AFun _ ty) = 1 + arityDepth ty
767 andArityType ABot at2 = at2
768 andArityType ATop at2 = ATop
769 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
770 andArityType at1 at2 = andArityType at2 at1
772 arityType :: CoreExpr -> ArityType
773 -- (go1 e) = [b1,..,bn]
774 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
775 -- where bi is True <=> the lambda is one-shot
777 arityType (Note n e) = arityType e
778 -- Not needed any more: etaExpand is cleverer
779 -- | ok_note n = arityType e
780 -- | otherwise = ATop
783 = mk (idArity v) (arg_tys (idType v))
785 mk :: Arity -> [Type] -> ArityType
786 -- The argument types are only to steer the "state hack"
787 -- Consider case x of
789 -- False -> \(s:RealWorld) -> e
790 -- where foo has arity 1. Then we want the state hack to
791 -- apply to foo too, so we can eta expand the case.
792 mk 0 tys | isBottomingId v = ABot
794 mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
795 mk n [] = AFun False (mk (n-1) [])
797 arg_tys :: Type -> [Type] -- Ignore for-alls
799 | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
800 | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
803 -- Lambdas; increase arity
804 arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
805 | otherwise = arityType e
807 -- Applications; decrease arity
808 arityType (App f (Type _)) = arityType f
809 arityType (App f a) = case arityType f of
810 AFun one_shot xs | exprIsCheap a -> xs
813 -- Case/Let; keep arity if either the expression is cheap
814 -- or it's a 1-shot lambda
815 -- The former is not really right for Haskell
816 -- f x = case x of { (a,b) -> \y. e }
818 -- f x y = case x of { (a,b) -> e }
819 -- The difference is observable using 'seq'
821 arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
822 xs@(AFun one_shot _) | one_shot -> xs
823 xs | exprIsCheap scrut -> xs
826 arityType (Let b e) = case arityType e of
827 xs@(AFun one_shot _) | one_shot -> xs
828 xs | all exprIsCheap (rhssOfBind b) -> xs
831 arityType other = ATop
833 {- NOT NEEDED ANY MORE: etaExpand is cleverer
834 ok_note InlineMe = False
836 -- Notice that we do not look through __inline_me__
837 -- This may seem surprising, but consider
838 -- f = _inline_me (\x -> e)
839 -- We DO NOT want to eta expand this to
840 -- f = \x -> (_inline_me (\x -> e)) x
841 -- because the _inline_me gets dropped now it is applied,
850 etaExpand :: Arity -- Result should have this number of value args
852 -> CoreExpr -> Type -- Expression and its type
854 -- (etaExpand n us e ty) returns an expression with
855 -- the same meaning as 'e', but with arity 'n'.
857 -- Given e' = etaExpand n us e ty
859 -- ty = exprType e = exprType e'
861 -- Note that SCCs are not treated specially. If we have
862 -- etaExpand 2 (\x -> scc "foo" e)
863 -- = (\xy -> (scc "foo" e) y)
864 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
866 etaExpand n us expr ty
867 | manifestArity expr >= n = expr -- The no-op case
868 | otherwise = eta_expand n us expr ty
871 -- manifestArity sees how many leading value lambdas there are
872 manifestArity :: CoreExpr -> Arity
873 manifestArity (Lam v e) | isId v = 1 + manifestArity e
874 | otherwise = manifestArity e
875 manifestArity (Note _ e) = manifestArity e
878 -- etaExpand deals with for-alls. For example:
880 -- where E :: forall a. a -> a
882 -- (/\b. \y::a -> E b y)
884 -- It deals with coerces too, though they are now rare
885 -- so perhaps the extra code isn't worth it
887 eta_expand n us expr ty
889 -- The ILX code generator requires eta expansion for type arguments
890 -- too, but alas the 'n' doesn't tell us how many of them there
891 -- may be. So we eagerly eta expand any big lambdas, and just
892 -- cross our fingers about possible loss of sharing in the ILX case.
893 -- The Right Thing is probably to make 'arity' include
894 -- type variables throughout the compiler. (ToDo.)
896 -- Saturated, so nothing to do
899 -- Short cut for the case where there already
900 -- is a lambda; no point in gratuitously adding more
901 eta_expand n us (Lam v body) ty
903 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
906 = Lam v (eta_expand (n-1) us body (funResultTy ty))
908 -- We used to have a special case that stepped inside Coerces here,
909 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
910 -- = Note note (eta_expand n us e ty)
911 -- BUT this led to an infinite loop
912 -- Example: newtype T = MkT (Int -> Int)
913 -- eta_expand 1 (coerce (Int->Int) e)
914 -- --> coerce (Int->Int) (eta_expand 1 T e)
916 -- --> coerce (Int->Int) (coerce T
917 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
918 -- by the splitNewType_maybe case below
921 eta_expand n us expr ty
922 = case splitForAllTy_maybe ty of {
923 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
927 case splitFunTy_maybe ty of {
928 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
930 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
936 -- newtype T = MkT ([T] -> Int)
937 -- Consider eta-expanding this
940 -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
941 -- Only try this for recursive newtypes; the non-recursive kind
942 -- are transparent anyway
944 case splitRecNewType_maybe ty of {
945 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
946 Nothing -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
950 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
951 It tells how many things the expression can be applied to before doing
952 any work. It doesn't look inside cases, lets, etc. The idea is that
953 exprEtaExpandArity will do the hard work, leaving something that's easy
954 for exprArity to grapple with. In particular, Simplify uses exprArity to
955 compute the ArityInfo for the Id.
957 Originally I thought that it was enough just to look for top-level lambdas, but
958 it isn't. I've seen this
960 foo = PrelBase.timesInt
962 We want foo to get arity 2 even though the eta-expander will leave it
963 unchanged, in the expectation that it'll be inlined. But occasionally it
964 isn't, because foo is blacklisted (used in a rule).
966 Similarly, see the ok_note check in exprEtaExpandArity. So
967 f = __inline_me (\x -> e)
968 won't be eta-expanded.
970 And in any case it seems more robust to have exprArity be a bit more intelligent.
971 But note that (\x y z -> f x y z)
972 should have arity 3, regardless of f's arity.
975 exprArity :: CoreExpr -> Arity
978 go (Var v) = idArity v
979 go (Lam x e) | isId x = go e + 1
982 go (App e (Type t)) = go e
983 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
984 -- NB: exprIsCheap a!
985 -- f (fac x) does not have arity 2,
986 -- even if f has arity 3!
987 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
988 -- unknown, hence arity 0
992 %************************************************************************
994 \subsection{Equality}
996 %************************************************************************
998 @cheapEqExpr@ is a cheap equality test which bales out fast!
999 True => definitely equal
1000 False => may or may not be equal
1003 cheapEqExpr :: Expr b -> Expr b -> Bool
1005 cheapEqExpr (Var v1) (Var v2) = v1==v2
1006 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1007 cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
1009 cheapEqExpr (App f1 a1) (App f2 a2)
1010 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1012 cheapEqExpr _ _ = False
1014 exprIsBig :: Expr b -> Bool
1015 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1016 exprIsBig (Lit _) = False
1017 exprIsBig (Var v) = False
1018 exprIsBig (Type t) = False
1019 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1020 exprIsBig other = True
1025 eqExpr :: CoreExpr -> CoreExpr -> Bool
1026 -- Works ok at more general type, but only needed at CoreExpr
1027 -- Used in rule matching, so when we find a type we use
1028 -- eqTcType, which doesn't look through newtypes
1029 -- [And it doesn't risk falling into a black hole either.]
1031 = eq emptyVarEnv e1 e2
1033 -- The "env" maps variables in e1 to variables in ty2
1034 -- So when comparing lambdas etc,
1035 -- we in effect substitute v2 for v1 in e1 before continuing
1036 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
1037 Just v1' -> v1' == v2
1040 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
1041 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
1042 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
1043 eq env (Let (NonRec v1 r1) e1)
1044 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
1045 eq env (Let (Rec ps1) e1)
1046 (Let (Rec ps2) e2) = equalLength ps1 ps2 &&
1047 and (zipWith eq_rhs ps1 ps2) &&
1050 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
1051 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
1052 eq env (Case e1 v1 t1 a1)
1053 (Case e2 v2 t2 a2) = eq env e1 e2 &&
1055 equalLength a1 a2 &&
1056 and (zipWith (eq_alt env') a1 a2)
1058 env' = extendVarEnv env v1 v2
1060 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
1061 eq env (Type t1) (Type t2) = t1 `eqType` t2
1062 eq env e1 e2 = False
1064 eq_list env [] [] = True
1065 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
1066 eq_list env es1 es2 = False
1068 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
1069 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
1071 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1072 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
1073 eq_note env InlineCall InlineCall = True
1074 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1075 eq_note env other1 other2 = False
1079 %************************************************************************
1081 \subsection{The size of an expression}
1083 %************************************************************************
1086 coreBindsSize :: [CoreBind] -> Int
1087 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1089 exprSize :: CoreExpr -> Int
1090 -- A measure of the size of the expressions
1091 -- It also forces the expression pretty drastically as a side effect
1092 exprSize (Var v) = v `seq` 1
1093 exprSize (Lit lit) = lit `seq` 1
1094 exprSize (App f a) = exprSize f + exprSize a
1095 exprSize (Lam b e) = varSize b + exprSize e
1096 exprSize (Let b e) = bindSize b + exprSize e
1098 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1099 exprSize (Note n e) = noteSize n + exprSize e
1100 exprSize (Type t) = seqType t `seq` 1
1102 noteSize (SCC cc) = cc `seq` 1
1103 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1104 noteSize InlineCall = 1
1105 noteSize InlineMe = 1
1106 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1108 varSize :: Var -> Int
1109 varSize b | isTyVar b = 1
1110 | otherwise = seqType (idType b) `seq`
1111 megaSeqIdInfo (idInfo b) `seq`
1114 varsSize = foldr ((+) . varSize) 0
1116 bindSize (NonRec b e) = varSize b + exprSize e
1117 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1119 pairSize (b,e) = varSize b + exprSize e
1121 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1125 %************************************************************************
1127 \subsection{Hashing}
1129 %************************************************************************
1132 hashExpr :: CoreExpr -> Int
1133 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1136 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1138 hash_expr (Note _ e) = hash_expr e
1139 hash_expr (Let (NonRec b r) e) = hashId b
1140 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1142 hash_expr (Case _ b _ _) = hashId b
1143 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1144 hash_expr (Var v) = hashId v
1145 hash_expr (Lit lit) = hashLiteral lit
1146 hash_expr (Lam b _) = hashId b
1147 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1149 fast_hash_expr (Var v) = hashId v
1150 fast_hash_expr (Lit lit) = hashLiteral lit
1151 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1152 fast_hash_expr (App f a) = fast_hash_expr a
1153 fast_hash_expr (Lam b _) = hashId b
1154 fast_hash_expr other = 1
1157 hashId id = hashName (idName id)
1160 %************************************************************************
1162 \subsection{Determining non-updatable right-hand-sides}
1164 %************************************************************************
1166 Top-level constructor applications can usually be allocated
1167 statically, but they can't if the constructor, or any of the
1168 arguments, come from another DLL (because we can't refer to static
1169 labels in other DLLs).
1171 If this happens we simply make the RHS into an updatable thunk,
1172 and 'exectute' it rather than allocating it statically.
1175 rhsIsStatic :: DynFlags -> CoreExpr -> Bool
1176 -- This function is called only on *top-level* right-hand sides
1177 -- Returns True if the RHS can be allocated statically, with
1178 -- no thunks involved at all.
1180 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1181 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1182 -- update flag on it.
1184 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1185 -- (a) a value lambda
1186 -- (b) a saturated constructor application with static args
1188 -- BUT watch out for
1189 -- (i) Any cross-DLL references kill static-ness completely
1190 -- because they must be 'executed' not statically allocated
1192 -- (ii) We treat partial applications as redexes, because in fact we
1193 -- make a thunk for them that runs and builds a PAP
1194 -- at run-time. The only appliations that are treated as
1195 -- static are *saturated* applications of constructors.
1197 -- We used to try to be clever with nested structures like this:
1198 -- ys = (:) w ((:) w [])
1199 -- on the grounds that CorePrep will flatten ANF-ise it later.
1200 -- But supporting this special case made the function much more
1201 -- complicated, because the special case only applies if there are no
1202 -- enclosing type lambdas:
1203 -- ys = /\ a -> Foo (Baz ([] a))
1204 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1206 -- But in fact, even without -O, nested structures at top level are
1207 -- flattened by the simplifier, so we don't need to be super-clever here.
1211 -- f = \x::Int. x+7 TRUE
1212 -- p = (True,False) TRUE
1214 -- d = (fst p, False) FALSE because there's a redex inside
1215 -- (this particular one doesn't happen but...)
1217 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1218 -- n = /\a. Nil a TRUE
1220 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1223 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1224 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1226 -- b) (C x xs), where C is a contructors is updatable if the application is
1229 -- c) don't look through unfolding of f in (f x).
1231 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1232 -- them as making the RHS re-entrant (non-updatable).
1234 rhsIsStatic dflags rhs = is_static False rhs
1236 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1239 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1241 is_static in_arg (Note (SCC _) e) = False
1242 is_static in_arg (Note _ e) = is_static in_arg e
1244 is_static in_arg (Lit lit)
1246 MachLabel _ _ -> False
1248 -- A MachLabel (foreign import "&foo") in an argument
1249 -- prevents a constructor application from being static. The
1250 -- reason is that it might give rise to unresolvable symbols
1251 -- in the object file: under Linux, references to "weak"
1252 -- symbols from the data segment give rise to "unresolvable
1253 -- relocation" errors at link time This might be due to a bug
1254 -- in the linker, but we'll work around it here anyway.
1257 is_static in_arg other_expr = go other_expr 0
1259 go (Var f) n_val_args
1260 | not (isDllName dflags (idName f))
1261 = saturated_data_con f n_val_args
1262 || (in_arg && n_val_args == 0)
1263 -- A naked un-applied variable is *not* deemed a static RHS
1265 -- Reason: better to update so that the indirection gets shorted
1266 -- out, and the true value will be seen
1267 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1268 -- are always updatable. If you do so, make sure that non-updatable
1269 -- ones have enough space for their static link field!
1271 go (App f a) n_val_args
1272 | isTypeArg a = go f n_val_args
1273 | not in_arg && is_static True a = go f (n_val_args + 1)
1274 -- The (not in_arg) checks that we aren't in a constructor argument;
1275 -- if we are, we don't allow (value) applications of any sort
1277 -- NB. In case you wonder, args are sometimes not atomic. eg.
1278 -- x = D# (1.0## /## 2.0##)
1279 -- can't float because /## can fail.
1281 go (Note (SCC _) f) n_val_args = False
1282 go (Note _ f) n_val_args = go f n_val_args
1284 go other n_val_args = False
1286 saturated_data_con f n_val_args
1287 = case isDataConWorkId_maybe f of
1288 Just dc -> n_val_args == dataConRepArity dc