2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
10 bindNonRec, needsCaseBinding,
11 mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
13 -- Taking expressions apart
16 -- Properties of expressions
17 exprType, coreAltType,
18 exprIsDupable, exprIsTrivial, exprIsCheap,
19 exprIsValue,exprOkForSpeculation, exprIsBig,
20 exprIsConApp_maybe, exprIsBottom,
23 -- Arity and eta expansion
24 manifestArity, exprArity,
25 exprEtaExpandArity, etaExpand,
34 cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg
37 #include "HsVersions.h"
40 import GLAEXTS -- For `xori`
43 import CoreFVs ( exprFreeVars )
44 import PprCore ( pprCoreExpr )
46 import VarSet ( unionVarSet )
48 import Name ( hashName )
49 import Packages ( isDllName )
50 import CmdLineOpts ( DynFlags )
51 import Literal ( hashLiteral, literalType, litIsDupable,
52 litIsTrivial, isZeroLit, Literal( MachLabel ) )
53 import DataCon ( DataCon, dataConRepArity, dataConArgTys,
54 isVanillaDataCon, dataConTyCon )
55 import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
56 import Id ( Id, idType, globalIdDetails, idNewStrictness,
57 mkWildId, idArity, idName, idUnfolding, idInfo,
58 isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
59 isDataConWorkId, isBottomingId
61 import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
62 import NewDemand ( appIsBottom )
63 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
64 splitFunTy, tcEqTypeX,
65 applyTys, isUnLiftedType, seqType, mkTyVarTy,
66 splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
67 splitTyConApp_maybe, coreEqType, funResultTy, applyTy
69 import TyCon ( tyConArity )
71 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
72 import CostCentre ( CostCentre )
73 import BasicTypes ( Arity )
74 import Unique ( Unique )
76 import TysPrim ( alphaTy ) -- Debugging only
77 import Util ( equalLength, lengthAtLeast, foldl2 )
81 %************************************************************************
83 \subsection{Find the type of a Core atom/expression}
85 %************************************************************************
88 exprType :: CoreExpr -> Type
90 exprType (Var var) = idType var
91 exprType (Lit lit) = literalType lit
92 exprType (Let _ body) = exprType body
94 exprType (Case _ _ ty alts) = ty
95 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
96 exprType (Note other_note e) = exprType e
97 exprType (Lam binder expr) = mkPiType binder (exprType expr)
99 = case collectArgs e of
100 (fun, args) -> applyTypeToArgs e (exprType fun) args
102 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
104 coreAltType :: CoreAlt -> Type
105 coreAltType (_,_,rhs) = exprType rhs
108 @mkPiType@ makes a (->) type or a forall type, depending on whether
109 it is given a type variable or a term variable. We cleverly use the
110 lbvarinfo field to figure out the right annotation for the arrove in
111 case of a term variable.
114 mkPiType :: Var -> Type -> Type -- The more polymorphic version
115 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
117 mkPiTypes vs ty = foldr mkPiType ty vs
120 | isId v = mkFunTy (idType v) ty
121 | otherwise = mkForAllTy v ty
125 applyTypeToArg :: Type -> CoreExpr -> Type
126 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
127 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
129 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
130 -- A more efficient version of applyTypeToArg
131 -- when we have several args
132 -- The first argument is just for debugging
133 applyTypeToArgs e op_ty [] = op_ty
135 applyTypeToArgs e op_ty (Type ty : args)
136 = -- Accumulate type arguments so we can instantiate all at once
139 go rev_tys (Type ty : args) = go (ty:rev_tys) args
140 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
142 op_ty' = applyTys op_ty (reverse rev_tys)
144 applyTypeToArgs e op_ty (other_arg : args)
145 = case (splitFunTy_maybe op_ty) of
146 Just (_, res_ty) -> applyTypeToArgs e res_ty args
147 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
152 %************************************************************************
154 \subsection{Attaching notes}
156 %************************************************************************
158 mkNote removes redundant coercions, and SCCs where possible
162 mkNote :: Note -> CoreExpr -> CoreExpr
163 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
164 mkNote (SCC cc) expr = mkSCC cc expr
165 mkNote InlineMe expr = mkInlineMe expr
166 mkNote note expr = Note note expr
169 -- Slide InlineCall in around the function
170 -- No longer necessary I think (SLPJ Apr 99)
171 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
172 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
173 -- mkNote InlineCall expr = expr
176 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
177 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
178 not be *applied* to anything.
180 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
183 f = inline_me (coerce t fw)
184 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
185 We want the split, so that the coerces can cancel at the call site.
187 However, we can get left with tiresome type applications. Notably, consider
188 f = /\ a -> let t = e in (t, w)
189 Then lifting the let out of the big lambda gives
191 f = /\ a -> let t = inline_me (t' a) in (t, w)
192 The inline_me is to stop the simplifier inlining t' right back
193 into t's RHS. In the next phase we'll substitute for t (since
194 its rhs is trivial) and *then* we could get rid of the inline_me.
195 But it hardly seems worth it, so I don't bother.
198 mkInlineMe (Var v) = Var v
199 mkInlineMe e = Note InlineMe e
205 mkCoerce :: Type -> CoreExpr -> CoreExpr
206 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
208 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
209 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
210 = ASSERT( from_ty `coreEqType` to_ty2 )
211 mkCoerce2 to_ty from_ty2 expr
213 mkCoerce2 to_ty from_ty expr
214 | to_ty `coreEqType` from_ty = expr
215 | otherwise = ASSERT( from_ty `coreEqType` exprType expr )
216 Note (Coerce to_ty from_ty) expr
220 mkSCC :: CostCentre -> Expr b -> Expr b
221 -- Note: Nested SCC's *are* preserved for the benefit of
222 -- cost centre stack profiling
223 mkSCC cc (Lit lit) = Lit lit
224 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
225 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
226 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
227 mkSCC cc expr = Note (SCC cc) expr
231 %************************************************************************
233 \subsection{Other expression construction}
235 %************************************************************************
238 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
239 -- (bindNonRec x r b) produces either
242 -- case r of x { _DEFAULT_ -> b }
244 -- depending on whether x is unlifted or not
245 -- It's used by the desugarer to avoid building bindings
246 -- that give Core Lint a heart attack. Actually the simplifier
247 -- deals with them perfectly well.
249 bindNonRec bndr rhs body
251 | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
252 | otherwise = Let (NonRec bndr rhs) body
254 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
255 -- Make a case expression instead of a let
256 -- These can arise either from the desugarer,
257 -- or from beta reductions: (\x.e) (x +# y)
261 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
262 -- This guy constructs the value that the scrutinee must have
263 -- when you are in one particular branch of a case
264 mkAltExpr (DataAlt con) args inst_tys
265 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
266 mkAltExpr (LitAlt lit) [] []
269 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
270 mkIfThenElse guard then_expr else_expr
272 -- Not going to be refining, so okay to take the type of the "then" clause
273 = Case guard (mkWildId boolTy) (exprType then_expr)
274 [ (DataAlt trueDataCon, [], then_expr),
275 (DataAlt falseDataCon, [], else_expr) ]
279 %************************************************************************
281 \subsection{Taking expressions apart}
283 %************************************************************************
285 The default alternative must be first, if it exists at all.
286 This makes it easy to find, though it makes matching marginally harder.
289 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
290 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
291 findDefault alts = (alts, Nothing)
293 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
296 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
297 other -> go alts panic_deflt
300 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
303 go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
304 | otherwise = ASSERT( not (con1 == DEFAULT) )
309 %************************************************************************
311 \subsection{Figuring out things about expressions}
313 %************************************************************************
315 @exprIsTrivial@ is true of expressions we are unconditionally happy to
316 duplicate; simple variables and constants, and type
317 applications. Note that primop Ids aren't considered
320 @exprIsBottom@ is true of expressions that are guaranteed to diverge
323 There used to be a gruesome test for (hasNoBinding v) in the
325 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
326 The idea here is that a constructor worker, like $wJust, is
327 really short for (\x -> $wJust x), becuase $wJust has no binding.
328 So it should be treated like a lambda. Ditto unsaturated primops.
329 But now constructor workers are not "have-no-binding" Ids. And
330 completely un-applied primops and foreign-call Ids are sufficiently
331 rare that I plan to allow them to be duplicated and put up with
334 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
335 a) it really generates code, (and a heap object when it's
336 a function arg) to capture the cost centre
337 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
340 exprIsTrivial (Var v) = True -- See notes above
341 exprIsTrivial (Type _) = True
342 exprIsTrivial (Lit lit) = litIsTrivial lit
343 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
344 exprIsTrivial (Note (SCC _) e) = False -- See notes above
345 exprIsTrivial (Note _ e) = exprIsTrivial e
346 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
347 exprIsTrivial other = False
351 @exprIsDupable@ is true of expressions that can be duplicated at a modest
352 cost in code size. This will only happen in different case
353 branches, so there's no issue about duplicating work.
355 That is, exprIsDupable returns True of (f x) even if
356 f is very very expensive to call.
358 Its only purpose is to avoid fruitless let-binding
359 and then inlining of case join points
363 exprIsDupable (Type _) = True
364 exprIsDupable (Var v) = True
365 exprIsDupable (Lit lit) = litIsDupable lit
366 exprIsDupable (Note InlineMe e) = True
367 exprIsDupable (Note _ e) = exprIsDupable e
371 go (Var v) n_args = True
372 go (App f a) n_args = n_args < dupAppSize
375 go other n_args = False
378 dupAppSize = 4 -- Size of application we are prepared to duplicate
381 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
382 it is obviously in weak head normal form, or is cheap to get to WHNF.
383 [Note that that's not the same as exprIsDupable; an expression might be
384 big, and hence not dupable, but still cheap.]
386 By ``cheap'' we mean a computation we're willing to:
387 push inside a lambda, or
388 inline at more than one place
389 That might mean it gets evaluated more than once, instead of being
390 shared. The main examples of things which aren't WHNF but are
395 (where e, and all the ei are cheap)
398 (where e and b are cheap)
401 (where op is a cheap primitive operator)
404 (because we are happy to substitute it inside a lambda)
406 Notice that a variable is considered 'cheap': we can push it inside a lambda,
407 because sharing will make sure it is only evaluated once.
410 exprIsCheap :: CoreExpr -> Bool
411 exprIsCheap (Lit lit) = True
412 exprIsCheap (Type _) = True
413 exprIsCheap (Var _) = True
414 exprIsCheap (Note InlineMe e) = True
415 exprIsCheap (Note _ e) = exprIsCheap e
416 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
418 exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
419 and [exprIsCheap rhs | (_,_,rhs) <- alts]
420 -- Experimentally, treat (case x of ...) as cheap
421 -- (and case __coerce x etc.)
422 -- This improves arities of overloaded functions where
423 -- there is only dictionary selection (no construction) involved
424 exprIsCheap (Let (NonRec x _) e)
425 | isUnLiftedType (idType x) = exprIsCheap e
427 -- strict lets always have cheap right hand sides, and
430 exprIsCheap other_expr
431 = go other_expr 0 True
433 go (Var f) n_args args_cheap
434 = (idAppIsCheap f n_args && args_cheap)
435 -- A constructor, cheap primop, or partial application
437 || idAppIsBottom f n_args
438 -- Application of a function which
439 -- always gives bottom; we treat this as cheap
440 -- because it certainly doesn't need to be shared!
442 go (App f a) n_args args_cheap
443 | not (isRuntimeArg a) = go f n_args args_cheap
444 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
446 go other n_args args_cheap = False
448 idAppIsCheap :: Id -> Int -> Bool
449 idAppIsCheap id n_val_args
450 | n_val_args == 0 = True -- Just a type application of
451 -- a variable (f t1 t2 t3)
453 | otherwise = case globalIdDetails id of
454 DataConWorkId _ -> True
455 RecordSelId _ _ -> True -- I'm experimenting with making record selection
456 ClassOpId _ -> True -- look cheap, so we will substitute it inside a
457 -- lambda. Particularly for dictionary field selection
459 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
460 -- that return a type variable, since the result
461 -- might be applied to something, but I'm not going
462 -- to bother to check the number of args
463 other -> n_val_args < idArity id
466 exprOkForSpeculation returns True of an expression that it is
468 * safe to evaluate even if normal order eval might not
469 evaluate the expression at all, or
471 * safe *not* to evaluate even if normal order would do so
475 the expression guarantees to terminate,
477 without raising an exception,
478 without causing a side effect (e.g. writing a mutable variable)
481 let x = case y# +# 1# of { r# -> I# r# }
484 case y# +# 1# of { r# ->
489 We can only do this if the (y+1) is ok for speculation: it has no
490 side effects, and can't diverge or raise an exception.
493 exprOkForSpeculation :: CoreExpr -> Bool
494 exprOkForSpeculation (Lit _) = True
495 exprOkForSpeculation (Type _) = True
496 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
497 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
498 exprOkForSpeculation other_expr
499 = case collectArgs other_expr of
500 (Var f, args) -> spec_ok (globalIdDetails f) args
504 spec_ok (DataConWorkId _) args
505 = True -- The strictness of the constructor has already
506 -- been expressed by its "wrapper", so we don't need
507 -- to take the arguments into account
509 spec_ok (PrimOpId op) args
510 | isDivOp op, -- Special case for dividing operations that fail
511 [arg1, Lit lit] <- args -- only if the divisor is zero
512 = not (isZeroLit lit) && exprOkForSpeculation arg1
513 -- Often there is a literal divisor, and this
514 -- can get rid of a thunk in an inner looop
517 = primOpOkForSpeculation op &&
518 all exprOkForSpeculation args
519 -- A bit conservative: we don't really need
520 -- to care about lazy arguments, but this is easy
522 spec_ok other args = False
524 isDivOp :: PrimOp -> Bool
525 -- True of dyadic operators that can fail
526 -- only if the second arg is zero
527 -- This function probably belongs in PrimOp, or even in
528 -- an automagically generated file.. but it's such a
529 -- special case I thought I'd leave it here for now.
530 isDivOp IntQuotOp = True
531 isDivOp IntRemOp = True
532 isDivOp WordQuotOp = True
533 isDivOp WordRemOp = True
534 isDivOp IntegerQuotRemOp = True
535 isDivOp IntegerDivModOp = True
536 isDivOp FloatDivOp = True
537 isDivOp DoubleDivOp = True
538 isDivOp other = False
543 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
544 exprIsBottom e = go 0 e
546 -- n is the number of args
547 go n (Note _ e) = go n e
548 go n (Let _ e) = go n e
550 go n (Case e _ _ _) = go 0 e -- Just check the scrut
551 go n (App e _) = go (n+1) e
552 go n (Var v) = idAppIsBottom v n
554 go n (Lam _ _) = False
556 idAppIsBottom :: Id -> Int -> Bool
557 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
560 @exprIsValue@ returns true for expressions that are certainly *already*
561 evaluated to *head* normal form. This is used to decide whether it's ok
564 case x of _ -> e ===> e
566 and to decide whether it's safe to discard a `seq`
568 So, it does *not* treat variables as evaluated, unless they say they are.
570 But it *does* treat partial applications and constructor applications
571 as values, even if their arguments are non-trivial, provided the argument
573 e.g. (:) (f x) (map f xs) is a value
574 map (...redex...) is a value
575 Because `seq` on such things completes immediately
577 For unlifted argument types, we have to be careful:
579 Suppose (f x) diverges; then C (f x) is not a value. True, but
580 this form is illegal (see the invariants in CoreSyn). Args of unboxed
581 type must be ok-for-speculation (or trivial).
584 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
585 exprIsValue (Var v) -- NB: There are no value args at this point
586 = isDataConWorkId v -- Catches nullary constructors,
587 -- so that [] and () are values, for example
588 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
589 || isEvaldUnfolding (idUnfolding v)
590 -- Check the thing's unfolding; it might be bound to a value
591 -- A worry: what if an Id's unfolding is just itself:
592 -- then we could get an infinite loop...
594 exprIsValue (Lit l) = True
595 exprIsValue (Type ty) = True -- Types are honorary Values;
596 -- we don't mind copying them
597 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
598 exprIsValue (Note _ e) = exprIsValue e
599 exprIsValue (App e (Type _)) = exprIsValue e
600 exprIsValue (App e a) = app_is_value e [a]
601 exprIsValue other = False
603 -- There is at least one value argument
604 app_is_value (Var fun) args
605 | isDataConWorkId fun -- Constructor apps are values
606 || idArity fun > valArgCount args -- Under-applied function
607 = check_args (idType fun) args
608 app_is_value (App f a) as = app_is_value f (a:as)
609 app_is_value other as = False
611 -- 'check_args' checks that unlifted-type args
612 -- are in fact guaranteed non-divergent
613 check_args fun_ty [] = True
614 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
615 Just (_, ty) -> check_args ty args
616 check_args fun_ty (arg : args)
617 | isUnLiftedType arg_ty = exprOkForSpeculation arg
618 | otherwise = check_args res_ty args
620 (arg_ty, res_ty) = splitFunTy fun_ty
624 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
625 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
626 = -- Maybe this is over the top, but here we try to turn
627 -- coerce (S,T) ( x, y )
629 -- ( coerce S x, coerce T y )
630 -- This happens in anger in PrelArrExts which has a coerce
631 -- case coerce memcpy a b of
633 -- where the memcpy is in the IO monad, but the call is in
635 case exprIsConApp_maybe expr of {
639 case splitTyConApp_maybe to_ty of {
641 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
642 | not (isVanillaDataCon dc) -> Nothing
644 -- Type constructor must match
645 -- We knock out existentials to keep matters simple(r)
647 arity = tyConArity tc
648 val_args = drop arity args
649 to_arg_tys = dataConArgTys dc tc_arg_tys
650 mk_coerce ty arg = mkCoerce ty arg
651 new_val_args = zipWith mk_coerce to_arg_tys val_args
653 ASSERT( all isTypeArg (take arity args) )
654 ASSERT( equalLength val_args to_arg_tys )
655 Just (dc, map Type tc_arg_tys ++ new_val_args)
658 exprIsConApp_maybe (Note _ expr)
659 = exprIsConApp_maybe expr
660 -- We ignore InlineMe notes in case we have
661 -- x = __inline_me__ (a,b)
662 -- All part of making sure that INLINE pragmas never hurt
663 -- Marcin tripped on this one when making dictionaries more inlinable
665 -- In fact, we ignore all notes. For example,
666 -- case _scc_ "foo" (C a b) of
668 -- should be optimised away, but it will be only if we look
669 -- through the SCC note.
671 exprIsConApp_maybe expr = analyse (collectArgs expr)
673 analyse (Var fun, args)
674 | Just con <- isDataConWorkId_maybe fun,
675 args `lengthAtLeast` dataConRepArity con
676 -- Might be > because the arity excludes type args
679 -- Look through unfoldings, but only cheap ones, because
680 -- we are effectively duplicating the unfolding
681 analyse (Var fun, [])
682 | let unf = idUnfolding fun,
684 = exprIsConApp_maybe (unfoldingTemplate unf)
686 analyse other = Nothing
691 %************************************************************************
693 \subsection{Eta reduction and expansion}
695 %************************************************************************
698 exprEtaExpandArity :: CoreExpr -> Arity
699 {- The Arity returned is the number of value args the
700 thing can be applied to without doing much work
702 exprEtaExpandArity is used when eta expanding
705 It returns 1 (or more) to:
706 case x of p -> \s -> ...
707 because for I/O ish things we really want to get that \s to the top.
708 We are prepared to evaluate x each time round the loop in order to get that
710 It's all a bit more subtle than it looks:
714 Consider one-shot lambdas
715 let x = expensive in \y z -> E
716 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
717 Hence the ArityType returned by arityType
719 2. The state-transformer hack
721 The one-shot lambda special cause is particularly important/useful for
722 IO state transformers, where we often get
723 let x = E in \ s -> ...
725 and the \s is a real-world state token abstraction. Such abstractions
726 are almost invariably 1-shot, so we want to pull the \s out, past the
727 let x=E, even if E is expensive. So we treat state-token lambdas as
728 one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
730 3. Dealing with bottom
733 f = \x -> error "foo"
734 Here, arity 1 is fine. But if it is
738 then we want to get arity 2. Tecnically, this isn't quite right, because
740 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
741 do so; it improves some programs significantly, and increasing convergence
742 isn't a bad thing. Hence the ABot/ATop in ArityType.
744 Actually, the situation is worse. Consider
748 Can we eta-expand here? At first the answer looks like "yes of course", but
751 This should diverge! But if we eta-expand, it won't. Again, we ignore this
752 "problem", because being scrupulous would lose an important transformation for
757 exprEtaExpandArity e = arityDepth (arityType e)
759 -- A limited sort of function type
760 data ArityType = AFun Bool ArityType -- True <=> one-shot
761 | ATop -- Know nothing
764 arityDepth :: ArityType -> Arity
765 arityDepth (AFun _ ty) = 1 + arityDepth ty
768 andArityType ABot at2 = at2
769 andArityType ATop at2 = ATop
770 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
771 andArityType at1 at2 = andArityType at2 at1
773 arityType :: CoreExpr -> ArityType
774 -- (go1 e) = [b1,..,bn]
775 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
776 -- where bi is True <=> the lambda is one-shot
778 arityType (Note n e) = arityType e
779 -- Not needed any more: etaExpand is cleverer
780 -- | ok_note n = arityType e
781 -- | otherwise = ATop
784 = mk (idArity v) (arg_tys (idType v))
786 mk :: Arity -> [Type] -> ArityType
787 -- The argument types are only to steer the "state hack"
788 -- Consider case x of
790 -- False -> \(s:RealWorld) -> e
791 -- where foo has arity 1. Then we want the state hack to
792 -- apply to foo too, so we can eta expand the case.
793 mk 0 tys | isBottomingId v = ABot
795 mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
796 mk n [] = AFun False (mk (n-1) [])
798 arg_tys :: Type -> [Type] -- Ignore for-alls
800 | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
801 | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
804 -- Lambdas; increase arity
805 arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
806 | otherwise = arityType e
808 -- Applications; decrease arity
809 arityType (App f (Type _)) = arityType f
810 arityType (App f a) = case arityType f of
811 AFun one_shot xs | exprIsCheap a -> xs
814 -- Case/Let; keep arity if either the expression is cheap
815 -- or it's a 1-shot lambda
816 -- The former is not really right for Haskell
817 -- f x = case x of { (a,b) -> \y. e }
819 -- f x y = case x of { (a,b) -> e }
820 -- The difference is observable using 'seq'
822 arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
823 xs@(AFun one_shot _) | one_shot -> xs
824 xs | exprIsCheap scrut -> xs
827 arityType (Let b e) = case arityType e of
828 xs@(AFun one_shot _) | one_shot -> xs
829 xs | all exprIsCheap (rhssOfBind b) -> xs
832 arityType other = ATop
834 {- NOT NEEDED ANY MORE: etaExpand is cleverer
835 ok_note InlineMe = False
837 -- Notice that we do not look through __inline_me__
838 -- This may seem surprising, but consider
839 -- f = _inline_me (\x -> e)
840 -- We DO NOT want to eta expand this to
841 -- f = \x -> (_inline_me (\x -> e)) x
842 -- because the _inline_me gets dropped now it is applied,
851 etaExpand :: Arity -- Result should have this number of value args
853 -> CoreExpr -> Type -- Expression and its type
855 -- (etaExpand n us e ty) returns an expression with
856 -- the same meaning as 'e', but with arity 'n'.
858 -- Given e' = etaExpand n us e ty
860 -- ty = exprType e = exprType e'
862 -- Note that SCCs are not treated specially. If we have
863 -- etaExpand 2 (\x -> scc "foo" e)
864 -- = (\xy -> (scc "foo" e) y)
865 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
867 etaExpand n us expr ty
868 | manifestArity expr >= n = expr -- The no-op case
869 | otherwise = eta_expand n us expr ty
872 -- manifestArity sees how many leading value lambdas there are
873 manifestArity :: CoreExpr -> Arity
874 manifestArity (Lam v e) | isId v = 1 + manifestArity e
875 | otherwise = manifestArity e
876 manifestArity (Note _ e) = manifestArity e
879 -- etaExpand deals with for-alls. For example:
881 -- where E :: forall a. a -> a
883 -- (/\b. \y::a -> E b y)
885 -- It deals with coerces too, though they are now rare
886 -- so perhaps the extra code isn't worth it
888 eta_expand n us expr ty
890 -- The ILX code generator requires eta expansion for type arguments
891 -- too, but alas the 'n' doesn't tell us how many of them there
892 -- may be. So we eagerly eta expand any big lambdas, and just
893 -- cross our fingers about possible loss of sharing in the ILX case.
894 -- The Right Thing is probably to make 'arity' include
895 -- type variables throughout the compiler. (ToDo.)
897 -- Saturated, so nothing to do
900 -- Short cut for the case where there already
901 -- is a lambda; no point in gratuitously adding more
902 eta_expand n us (Lam v body) ty
904 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
907 = Lam v (eta_expand (n-1) us body (funResultTy ty))
909 -- We used to have a special case that stepped inside Coerces here,
910 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
911 -- = Note note (eta_expand n us e ty)
912 -- BUT this led to an infinite loop
913 -- Example: newtype T = MkT (Int -> Int)
914 -- eta_expand 1 (coerce (Int->Int) e)
915 -- --> coerce (Int->Int) (eta_expand 1 T e)
917 -- --> coerce (Int->Int) (coerce T
918 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
919 -- by the splitNewType_maybe case below
922 eta_expand n us expr ty
923 = case splitForAllTy_maybe ty of {
924 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
928 case splitFunTy_maybe ty of {
929 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
931 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
937 -- newtype T = MkT ([T] -> Int)
938 -- Consider eta-expanding this
941 -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
942 -- Only try this for recursive newtypes; the non-recursive kind
943 -- are transparent anyway
945 case splitRecNewType_maybe ty of {
946 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
947 Nothing -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
951 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
952 It tells how many things the expression can be applied to before doing
953 any work. It doesn't look inside cases, lets, etc. The idea is that
954 exprEtaExpandArity will do the hard work, leaving something that's easy
955 for exprArity to grapple with. In particular, Simplify uses exprArity to
956 compute the ArityInfo for the Id.
958 Originally I thought that it was enough just to look for top-level lambdas, but
959 it isn't. I've seen this
961 foo = PrelBase.timesInt
963 We want foo to get arity 2 even though the eta-expander will leave it
964 unchanged, in the expectation that it'll be inlined. But occasionally it
965 isn't, because foo is blacklisted (used in a rule).
967 Similarly, see the ok_note check in exprEtaExpandArity. So
968 f = __inline_me (\x -> e)
969 won't be eta-expanded.
971 And in any case it seems more robust to have exprArity be a bit more intelligent.
972 But note that (\x y z -> f x y z)
973 should have arity 3, regardless of f's arity.
976 exprArity :: CoreExpr -> Arity
979 go (Var v) = idArity v
980 go (Lam x e) | isId x = go e + 1
983 go (App e (Type t)) = go e
984 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
985 -- NB: exprIsCheap a!
986 -- f (fac x) does not have arity 2,
987 -- even if f has arity 3!
988 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
989 -- unknown, hence arity 0
993 %************************************************************************
995 \subsection{Equality}
997 %************************************************************************
999 @cheapEqExpr@ is a cheap equality test which bales out fast!
1000 True => definitely equal
1001 False => may or may not be equal
1004 cheapEqExpr :: Expr b -> Expr b -> Bool
1006 cheapEqExpr (Var v1) (Var v2) = v1==v2
1007 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1008 cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
1010 cheapEqExpr (App f1 a1) (App f2 a2)
1011 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1013 cheapEqExpr _ _ = False
1015 exprIsBig :: Expr b -> Bool
1016 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1017 exprIsBig (Lit _) = False
1018 exprIsBig (Var v) = False
1019 exprIsBig (Type t) = False
1020 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1021 exprIsBig other = True
1026 tcEqExpr :: CoreExpr -> CoreExpr -> Bool
1027 -- Used in rule matching, so does *not* look through
1028 -- newtypes, predicate types; hence tcEqExpr
1030 tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
1032 rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
1034 tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
1035 tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
1036 tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2
1037 tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
1038 tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
1039 tcEqExprX env (Let (NonRec v1 r1) e1)
1040 (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
1041 && tcEqExprX (rnBndr2 env v1 v2) e1 e2
1042 tcEqExprX env (Let (Rec ps1) e1)
1043 (Let (Rec ps2) e2) = equalLength ps1 ps2
1044 && and (zipWith eq_rhs ps1 ps2)
1045 && tcEqExprX env' e1 e2
1047 env' = foldl2 rn_bndr2 env ps2 ps2
1048 rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
1049 eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
1050 tcEqExprX env (Case e1 v1 t1 a1)
1051 (Case e2 v2 t2 a2) = tcEqExprX env e1 e2
1052 && tcEqTypeX env t1 t2
1053 && equalLength a1 a2
1054 && and (zipWith (eq_alt env') a1 a2)
1056 env' = rnBndr2 env v1 v2
1058 tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
1059 tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
1060 tcEqExprX env e1 e2 = False
1062 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
1064 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1065 eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2
1066 eq_note env InlineCall InlineCall = True
1067 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1068 eq_note env other1 other2 = False
1072 %************************************************************************
1074 \subsection{The size of an expression}
1076 %************************************************************************
1079 coreBindsSize :: [CoreBind] -> Int
1080 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1082 exprSize :: CoreExpr -> Int
1083 -- A measure of the size of the expressions
1084 -- It also forces the expression pretty drastically as a side effect
1085 exprSize (Var v) = v `seq` 1
1086 exprSize (Lit lit) = lit `seq` 1
1087 exprSize (App f a) = exprSize f + exprSize a
1088 exprSize (Lam b e) = varSize b + exprSize e
1089 exprSize (Let b e) = bindSize b + exprSize e
1091 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1092 exprSize (Note n e) = noteSize n + exprSize e
1093 exprSize (Type t) = seqType t `seq` 1
1095 noteSize (SCC cc) = cc `seq` 1
1096 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1097 noteSize InlineCall = 1
1098 noteSize InlineMe = 1
1099 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1101 varSize :: Var -> Int
1102 varSize b | isTyVar b = 1
1103 | otherwise = seqType (idType b) `seq`
1104 megaSeqIdInfo (idInfo b) `seq`
1107 varsSize = foldr ((+) . varSize) 0
1109 bindSize (NonRec b e) = varSize b + exprSize e
1110 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1112 pairSize (b,e) = varSize b + exprSize e
1114 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1118 %************************************************************************
1120 \subsection{Hashing}
1122 %************************************************************************
1125 hashExpr :: CoreExpr -> Int
1126 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1129 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1131 hash_expr (Note _ e) = hash_expr e
1132 hash_expr (Let (NonRec b r) e) = hashId b
1133 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1135 hash_expr (Case _ b _ _) = hashId b
1136 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1137 hash_expr (Var v) = hashId v
1138 hash_expr (Lit lit) = hashLiteral lit
1139 hash_expr (Lam b _) = hashId b
1140 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1142 fast_hash_expr (Var v) = hashId v
1143 fast_hash_expr (Lit lit) = hashLiteral lit
1144 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1145 fast_hash_expr (App f a) = fast_hash_expr a
1146 fast_hash_expr (Lam b _) = hashId b
1147 fast_hash_expr other = 1
1150 hashId id = hashName (idName id)
1153 %************************************************************************
1155 \subsection{Determining non-updatable right-hand-sides}
1157 %************************************************************************
1159 Top-level constructor applications can usually be allocated
1160 statically, but they can't if the constructor, or any of the
1161 arguments, come from another DLL (because we can't refer to static
1162 labels in other DLLs).
1164 If this happens we simply make the RHS into an updatable thunk,
1165 and 'exectute' it rather than allocating it statically.
1168 rhsIsStatic :: DynFlags -> CoreExpr -> Bool
1169 -- This function is called only on *top-level* right-hand sides
1170 -- Returns True if the RHS can be allocated statically, with
1171 -- no thunks involved at all.
1173 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1174 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1175 -- update flag on it.
1177 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1178 -- (a) a value lambda
1179 -- (b) a saturated constructor application with static args
1181 -- BUT watch out for
1182 -- (i) Any cross-DLL references kill static-ness completely
1183 -- because they must be 'executed' not statically allocated
1185 -- (ii) We treat partial applications as redexes, because in fact we
1186 -- make a thunk for them that runs and builds a PAP
1187 -- at run-time. The only appliations that are treated as
1188 -- static are *saturated* applications of constructors.
1190 -- We used to try to be clever with nested structures like this:
1191 -- ys = (:) w ((:) w [])
1192 -- on the grounds that CorePrep will flatten ANF-ise it later.
1193 -- But supporting this special case made the function much more
1194 -- complicated, because the special case only applies if there are no
1195 -- enclosing type lambdas:
1196 -- ys = /\ a -> Foo (Baz ([] a))
1197 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1199 -- But in fact, even without -O, nested structures at top level are
1200 -- flattened by the simplifier, so we don't need to be super-clever here.
1204 -- f = \x::Int. x+7 TRUE
1205 -- p = (True,False) TRUE
1207 -- d = (fst p, False) FALSE because there's a redex inside
1208 -- (this particular one doesn't happen but...)
1210 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1211 -- n = /\a. Nil a TRUE
1213 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1216 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1217 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1219 -- b) (C x xs), where C is a contructors is updatable if the application is
1222 -- c) don't look through unfolding of f in (f x).
1224 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1225 -- them as making the RHS re-entrant (non-updatable).
1227 rhsIsStatic dflags rhs = is_static False rhs
1229 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1232 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1234 is_static in_arg (Note (SCC _) e) = False
1235 is_static in_arg (Note _ e) = is_static in_arg e
1237 is_static in_arg (Lit lit)
1239 MachLabel _ _ -> False
1241 -- A MachLabel (foreign import "&foo") in an argument
1242 -- prevents a constructor application from being static. The
1243 -- reason is that it might give rise to unresolvable symbols
1244 -- in the object file: under Linux, references to "weak"
1245 -- symbols from the data segment give rise to "unresolvable
1246 -- relocation" errors at link time This might be due to a bug
1247 -- in the linker, but we'll work around it here anyway.
1250 is_static in_arg other_expr = go other_expr 0
1252 go (Var f) n_val_args
1253 | not (isDllName dflags (idName f))
1254 = saturated_data_con f n_val_args
1255 || (in_arg && n_val_args == 0)
1256 -- A naked un-applied variable is *not* deemed a static RHS
1258 -- Reason: better to update so that the indirection gets shorted
1259 -- out, and the true value will be seen
1260 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1261 -- are always updatable. If you do so, make sure that non-updatable
1262 -- ones have enough space for their static link field!
1264 go (App f a) n_val_args
1265 | isTypeArg a = go f n_val_args
1266 | not in_arg && is_static True a = go f (n_val_args + 1)
1267 -- The (not in_arg) checks that we aren't in a constructor argument;
1268 -- if we are, we don't allow (value) applications of any sort
1270 -- NB. In case you wonder, args are sometimes not atomic. eg.
1271 -- x = D# (1.0## /## 2.0##)
1272 -- can't float because /## can fail.
1274 go (Note (SCC _) f) n_val_args = False
1275 go (Note _ f) n_val_args = go f n_val_args
1277 go other n_val_args = False
1279 saturated_data_con f n_val_args
1280 = case isDataConWorkId_maybe f of
1281 Just dc -> n_val_args == dataConRepArity dc