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
18 exprIsDupable, exprIsTrivial, exprIsCheap,
19 exprIsValue,exprOkForSpeculation, exprIsBig,
23 -- Arity and eta expansion
24 manifestArity, exprArity,
25 exprEtaExpandArity, etaExpand,
34 cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
37 #include "HsVersions.h"
40 import GLAEXTS -- For `xori`
43 import PprCore ( pprCoreExpr )
44 import Var ( Var, isId, isTyVar )
46 import Name ( hashName, isDllName )
47 import Literal ( hashLiteral, literalType, litIsDupable,
48 litIsTrivial, isZeroLit, Literal( MachLabel ) )
49 import DataCon ( DataCon, dataConRepArity, dataConArgTys,
50 isExistentialDataCon, dataConTyCon )
51 import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
52 import Id ( Id, idType, globalIdDetails, idNewStrictness,
53 mkWildId, idArity, idName, idUnfolding, idInfo,
54 isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
55 isDataConWorkId, isBottomingId
57 import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
58 import NewDemand ( appIsBottom )
59 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
61 applyTys, isUnLiftedType, seqType, mkTyVarTy,
62 splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
63 splitTyConApp_maybe, eqType, funResultTy, applyTy,
66 import TyCon ( tyConArity )
67 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
68 import CostCentre ( CostCentre )
69 import BasicTypes ( Arity )
70 import Unique ( Unique )
72 import TysPrim ( alphaTy ) -- Debugging only
73 import Util ( equalLength, lengthAtLeast )
77 %************************************************************************
79 \subsection{Find the type of a Core atom/expression}
81 %************************************************************************
84 exprType :: CoreExpr -> Type
86 exprType (Var var) = idType var
87 exprType (Lit lit) = literalType lit
88 exprType (Let _ body) = exprType body
89 exprType (Case _ _ alts) = coreAltsType alts
90 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
91 exprType (Note other_note e) = exprType e
92 exprType (Lam binder expr) = mkPiType binder (exprType expr)
94 = case collectArgs e of
95 (fun, args) -> applyTypeToArgs e (exprType fun) args
97 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
99 coreAltsType :: [CoreAlt] -> Type
100 coreAltsType ((_,_,rhs) : _) = exprType rhs
103 @mkPiType@ makes a (->) type or a forall type, depending on whether
104 it is given a type variable or a term variable. We cleverly use the
105 lbvarinfo field to figure out the right annotation for the arrove in
106 case of a term variable.
109 mkPiType :: Var -> Type -> Type -- The more polymorphic version
110 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
112 mkPiTypes vs ty = foldr mkPiType ty vs
115 | isId v = mkFunTy (idType v) ty
116 | otherwise = mkForAllTy v ty
120 applyTypeToArg :: Type -> CoreExpr -> Type
121 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
122 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
124 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
125 -- A more efficient version of applyTypeToArg
126 -- when we have several args
127 -- The first argument is just for debugging
128 applyTypeToArgs e op_ty [] = op_ty
130 applyTypeToArgs e op_ty (Type ty : args)
131 = -- Accumulate type arguments so we can instantiate all at once
134 go rev_tys (Type ty : args) = go (ty:rev_tys) args
135 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
137 op_ty' = applyTys op_ty (reverse rev_tys)
139 applyTypeToArgs e op_ty (other_arg : args)
140 = case (splitFunTy_maybe op_ty) of
141 Just (_, res_ty) -> applyTypeToArgs e res_ty args
142 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
147 %************************************************************************
149 \subsection{Attaching notes}
151 %************************************************************************
153 mkNote removes redundant coercions, and SCCs where possible
157 mkNote :: Note -> CoreExpr -> CoreExpr
158 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
159 mkNote (SCC cc) expr = mkSCC cc expr
160 mkNote InlineMe expr = mkInlineMe expr
161 mkNote note expr = Note note expr
164 -- Slide InlineCall in around the function
165 -- No longer necessary I think (SLPJ Apr 99)
166 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
167 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
168 -- mkNote InlineCall expr = expr
171 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
172 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
173 not be *applied* to anything.
175 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
178 f = inline_me (coerce t fw)
179 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
180 We want the split, so that the coerces can cancel at the call site.
182 However, we can get left with tiresome type applications. Notably, consider
183 f = /\ a -> let t = e in (t, w)
184 Then lifting the let out of the big lambda gives
186 f = /\ a -> let t = inline_me (t' a) in (t, w)
187 The inline_me is to stop the simplifier inlining t' right back
188 into t's RHS. In the next phase we'll substitute for t (since
189 its rhs is trivial) and *then* we could get rid of the inline_me.
190 But it hardly seems worth it, so I don't bother.
193 mkInlineMe (Var v) = Var v
194 mkInlineMe e = Note InlineMe e
200 mkCoerce :: Type -> CoreExpr -> CoreExpr
201 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
203 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
204 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
205 = ASSERT( from_ty `eqType` to_ty2 )
206 mkCoerce2 to_ty from_ty2 expr
208 mkCoerce2 to_ty from_ty expr
209 | to_ty `eqType` from_ty = expr
210 | otherwise = ASSERT( from_ty `eqType` exprType expr )
211 Note (Coerce to_ty from_ty) expr
215 mkSCC :: CostCentre -> Expr b -> Expr b
216 -- Note: Nested SCC's *are* preserved for the benefit of
217 -- cost centre stack profiling
218 mkSCC cc (Lit lit) = Lit lit
219 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
220 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
221 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
222 mkSCC cc expr = Note (SCC cc) expr
226 %************************************************************************
228 \subsection{Other expression construction}
230 %************************************************************************
233 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
234 -- (bindNonRec x r b) produces either
237 -- case r of x { _DEFAULT_ -> b }
239 -- depending on whether x is unlifted or not
240 -- It's used by the desugarer to avoid building bindings
241 -- that give Core Lint a heart attack. Actually the simplifier
242 -- deals with them perfectly well.
243 bindNonRec bndr rhs body
244 | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
245 | otherwise = Let (NonRec bndr rhs) body
247 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
248 -- Make a case expression instead of a let
249 -- These can arise either from the desugarer,
250 -- or from beta reductions: (\x.e) (x +# y)
254 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
255 -- This guy constructs the value that the scrutinee must have
256 -- when you are in one particular branch of a case
257 mkAltExpr (DataAlt con) args inst_tys
258 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
259 mkAltExpr (LitAlt lit) [] []
262 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
263 mkIfThenElse guard then_expr else_expr
264 = Case guard (mkWildId boolTy)
265 [ (DataAlt trueDataCon, [], then_expr),
266 (DataAlt falseDataCon, [], else_expr) ]
270 %************************************************************************
272 \subsection{Taking expressions apart}
274 %************************************************************************
276 The default alternative must be first, if it exists at all.
277 This makes it easy to find, though it makes matching marginally harder.
280 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
281 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
282 findDefault alts = (alts, Nothing)
284 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
287 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
288 other -> go alts panic_deflt
291 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
294 go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
295 | otherwise = ASSERT( not (con1 == DEFAULT) )
300 %************************************************************************
302 \subsection{Figuring out things about expressions}
304 %************************************************************************
306 @exprIsTrivial@ is true of expressions we are unconditionally happy to
307 duplicate; simple variables and constants, and type
308 applications. Note that primop Ids aren't considered
311 @exprIsBottom@ is true of expressions that are guaranteed to diverge
314 There used to be a gruesome test for (hasNoBinding v) in the
316 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
317 The idea here is that a constructor worker, like $wJust, is
318 really short for (\x -> $wJust x), becuase $wJust has no binding.
319 So it should be treated like a lambda. Ditto unsaturated primops.
320 But now constructor workers are not "have-no-binding" Ids. And
321 completely un-applied primops and foreign-call Ids are sufficiently
322 rare that I plan to allow them to be duplicated and put up with
325 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
326 a) it really generates code, (and a heap object when it's
327 a function arg) to capture the cost centre
328 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
331 exprIsTrivial (Var v) = True -- See notes above
332 exprIsTrivial (Type _) = True
333 exprIsTrivial (Lit lit) = litIsTrivial lit
334 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
335 exprIsTrivial (Note (SCC _) e) = False -- See notes above
336 exprIsTrivial (Note _ e) = exprIsTrivial e
337 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
338 exprIsTrivial other = False
342 @exprIsDupable@ is true of expressions that can be duplicated at a modest
343 cost in code size. This will only happen in different case
344 branches, so there's no issue about duplicating work.
346 That is, exprIsDupable returns True of (f x) even if
347 f is very very expensive to call.
349 Its only purpose is to avoid fruitless let-binding
350 and then inlining of case join points
354 exprIsDupable (Type _) = True
355 exprIsDupable (Var v) = True
356 exprIsDupable (Lit lit) = litIsDupable lit
357 exprIsDupable (Note InlineMe e) = True
358 exprIsDupable (Note _ e) = exprIsDupable e
362 go (Var v) n_args = True
363 go (App f a) n_args = n_args < dupAppSize
366 go other n_args = False
369 dupAppSize = 4 -- Size of application we are prepared to duplicate
372 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
373 it is obviously in weak head normal form, or is cheap to get to WHNF.
374 [Note that that's not the same as exprIsDupable; an expression might be
375 big, and hence not dupable, but still cheap.]
377 By ``cheap'' we mean a computation we're willing to:
378 push inside a lambda, or
379 inline at more than one place
380 That might mean it gets evaluated more than once, instead of being
381 shared. The main examples of things which aren't WHNF but are
386 (where e, and all the ei are cheap)
389 (where e and b are cheap)
392 (where op is a cheap primitive operator)
395 (because we are happy to substitute it inside a lambda)
397 Notice that a variable is considered 'cheap': we can push it inside a lambda,
398 because sharing will make sure it is only evaluated once.
401 exprIsCheap :: CoreExpr -> Bool
402 exprIsCheap (Lit lit) = True
403 exprIsCheap (Type _) = True
404 exprIsCheap (Var _) = True
405 exprIsCheap (Note InlineMe e) = True
406 exprIsCheap (Note _ e) = exprIsCheap e
407 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
408 exprIsCheap (Case e _ alts) = exprIsCheap e &&
409 and [exprIsCheap rhs | (_,_,rhs) <- alts]
410 -- Experimentally, treat (case x of ...) as cheap
411 -- (and case __coerce x etc.)
412 -- This improves arities of overloaded functions where
413 -- there is only dictionary selection (no construction) involved
414 exprIsCheap (Let (NonRec x _) e)
415 | isUnLiftedType (idType x) = exprIsCheap e
417 -- strict lets always have cheap right hand sides, and
420 exprIsCheap other_expr
421 = go other_expr 0 True
423 go (Var f) n_args args_cheap
424 = (idAppIsCheap f n_args && args_cheap)
425 -- A constructor, cheap primop, or partial application
427 || idAppIsBottom f n_args
428 -- Application of a function which
429 -- always gives bottom; we treat this as cheap
430 -- because it certainly doesn't need to be shared!
432 go (App f a) n_args args_cheap
433 | not (isRuntimeArg a) = go f n_args args_cheap
434 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
436 go other n_args args_cheap = False
438 idAppIsCheap :: Id -> Int -> Bool
439 idAppIsCheap id n_val_args
440 | n_val_args == 0 = True -- Just a type application of
441 -- a variable (f t1 t2 t3)
443 | otherwise = case globalIdDetails id of
444 DataConWorkId _ -> True
445 RecordSelId _ -> True -- I'm experimenting with making record selection
446 ClassOpId _ -> True -- look cheap, so we will substitute it inside a
447 -- lambda. Particularly for dictionary field selection
449 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
450 -- that return a type variable, since the result
451 -- might be applied to something, but I'm not going
452 -- to bother to check the number of args
453 other -> n_val_args < idArity id
456 exprOkForSpeculation returns True of an expression that it is
458 * safe to evaluate even if normal order eval might not
459 evaluate the expression at all, or
461 * safe *not* to evaluate even if normal order would do so
465 the expression guarantees to terminate,
467 without raising an exception,
468 without causing a side effect (e.g. writing a mutable variable)
471 let x = case y# +# 1# of { r# -> I# r# }
474 case y# +# 1# of { r# ->
479 We can only do this if the (y+1) is ok for speculation: it has no
480 side effects, and can't diverge or raise an exception.
483 exprOkForSpeculation :: CoreExpr -> Bool
484 exprOkForSpeculation (Lit _) = True
485 exprOkForSpeculation (Type _) = True
486 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
487 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
488 exprOkForSpeculation other_expr
489 = case collectArgs other_expr of
490 (Var f, args) -> spec_ok (globalIdDetails f) args
494 spec_ok (DataConWorkId _) args
495 = True -- The strictness of the constructor has already
496 -- been expressed by its "wrapper", so we don't need
497 -- to take the arguments into account
499 spec_ok (PrimOpId op) args
500 | isDivOp op, -- Special case for dividing operations that fail
501 [arg1, Lit lit] <- args -- only if the divisor is zero
502 = not (isZeroLit lit) && exprOkForSpeculation arg1
503 -- Often there is a literal divisor, and this
504 -- can get rid of a thunk in an inner looop
507 = primOpOkForSpeculation op &&
508 all exprOkForSpeculation args
509 -- A bit conservative: we don't really need
510 -- to care about lazy arguments, but this is easy
512 spec_ok other args = False
514 isDivOp :: PrimOp -> Bool
515 -- True of dyadic operators that can fail
516 -- only if the second arg is zero
517 -- This function probably belongs in PrimOp, or even in
518 -- an automagically generated file.. but it's such a
519 -- special case I thought I'd leave it here for now.
520 isDivOp IntQuotOp = True
521 isDivOp IntRemOp = True
522 isDivOp WordQuotOp = True
523 isDivOp WordRemOp = True
524 isDivOp IntegerQuotRemOp = True
525 isDivOp IntegerDivModOp = True
526 isDivOp FloatDivOp = True
527 isDivOp DoubleDivOp = True
528 isDivOp other = False
533 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
534 exprIsBottom e = go 0 e
536 -- n is the number of args
537 go n (Note _ e) = go n e
538 go n (Let _ e) = go n e
539 go n (Case e _ _) = go 0 e -- Just check the scrut
540 go n (App e _) = go (n+1) e
541 go n (Var v) = idAppIsBottom v n
543 go n (Lam _ _) = False
545 idAppIsBottom :: Id -> Int -> Bool
546 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
549 @exprIsValue@ returns true for expressions that are certainly *already*
550 evaluated to *head* normal form. This is used to decide whether it's ok
553 case x of _ -> e ===> e
555 and to decide whether it's safe to discard a `seq`
557 So, it does *not* treat variables as evaluated, unless they say they are.
559 But it *does* treat partial applications and constructor applications
560 as values, even if their arguments are non-trivial, provided the argument
562 e.g. (:) (f x) (map f xs) is a value
563 map (...redex...) is a value
564 Because `seq` on such things completes immediately
566 For unlifted argument types, we have to be careful:
568 Suppose (f x) diverges; then C (f x) is not a value. True, but
569 this form is illegal (see the invariants in CoreSyn). Args of unboxed
570 type must be ok-for-speculation (or trivial).
573 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
574 exprIsValue (Var v) -- NB: There are no value args at this point
575 = isDataConWorkId v -- Catches nullary constructors,
576 -- so that [] and () are values, for example
577 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
578 || isEvaldUnfolding (idUnfolding v)
579 -- Check the thing's unfolding; it might be bound to a value
580 -- A worry: what if an Id's unfolding is just itself:
581 -- then we could get an infinite loop...
583 exprIsValue (Lit l) = True
584 exprIsValue (Type ty) = True -- Types are honorary Values;
585 -- we don't mind copying them
586 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
587 exprIsValue (Note _ e) = exprIsValue e
588 exprIsValue (App e (Type _)) = exprIsValue e
589 exprIsValue (App e a) = app_is_value e [a]
590 exprIsValue other = False
592 -- There is at least one value argument
593 app_is_value (Var fun) args
594 | isDataConWorkId fun -- Constructor apps are values
595 || idArity fun > valArgCount args -- Under-applied function
596 = check_args (idType fun) args
597 app_is_value (App f a) as = app_is_value f (a:as)
598 app_is_value other as = False
600 -- 'check_args' checks that unlifted-type args
601 -- are in fact guaranteed non-divergent
602 check_args fun_ty [] = True
603 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
604 Just (_, ty) -> check_args ty args
605 check_args fun_ty (arg : args)
606 | isUnLiftedType arg_ty = exprOkForSpeculation arg
607 | otherwise = check_args res_ty args
609 (arg_ty, res_ty) = splitFunTy fun_ty
613 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
614 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
615 = -- Maybe this is over the top, but here we try to turn
616 -- coerce (S,T) ( x, y )
618 -- ( coerce S x, coerce T y )
619 -- This happens in anger in PrelArrExts which has a coerce
620 -- case coerce memcpy a b of
622 -- where the memcpy is in the IO monad, but the call is in
624 case exprIsConApp_maybe expr of {
628 case splitTyConApp_maybe to_ty of {
630 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
631 | isExistentialDataCon dc -> Nothing
633 -- Type constructor must match
634 -- We knock out existentials to keep matters simple(r)
636 arity = tyConArity tc
637 val_args = drop arity args
638 to_arg_tys = dataConArgTys dc tc_arg_tys
639 mk_coerce ty arg = mkCoerce ty arg
640 new_val_args = zipWith mk_coerce to_arg_tys val_args
642 ASSERT( all isTypeArg (take arity args) )
643 ASSERT( equalLength val_args to_arg_tys )
644 Just (dc, map Type tc_arg_tys ++ new_val_args)
647 exprIsConApp_maybe (Note _ expr)
648 = exprIsConApp_maybe expr
649 -- We ignore InlineMe notes in case we have
650 -- x = __inline_me__ (a,b)
651 -- All part of making sure that INLINE pragmas never hurt
652 -- Marcin tripped on this one when making dictionaries more inlinable
654 -- In fact, we ignore all notes. For example,
655 -- case _scc_ "foo" (C a b) of
657 -- should be optimised away, but it will be only if we look
658 -- through the SCC note.
660 exprIsConApp_maybe expr = analyse (collectArgs expr)
662 analyse (Var fun, args)
663 | Just con <- isDataConWorkId_maybe fun,
664 args `lengthAtLeast` dataConRepArity con
665 -- Might be > because the arity excludes type args
668 -- Look through unfoldings, but only cheap ones, because
669 -- we are effectively duplicating the unfolding
670 analyse (Var fun, [])
671 | let unf = idUnfolding fun,
673 = exprIsConApp_maybe (unfoldingTemplate unf)
675 analyse other = Nothing
680 %************************************************************************
682 \subsection{Eta reduction and expansion}
684 %************************************************************************
687 exprEtaExpandArity :: CoreExpr -> Arity
688 {- The Arity returned is the number of value args the
689 thing can be applied to without doing much work
691 exprEtaExpandArity is used when eta expanding
694 It returns 1 (or more) to:
695 case x of p -> \s -> ...
696 because for I/O ish things we really want to get that \s to the top.
697 We are prepared to evaluate x each time round the loop in order to get that
699 It's all a bit more subtle than it looks:
703 Consider one-shot lambdas
704 let x = expensive in \y z -> E
705 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
706 Hence the ArityType returned by arityType
708 2. The state-transformer hack
710 The one-shot lambda special cause is particularly important/useful for
711 IO state transformers, where we often get
712 let x = E in \ s -> ...
714 and the \s is a real-world state token abstraction. Such abstractions
715 are almost invariably 1-shot, so we want to pull the \s out, past the
716 let x=E, even if E is expensive. So we treat state-token lambdas as
717 one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
719 3. Dealing with bottom
722 f = \x -> error "foo"
723 Here, arity 1 is fine. But if it is
727 then we want to get arity 2. Tecnically, this isn't quite right, because
729 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
730 do so; it improves some programs significantly, and increasing convergence
731 isn't a bad thing. Hence the ABot/ATop in ArityType.
733 Actually, the situation is worse. Consider
737 Can we eta-expand here? At first the answer looks like "yes of course", but
740 This should diverge! But if we eta-expand, it won't. Again, we ignore this
741 "problem", because being scrupulous would lose an important transformation for
746 exprEtaExpandArity e = arityDepth (arityType e)
748 -- A limited sort of function type
749 data ArityType = AFun Bool ArityType -- True <=> one-shot
750 | ATop -- Know nothing
753 arityDepth :: ArityType -> Arity
754 arityDepth (AFun _ ty) = 1 + arityDepth ty
757 andArityType ABot at2 = at2
758 andArityType ATop at2 = ATop
759 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
760 andArityType at1 at2 = andArityType at2 at1
762 arityType :: CoreExpr -> ArityType
763 -- (go1 e) = [b1,..,bn]
764 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
765 -- where bi is True <=> the lambda is one-shot
767 arityType (Note n e) = arityType e
768 -- Not needed any more: etaExpand is cleverer
769 -- | ok_note n = arityType e
770 -- | otherwise = ATop
773 = mk (idArity v) (arg_tys (idType v))
775 mk :: Arity -> [Type] -> ArityType
776 -- The argument types are only to steer the "state hack"
777 -- Consider case x of
779 -- False -> \(s:RealWorld) -> e
780 -- where foo has arity 1. Then we want the state hack to
781 -- apply to foo too, so we can eta expand the case.
782 mk 0 tys | isBottomingId v = ABot
784 mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
785 mk n [] = AFun False (mk (n-1) [])
787 arg_tys :: Type -> [Type] -- Ignore for-alls
789 | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
790 | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
793 -- Lambdas; increase arity
794 arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
795 | otherwise = arityType e
797 -- Applications; decrease arity
798 arityType (App f (Type _)) = arityType f
799 arityType (App f a) = case arityType f of
800 AFun one_shot xs | exprIsCheap a -> xs
803 -- Case/Let; keep arity if either the expression is cheap
804 -- or it's a 1-shot lambda
805 -- The former is not really right for Haskell
806 -- f x = case x of { (a,b) -> \y. e }
808 -- f x y = case x of { (a,b) -> e }
809 -- The difference is observable using 'seq'
810 arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
811 xs@(AFun one_shot _) | one_shot -> xs
812 xs | exprIsCheap scrut -> xs
815 arityType (Let b e) = case arityType e of
816 xs@(AFun one_shot _) | one_shot -> xs
817 xs | all exprIsCheap (rhssOfBind b) -> xs
820 arityType other = ATop
822 {- NOT NEEDED ANY MORE: etaExpand is cleverer
823 ok_note InlineMe = False
825 -- Notice that we do not look through __inline_me__
826 -- This may seem surprising, but consider
827 -- f = _inline_me (\x -> e)
828 -- We DO NOT want to eta expand this to
829 -- f = \x -> (_inline_me (\x -> e)) x
830 -- because the _inline_me gets dropped now it is applied,
839 etaExpand :: Arity -- Result should have this number of value args
841 -> CoreExpr -> Type -- Expression and its type
843 -- (etaExpand n us e ty) returns an expression with
844 -- the same meaning as 'e', but with arity 'n'.
846 -- Given e' = etaExpand n us e ty
848 -- ty = exprType e = exprType e'
850 -- Note that SCCs are not treated specially. If we have
851 -- etaExpand 2 (\x -> scc "foo" e)
852 -- = (\xy -> (scc "foo" e) y)
853 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
855 etaExpand n us expr ty
856 | manifestArity expr >= n = expr -- The no-op case
857 | otherwise = eta_expand n us expr ty
860 -- manifestArity sees how many leading value lambdas there are
861 manifestArity :: CoreExpr -> Arity
862 manifestArity (Lam v e) | isId v = 1 + manifestArity e
863 | otherwise = manifestArity e
864 manifestArity (Note _ e) = manifestArity e
867 -- etaExpand deals with for-alls. For example:
869 -- where E :: forall a. a -> a
871 -- (/\b. \y::a -> E b y)
873 -- It deals with coerces too, though they are now rare
874 -- so perhaps the extra code isn't worth it
876 eta_expand n us expr ty
878 -- The ILX code generator requires eta expansion for type arguments
879 -- too, but alas the 'n' doesn't tell us how many of them there
880 -- may be. So we eagerly eta expand any big lambdas, and just
881 -- cross our fingers about possible loss of sharing in the ILX case.
882 -- The Right Thing is probably to make 'arity' include
883 -- type variables throughout the compiler. (ToDo.)
885 -- Saturated, so nothing to do
888 -- Short cut for the case where there already
889 -- is a lambda; no point in gratuitously adding more
890 eta_expand n us (Lam v body) ty
892 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
895 = Lam v (eta_expand (n-1) us body (funResultTy ty))
897 -- We used to have a special case that stepped inside Coerces here,
898 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
899 -- = Note note (eta_expand n us e ty)
900 -- BUT this led to an infinite loop
901 -- Example: newtype T = MkT (Int -> Int)
902 -- eta_expand 1 (coerce (Int->Int) e)
903 -- --> coerce (Int->Int) (eta_expand 1 T e)
905 -- --> coerce (Int->Int) (coerce T
906 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
907 -- by the splitNewType_maybe case below
910 eta_expand n us expr ty
911 = case splitForAllTy_maybe ty of {
912 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
916 case splitFunTy_maybe ty of {
917 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
919 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
925 -- newtype T = MkT ([T] -> Int)
926 -- Consider eta-expanding this
929 -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
930 -- Only try this for recursive newtypes; the non-recursive kind
931 -- are transparent anyway
933 case splitRecNewType_maybe ty of {
934 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
935 Nothing -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
939 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
940 It tells how many things the expression can be applied to before doing
941 any work. It doesn't look inside cases, lets, etc. The idea is that
942 exprEtaExpandArity will do the hard work, leaving something that's easy
943 for exprArity to grapple with. In particular, Simplify uses exprArity to
944 compute the ArityInfo for the Id.
946 Originally I thought that it was enough just to look for top-level lambdas, but
947 it isn't. I've seen this
949 foo = PrelBase.timesInt
951 We want foo to get arity 2 even though the eta-expander will leave it
952 unchanged, in the expectation that it'll be inlined. But occasionally it
953 isn't, because foo is blacklisted (used in a rule).
955 Similarly, see the ok_note check in exprEtaExpandArity. So
956 f = __inline_me (\x -> e)
957 won't be eta-expanded.
959 And in any case it seems more robust to have exprArity be a bit more intelligent.
960 But note that (\x y z -> f x y z)
961 should have arity 3, regardless of f's arity.
964 exprArity :: CoreExpr -> Arity
967 go (Var v) = idArity v
968 go (Lam x e) | isId x = go e + 1
971 go (App e (Type t)) = go e
972 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
973 -- NB: exprIsCheap a!
974 -- f (fac x) does not have arity 2,
975 -- even if f has arity 3!
976 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
977 -- unknown, hence arity 0
981 %************************************************************************
983 \subsection{Equality}
985 %************************************************************************
987 @cheapEqExpr@ is a cheap equality test which bales out fast!
988 True => definitely equal
989 False => may or may not be equal
992 cheapEqExpr :: Expr b -> Expr b -> Bool
994 cheapEqExpr (Var v1) (Var v2) = v1==v2
995 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
996 cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
998 cheapEqExpr (App f1 a1) (App f2 a2)
999 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1001 cheapEqExpr _ _ = False
1003 exprIsBig :: Expr b -> Bool
1004 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1005 exprIsBig (Lit _) = False
1006 exprIsBig (Var v) = False
1007 exprIsBig (Type t) = False
1008 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1009 exprIsBig other = True
1014 eqExpr :: CoreExpr -> CoreExpr -> Bool
1015 -- Works ok at more general type, but only needed at CoreExpr
1016 -- Used in rule matching, so when we find a type we use
1017 -- eqTcType, which doesn't look through newtypes
1018 -- [And it doesn't risk falling into a black hole either.]
1020 = eq emptyVarEnv e1 e2
1022 -- The "env" maps variables in e1 to variables in ty2
1023 -- So when comparing lambdas etc,
1024 -- we in effect substitute v2 for v1 in e1 before continuing
1025 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
1026 Just v1' -> v1' == v2
1029 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
1030 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
1031 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
1032 eq env (Let (NonRec v1 r1) e1)
1033 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
1034 eq env (Let (Rec ps1) e1)
1035 (Let (Rec ps2) e2) = equalLength ps1 ps2 &&
1036 and (zipWith eq_rhs ps1 ps2) &&
1039 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
1040 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
1041 eq env (Case e1 v1 a1)
1042 (Case e2 v2 a2) = eq env e1 e2 &&
1043 equalLength a1 a2 &&
1044 and (zipWith (eq_alt env') a1 a2)
1046 env' = extendVarEnv env v1 v2
1048 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
1049 eq env (Type t1) (Type t2) = t1 `eqType` t2
1050 eq env e1 e2 = False
1052 eq_list env [] [] = True
1053 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
1054 eq_list env es1 es2 = False
1056 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
1057 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
1059 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1060 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
1061 eq_note env InlineCall InlineCall = True
1062 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1063 eq_note env other1 other2 = False
1067 %************************************************************************
1069 \subsection{The size of an expression}
1071 %************************************************************************
1074 coreBindsSize :: [CoreBind] -> Int
1075 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1077 exprSize :: CoreExpr -> Int
1078 -- A measure of the size of the expressions
1079 -- It also forces the expression pretty drastically as a side effect
1080 exprSize (Var v) = v `seq` 1
1081 exprSize (Lit lit) = lit `seq` 1
1082 exprSize (App f a) = exprSize f + exprSize a
1083 exprSize (Lam b e) = varSize b + exprSize e
1084 exprSize (Let b e) = bindSize b + exprSize e
1085 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
1086 exprSize (Note n e) = noteSize n + exprSize e
1087 exprSize (Type t) = seqType t `seq` 1
1089 noteSize (SCC cc) = cc `seq` 1
1090 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1091 noteSize InlineCall = 1
1092 noteSize InlineMe = 1
1093 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1095 varSize :: Var -> Int
1096 varSize b | isTyVar b = 1
1097 | otherwise = seqType (idType b) `seq`
1098 megaSeqIdInfo (idInfo b) `seq`
1101 varsSize = foldr ((+) . varSize) 0
1103 bindSize (NonRec b e) = varSize b + exprSize e
1104 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1106 pairSize (b,e) = varSize b + exprSize e
1108 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1112 %************************************************************************
1114 \subsection{Hashing}
1116 %************************************************************************
1119 hashExpr :: CoreExpr -> Int
1120 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1123 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1125 hash_expr (Note _ e) = hash_expr e
1126 hash_expr (Let (NonRec b r) e) = hashId b
1127 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1128 hash_expr (Case _ b _) = hashId b
1129 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1130 hash_expr (Var v) = hashId v
1131 hash_expr (Lit lit) = hashLiteral lit
1132 hash_expr (Lam b _) = hashId b
1133 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1135 fast_hash_expr (Var v) = hashId v
1136 fast_hash_expr (Lit lit) = hashLiteral lit
1137 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1138 fast_hash_expr (App f a) = fast_hash_expr a
1139 fast_hash_expr (Lam b _) = hashId b
1140 fast_hash_expr other = 1
1143 hashId id = hashName (idName id)
1146 %************************************************************************
1148 \subsection{Determining non-updatable right-hand-sides}
1150 %************************************************************************
1152 Top-level constructor applications can usually be allocated
1153 statically, but they can't if the constructor, or any of the
1154 arguments, come from another DLL (because we can't refer to static
1155 labels in other DLLs).
1157 If this happens we simply make the RHS into an updatable thunk,
1158 and 'exectute' it rather than allocating it statically.
1161 rhsIsStatic :: CoreExpr -> Bool
1162 -- This function is called only on *top-level* right-hand sides
1163 -- Returns True if the RHS can be allocated statically, with
1164 -- no thunks involved at all.
1166 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1167 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1168 -- update flag on it.
1170 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1171 -- (a) a value lambda
1172 -- (b) a saturated constructor application with static args
1174 -- BUT watch out for
1175 -- (i) Any cross-DLL references kill static-ness completely
1176 -- because they must be 'executed' not statically allocated
1178 -- (ii) We treat partial applications as redexes, because in fact we
1179 -- make a thunk for them that runs and builds a PAP
1180 -- at run-time. The only appliations that are treated as
1181 -- static are *saturated* applications of constructors.
1183 -- We used to try to be clever with nested structures like this:
1184 -- ys = (:) w ((:) w [])
1185 -- on the grounds that CorePrep will flatten ANF-ise it later.
1186 -- But supporting this special case made the function much more
1187 -- complicated, because the special case only applies if there are no
1188 -- enclosing type lambdas:
1189 -- ys = /\ a -> Foo (Baz ([] a))
1190 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1192 -- But in fact, even without -O, nested structures at top level are
1193 -- flattened by the simplifier, so we don't need to be super-clever here.
1197 -- f = \x::Int. x+7 TRUE
1198 -- p = (True,False) TRUE
1200 -- d = (fst p, False) FALSE because there's a redex inside
1201 -- (this particular one doesn't happen but...)
1203 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1204 -- n = /\a. Nil a TRUE
1206 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1209 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1210 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1212 -- b) (C x xs), where C is a contructors is updatable if the application is
1215 -- c) don't look through unfolding of f in (f x).
1217 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1218 -- them as making the RHS re-entrant (non-updatable).
1220 rhsIsStatic rhs = is_static False rhs
1222 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1225 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1227 is_static in_arg (Note (SCC _) e) = False
1228 is_static in_arg (Note _ e) = is_static in_arg e
1230 is_static in_arg (Lit lit)
1232 MachLabel _ _ -> False
1234 -- A MachLabel (foreign import "&foo") in an argument
1235 -- prevents a constructor application from being static. The
1236 -- reason is that it might give rise to unresolvable symbols
1237 -- in the object file: under Linux, references to "weak"
1238 -- symbols from the data segment give rise to "unresolvable
1239 -- relocation" errors at link time This might be due to a bug
1240 -- in the linker, but we'll work around it here anyway.
1243 is_static in_arg other_expr = go other_expr 0
1245 go (Var f) n_val_args
1246 | not (isDllName (idName f))
1247 = saturated_data_con f n_val_args
1248 || (in_arg && n_val_args == 0)
1249 -- A naked un-applied variable is *not* deemed a static RHS
1251 -- Reason: better to update so that the indirection gets shorted
1252 -- out, and the true value will be seen
1253 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1254 -- are always updatable. If you do so, make sure that non-updatable
1255 -- ones have enough space for their static link field!
1257 go (App f a) n_val_args
1258 | isTypeArg a = go f n_val_args
1259 | not in_arg && is_static True a = go f (n_val_args + 1)
1260 -- The (not in_arg) checks that we aren't in a constructor argument;
1261 -- if we are, we don't allow (value) applications of any sort
1263 -- NB. In case you wonder, args are sometimes not atomic. eg.
1264 -- x = D# (1.0## /## 2.0##)
1265 -- can't float because /## can fail.
1267 go (Note (SCC _) f) n_val_args = False
1268 go (Note _ f) n_val_args = go f n_val_args
1270 go other n_val_args = False
1272 saturated_data_con f n_val_args
1273 = case isDataConWorkId_maybe f of
1274 Just dc -> n_val_args == dataConRepArity dc