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
14 findDefault, findAlt, isDefaultAlt, mergeAlts,
16 -- Properties of expressions
17 exprType, coreAltType,
18 exprIsDupable, exprIsTrivial, exprIsCheap,
19 exprIsHNF,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 )
50 import Packages ( isDllName )
52 import Literal ( hashLiteral, literalType, litIsDupable,
53 litIsTrivial, isZeroLit, Literal( MachLabel ) )
54 import DataCon ( DataCon, dataConRepArity, dataConInstArgTys,
55 isVanillaDataCon, dataConTyCon )
56 import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
57 import Id ( Id, idType, globalIdDetails, idNewStrictness,
58 mkWildId, idArity, idName, idUnfolding, idInfo,
59 isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
60 isDataConWorkId, isBottomingId, isDictId
62 import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
63 import NewDemand ( appIsBottom )
64 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
65 splitFunTy, tcEqTypeX,
66 applyTys, isUnLiftedType, seqType, mkTyVarTy,
67 splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
68 splitTyConApp_maybe, coreEqType, funResultTy, applyTy
70 import TyCon ( tyConArity )
71 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
72 import CostCentre ( CostCentre )
73 import BasicTypes ( Arity )
74 import PackageConfig ( PackageId )
75 import Unique ( Unique )
77 import DynFlags ( DynFlags, DynFlag(Opt_DictsCheap), dopt )
78 import TysPrim ( alphaTy ) -- Debugging only
79 import Util ( equalLength, lengthAtLeast, foldl2 )
83 %************************************************************************
85 \subsection{Find the type of a Core atom/expression}
87 %************************************************************************
90 exprType :: CoreExpr -> Type
92 exprType (Var var) = idType var
93 exprType (Lit lit) = literalType lit
94 exprType (Let _ body) = exprType body
95 exprType (Case _ _ ty alts) = ty
96 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
97 exprType (Note other_note e) = exprType e
98 exprType (Lam binder expr) = mkPiType binder (exprType expr)
100 = case collectArgs e of
101 (fun, args) -> applyTypeToArgs e (exprType fun) args
103 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
105 coreAltType :: CoreAlt -> Type
106 coreAltType (_,_,rhs) = exprType rhs
109 @mkPiType@ makes a (->) type or a forall type, depending on whether
110 it is given a type variable or a term variable. We cleverly use the
111 lbvarinfo field to figure out the right annotation for the arrove in
112 case of a term variable.
115 mkPiType :: Var -> Type -> Type -- The more polymorphic version
116 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
118 mkPiTypes vs ty = foldr mkPiType ty vs
121 | isId v = mkFunTy (idType v) ty
122 | otherwise = mkForAllTy v ty
126 applyTypeToArg :: Type -> CoreExpr -> Type
127 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
128 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
130 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
131 -- A more efficient version of applyTypeToArg
132 -- when we have several args
133 -- The first argument is just for debugging
134 applyTypeToArgs e op_ty [] = op_ty
136 applyTypeToArgs e op_ty (Type ty : args)
137 = -- Accumulate type arguments so we can instantiate all at once
140 go rev_tys (Type ty : args) = go (ty:rev_tys) args
141 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
143 op_ty' = applyTys op_ty (reverse rev_tys)
145 applyTypeToArgs e op_ty (other_arg : args)
146 = case (splitFunTy_maybe op_ty) of
147 Just (_, res_ty) -> applyTypeToArgs e res_ty args
148 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
153 %************************************************************************
155 \subsection{Attaching notes}
157 %************************************************************************
159 mkNote removes redundant coercions, and SCCs where possible
163 mkNote :: Note -> CoreExpr -> CoreExpr
164 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
165 mkNote (SCC cc) expr = mkSCC cc expr
166 mkNote InlineMe expr = mkInlineMe expr
167 mkNote note expr = Note note 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 `coreEqType` to_ty2 )
206 mkCoerce2 to_ty from_ty2 expr
208 mkCoerce2 to_ty from_ty expr
209 | to_ty `coreEqType` from_ty = expr
210 | otherwise = ASSERT( from_ty `coreEqType` 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.
244 bindNonRec bndr rhs body
245 | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
246 | otherwise = Let (NonRec bndr rhs) body
248 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
249 -- Make a case expression instead of a let
250 -- These can arise either from the desugarer,
251 -- or from beta reductions: (\x.e) (x +# y)
255 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
256 -- This guy constructs the value that the scrutinee must have
257 -- when you are in one particular branch of a case
258 mkAltExpr (DataAlt con) args inst_tys
259 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
260 mkAltExpr (LitAlt lit) [] []
263 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
264 mkIfThenElse guard then_expr else_expr
265 -- Not going to be refining, so okay to take the type of the "then" clause
266 = Case guard (mkWildId boolTy) (exprType then_expr)
267 [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
268 (DataAlt trueDataCon, [], then_expr) ]
272 %************************************************************************
274 \subsection{Taking expressions apart}
276 %************************************************************************
278 The default alternative must be first, if it exists at all.
279 This makes it easy to find, though it makes matching marginally harder.
282 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
283 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
284 findDefault alts = (alts, Nothing)
286 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
289 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
290 other -> go alts panic_deflt
292 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
295 go (alt@(con1,_,_) : alts) deflt
296 = case con `cmpAltCon` con1 of
297 LT -> deflt -- Missed it already; the alts are in increasing order
299 GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
301 isDefaultAlt :: CoreAlt -> Bool
302 isDefaultAlt (DEFAULT, _, _) = True
303 isDefaultAlt other = False
305 ---------------------------------
306 mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
307 -- Merge preserving order; alternatives in the first arg
308 -- shadow ones in the second
309 mergeAlts [] as2 = as2
310 mergeAlts as1 [] = as1
311 mergeAlts (a1:as1) (a2:as2)
312 = case a1 `cmpAlt` a2 of
313 LT -> a1 : mergeAlts as1 (a2:as2)
314 EQ -> a1 : mergeAlts as1 as2 -- Discard a2
315 GT -> a2 : mergeAlts (a1:as1) as2
319 %************************************************************************
321 \subsection{Figuring out things about expressions}
323 %************************************************************************
325 @exprIsTrivial@ is true of expressions we are unconditionally happy to
326 duplicate; simple variables and constants, and type
327 applications. Note that primop Ids aren't considered
330 @exprIsBottom@ is true of expressions that are guaranteed to diverge
333 There used to be a gruesome test for (hasNoBinding v) in the
335 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
336 The idea here is that a constructor worker, like $wJust, is
337 really short for (\x -> $wJust x), becuase $wJust has no binding.
338 So it should be treated like a lambda. Ditto unsaturated primops.
339 But now constructor workers are not "have-no-binding" Ids. And
340 completely un-applied primops and foreign-call Ids are sufficiently
341 rare that I plan to allow them to be duplicated and put up with
344 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
345 a) it really generates code, (and a heap object when it's
346 a function arg) to capture the cost centre
347 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
350 exprIsTrivial (Var v) = True -- See notes above
351 exprIsTrivial (Type _) = True
352 exprIsTrivial (Lit lit) = litIsTrivial lit
353 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
354 exprIsTrivial (Note (SCC _) e) = False -- See notes above
355 exprIsTrivial (Note _ e) = exprIsTrivial e
356 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
357 exprIsTrivial other = False
361 @exprIsDupable@ is true of expressions that can be duplicated at a modest
362 cost in code size. This will only happen in different case
363 branches, so there's no issue about duplicating work.
365 That is, exprIsDupable returns True of (f x) even if
366 f is very very expensive to call.
368 Its only purpose is to avoid fruitless let-binding
369 and then inlining of case join points
373 exprIsDupable (Type _) = True
374 exprIsDupable (Var v) = True
375 exprIsDupable (Lit lit) = litIsDupable lit
376 exprIsDupable (Note InlineMe e) = True
377 exprIsDupable (Note _ e) = exprIsDupable e
381 go (Var v) n_args = True
382 go (App f a) n_args = n_args < dupAppSize
385 go other n_args = False
388 dupAppSize = 4 -- Size of application we are prepared to duplicate
391 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
392 it is obviously in weak head normal form, or is cheap to get to WHNF.
393 [Note that that's not the same as exprIsDupable; an expression might be
394 big, and hence not dupable, but still cheap.]
396 By ``cheap'' we mean a computation we're willing to:
397 push inside a lambda, or
398 inline at more than one place
399 That might mean it gets evaluated more than once, instead of being
400 shared. The main examples of things which aren't WHNF but are
405 (where e, and all the ei are cheap)
408 (where e and b are cheap)
411 (where op is a cheap primitive operator)
414 (because we are happy to substitute it inside a lambda)
416 Notice that a variable is considered 'cheap': we can push it inside a lambda,
417 because sharing will make sure it is only evaluated once.
420 exprIsCheap :: CoreExpr -> Bool
421 exprIsCheap (Lit lit) = True
422 exprIsCheap (Type _) = True
423 exprIsCheap (Var _) = True
424 exprIsCheap (Note InlineMe e) = True
425 exprIsCheap (Note _ e) = exprIsCheap e
426 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
427 exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
428 and [exprIsCheap rhs | (_,_,rhs) <- alts]
429 -- Experimentally, treat (case x of ...) as cheap
430 -- (and case __coerce x etc.)
431 -- This improves arities of overloaded functions where
432 -- there is only dictionary selection (no construction) involved
433 exprIsCheap (Let (NonRec x _) e)
434 | isUnLiftedType (idType x) = exprIsCheap e
436 -- strict lets always have cheap right hand sides,
437 -- and do no allocation.
439 exprIsCheap other_expr -- Applications and variables
442 -- Accumulate value arguments, then decide
443 go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
444 | otherwise = go f val_args
446 go (Var f) [] = True -- Just a type application of a variable
447 -- (f t1 t2 t3) counts as WHNF
449 = case globalIdDetails f of
450 RecordSelId {} -> go_sel args
451 ClassOpId _ -> go_sel args
452 PrimOpId op -> go_primop op args
454 DataConWorkId _ -> go_pap args
455 other | length args < idArity f -> go_pap args
457 other -> isBottomingId f
458 -- Application of a function which
459 -- always gives bottom; we treat this as cheap
460 -- because it certainly doesn't need to be shared!
462 go other args = False
465 go_pap args = all exprIsTrivial args
466 -- For constructor applications and primops, check that all
467 -- the args are trivial. We don't want to treat as cheap, say,
469 -- We'll put up with one constructor application, but not dozens
472 go_primop op args = primOpIsCheap op && all exprIsCheap args
473 -- In principle we should worry about primops
474 -- that return a type variable, since the result
475 -- might be applied to something, but I'm not going
476 -- to bother to check the number of args
479 go_sel [arg] = exprIsTrivial arg -- I'm experimenting with making record selection
480 go_sel other = False -- look cheap, so we will substitute it inside a
481 -- lambda. Particularly for dictionary field selection.
482 -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
483 -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
486 exprOkForSpeculation returns True of an expression that it is
488 * safe to evaluate even if normal order eval might not
489 evaluate the expression at all, or
491 * safe *not* to evaluate even if normal order would do so
495 the expression guarantees to terminate,
497 without raising an exception,
498 without causing a side effect (e.g. writing a mutable variable)
500 let x = case y# +# 1# of { r# -> I# r# }
503 case y# +# 1# of { r# ->
508 We can only do this if the (y+1) is ok for speculation: it has no
509 side effects, and can't diverge or raise an exception.
512 exprOkForSpeculation :: CoreExpr -> Bool
513 exprOkForSpeculation (Lit _) = True
514 exprOkForSpeculation (Type _) = True
515 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
516 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
517 exprOkForSpeculation other_expr
518 = case collectArgs other_expr of
519 (Var f, args) -> spec_ok (globalIdDetails f) args
523 spec_ok (DataConWorkId _) args
524 = True -- The strictness of the constructor has already
525 -- been expressed by its "wrapper", so we don't need
526 -- to take the arguments into account
528 spec_ok (PrimOpId op) args
529 | isDivOp op, -- Special case for dividing operations that fail
530 [arg1, Lit lit] <- args -- only if the divisor is zero
531 = not (isZeroLit lit) && exprOkForSpeculation arg1
532 -- Often there is a literal divisor, and this
533 -- can get rid of a thunk in an inner looop
536 = primOpOkForSpeculation op &&
537 all exprOkForSpeculation args
538 -- A bit conservative: we don't really need
539 -- to care about lazy arguments, but this is easy
541 spec_ok other args = False
543 isDivOp :: PrimOp -> Bool
544 -- True of dyadic operators that can fail
545 -- only if the second arg is zero
546 -- This function probably belongs in PrimOp, or even in
547 -- an automagically generated file.. but it's such a
548 -- special case I thought I'd leave it here for now.
549 isDivOp IntQuotOp = True
550 isDivOp IntRemOp = True
551 isDivOp WordQuotOp = True
552 isDivOp WordRemOp = True
553 isDivOp IntegerQuotRemOp = True
554 isDivOp IntegerDivModOp = True
555 isDivOp FloatDivOp = True
556 isDivOp DoubleDivOp = True
557 isDivOp other = False
562 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
563 exprIsBottom e = go 0 e
565 -- n is the number of args
566 go n (Note _ e) = go n e
567 go n (Let _ e) = go n e
568 go n (Case e _ _ _) = go 0 e -- Just check the scrut
569 go n (App e _) = go (n+1) e
570 go n (Var v) = idAppIsBottom v n
572 go n (Lam _ _) = False
573 go n (Type _) = False
575 idAppIsBottom :: Id -> Int -> Bool
576 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
579 @exprIsHNF@ returns true for expressions that are certainly *already*
580 evaluated to *head* normal form. This is used to decide whether it's ok
583 case x of _ -> e ===> e
585 and to decide whether it's safe to discard a `seq`
587 So, it does *not* treat variables as evaluated, unless they say they are.
589 But it *does* treat partial applications and constructor applications
590 as values, even if their arguments are non-trivial, provided the argument
592 e.g. (:) (f x) (map f xs) is a value
593 map (...redex...) is a value
594 Because `seq` on such things completes immediately
596 For unlifted argument types, we have to be careful:
598 Suppose (f x) diverges; then C (f x) is not a value. True, but
599 this form is illegal (see the invariants in CoreSyn). Args of unboxed
600 type must be ok-for-speculation (or trivial).
603 exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
604 exprIsHNF (Var v) -- NB: There are no value args at this point
605 = isDataConWorkId v -- Catches nullary constructors,
606 -- so that [] and () are values, for example
607 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
608 || isEvaldUnfolding (idUnfolding v)
609 -- Check the thing's unfolding; it might be bound to a value
610 -- A worry: what if an Id's unfolding is just itself:
611 -- then we could get an infinite loop...
613 exprIsHNF (Lit l) = True
614 exprIsHNF (Type ty) = True -- Types are honorary Values;
615 -- we don't mind copying them
616 exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
617 exprIsHNF (Note _ e) = exprIsHNF e
618 exprIsHNF (App e (Type _)) = exprIsHNF e
619 exprIsHNF (App e a) = app_is_value e [a]
620 exprIsHNF other = False
622 -- There is at least one value argument
623 app_is_value (Var fun) args
624 | isDataConWorkId fun -- Constructor apps are values
625 || idArity fun > valArgCount args -- Under-applied function
626 = check_args (idType fun) args
627 app_is_value (App f a) as = app_is_value f (a:as)
628 app_is_value other as = False
630 -- 'check_args' checks that unlifted-type args
631 -- are in fact guaranteed non-divergent
632 check_args fun_ty [] = True
633 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
634 Just (_, ty) -> check_args ty args
635 check_args fun_ty (arg : args)
636 | isUnLiftedType arg_ty = exprOkForSpeculation arg
637 | otherwise = check_args res_ty args
639 (arg_ty, res_ty) = splitFunTy fun_ty
643 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
644 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
645 = -- Maybe this is over the top, but here we try to turn
646 -- coerce (S,T) ( x, y )
648 -- ( coerce S x, coerce T y )
649 -- This happens in anger in PrelArrExts which has a coerce
650 -- case coerce memcpy a b of
652 -- where the memcpy is in the IO monad, but the call is in
654 case exprIsConApp_maybe expr of {
658 case splitTyConApp_maybe to_ty of {
660 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
661 | not (isVanillaDataCon dc) -> Nothing
663 -- Type constructor must match
664 -- We knock out existentials to keep matters simple(r)
666 arity = tyConArity tc
667 val_args = drop arity args
668 to_arg_tys = dataConInstArgTys dc tc_arg_tys
669 mk_coerce ty arg = mkCoerce ty arg
670 new_val_args = zipWith mk_coerce to_arg_tys val_args
672 ASSERT( all isTypeArg (take arity args) )
673 ASSERT( equalLength val_args to_arg_tys )
674 Just (dc, map Type tc_arg_tys ++ new_val_args)
677 exprIsConApp_maybe (Note _ expr)
678 = exprIsConApp_maybe expr
679 -- We ignore InlineMe notes in case we have
680 -- x = __inline_me__ (a,b)
681 -- All part of making sure that INLINE pragmas never hurt
682 -- Marcin tripped on this one when making dictionaries more inlinable
684 -- In fact, we ignore all notes. For example,
685 -- case _scc_ "foo" (C a b) of
687 -- should be optimised away, but it will be only if we look
688 -- through the SCC note.
690 exprIsConApp_maybe expr = analyse (collectArgs expr)
692 analyse (Var fun, args)
693 | Just con <- isDataConWorkId_maybe fun,
694 args `lengthAtLeast` dataConRepArity con
695 -- Might be > because the arity excludes type args
698 -- Look through unfoldings, but only cheap ones, because
699 -- we are effectively duplicating the unfolding
700 analyse (Var fun, [])
701 | let unf = idUnfolding fun,
703 = exprIsConApp_maybe (unfoldingTemplate unf)
705 analyse other = Nothing
710 %************************************************************************
712 \subsection{Eta reduction and expansion}
714 %************************************************************************
717 exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
718 {- The Arity returned is the number of value args the
719 thing can be applied to without doing much work
721 exprEtaExpandArity is used when eta expanding
724 It returns 1 (or more) to:
725 case x of p -> \s -> ...
726 because for I/O ish things we really want to get that \s to the top.
727 We are prepared to evaluate x each time round the loop in order to get that
729 It's all a bit more subtle than it looks:
733 Consider one-shot lambdas
734 let x = expensive in \y z -> E
735 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
736 Hence the ArityType returned by arityType
738 2. The state-transformer hack
740 The one-shot lambda special cause is particularly important/useful for
741 IO state transformers, where we often get
742 let x = E in \ s -> ...
744 and the \s is a real-world state token abstraction. Such abstractions
745 are almost invariably 1-shot, so we want to pull the \s out, past the
746 let x=E, even if E is expensive. So we treat state-token lambdas as
747 one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
749 3. Dealing with bottom
752 f = \x -> error "foo"
753 Here, arity 1 is fine. But if it is
757 then we want to get arity 2. Tecnically, this isn't quite right, because
759 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
760 do so; it improves some programs significantly, and increasing convergence
761 isn't a bad thing. Hence the ABot/ATop in ArityType.
763 Actually, the situation is worse. Consider
767 Can we eta-expand here? At first the answer looks like "yes of course", but
770 This should diverge! But if we eta-expand, it won't. Again, we ignore this
771 "problem", because being scrupulous would lose an important transformation for
777 Non-recursive newtypes are transparent, and should not get in the way.
778 We do (currently) eta-expand recursive newtypes too. So if we have, say
780 newtype T = MkT ([T] -> Int)
784 where f has arity 1. Then: etaExpandArity e = 1;
785 that is, etaExpandArity looks through the coerce.
787 When we eta-expand e to arity 1: eta_expand 1 e T
788 we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
790 HOWEVER, note that if you use coerce bogusly you can ge
792 And since negate has arity 2, you might try to eta expand. But you can't
793 decopose Int to a function type. Hence the final case in eta_expand.
797 exprEtaExpandArity dflags e = arityDepth (arityType dflags e)
799 -- A limited sort of function type
800 data ArityType = AFun Bool ArityType -- True <=> one-shot
801 | ATop -- Know nothing
804 arityDepth :: ArityType -> Arity
805 arityDepth (AFun _ ty) = 1 + arityDepth ty
808 andArityType ABot at2 = at2
809 andArityType ATop at2 = ATop
810 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
811 andArityType at1 at2 = andArityType at2 at1
813 arityType :: DynFlags -> CoreExpr -> ArityType
814 -- (go1 e) = [b1,..,bn]
815 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
816 -- where bi is True <=> the lambda is one-shot
818 arityType dflags (Note n e) = arityType dflags e
819 -- Not needed any more: etaExpand is cleverer
820 -- | ok_note n = arityType dflags e
821 -- | otherwise = ATop
823 arityType dflags (Var v)
824 = mk (idArity v) (arg_tys (idType v))
826 mk :: Arity -> [Type] -> ArityType
827 -- The argument types are only to steer the "state hack"
828 -- Consider case x of
830 -- False -> \(s:RealWorld) -> e
831 -- where foo has arity 1. Then we want the state hack to
832 -- apply to foo too, so we can eta expand the case.
833 mk 0 tys | isBottomingId v = ABot
834 | (ty:tys) <- tys, isStateHackType ty = AFun True ATop
836 mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
837 mk n [] = AFun False (mk (n-1) [])
839 arg_tys :: Type -> [Type] -- Ignore for-alls
841 | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
842 | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
845 -- Lambdas; increase arity
846 arityType dflags (Lam x e)
847 | isId x = AFun (isOneShotBndr x) (arityType dflags e)
848 | otherwise = arityType dflags e
850 -- Applications; decrease arity
851 arityType dflags (App f (Type _)) = arityType dflags f
852 arityType dflags (App f a) = case arityType dflags f of
853 AFun one_shot xs | exprIsCheap a -> xs
856 -- Case/Let; keep arity if either the expression is cheap
857 -- or it's a 1-shot lambda
858 -- The former is not really right for Haskell
859 -- f x = case x of { (a,b) -> \y. e }
861 -- f x y = case x of { (a,b) -> e }
862 -- The difference is observable using 'seq'
863 arityType dflags (Case scrut _ _ alts)
864 = case foldr1 andArityType [arityType dflags rhs | (_,_,rhs) <- alts] of
865 xs | exprIsCheap scrut -> xs
866 xs@(AFun one_shot _) | one_shot -> AFun True ATop
869 arityType dflags (Let b e)
870 = case arityType dflags e of
871 xs | cheap_bind b -> xs
872 xs@(AFun one_shot _) | one_shot -> AFun True ATop
875 cheap_bind (NonRec b e) = is_cheap (b,e)
876 cheap_bind (Rec prs) = all is_cheap prs
877 is_cheap (b,e) = (dopt Opt_DictsCheap dflags && isDictId b)
879 -- If the experimental -fdicts-cheap flag is on, we eta-expand through
880 -- dictionary bindings. This improves arities. Thereby, it also
881 -- means that full laziness is less prone to floating out the
882 -- application of a function to its dictionary arguments, which
883 -- can thereby lose opportunities for fusion. Example:
884 -- foo :: Ord a => a -> ...
885 -- foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
886 -- -- So foo has arity 1
888 -- f = \x. foo dInt $ bar x
890 -- The (foo DInt) is floated out, and makes ineffective a RULE
893 -- One could go further and make exprIsCheap reply True to any
894 -- dictionary-typed expression, but that's more work.
896 arityType dflags other = ATop
898 {- NOT NEEDED ANY MORE: etaExpand is cleverer
899 ok_note InlineMe = False
901 -- Notice that we do not look through __inline_me__
902 -- This may seem surprising, but consider
903 -- f = _inline_me (\x -> e)
904 -- We DO NOT want to eta expand this to
905 -- f = \x -> (_inline_me (\x -> e)) x
906 -- because the _inline_me gets dropped now it is applied,
915 etaExpand :: Arity -- Result should have this number of value args
917 -> CoreExpr -> Type -- Expression and its type
919 -- (etaExpand n us e ty) returns an expression with
920 -- the same meaning as 'e', but with arity 'n'.
922 -- Given e' = etaExpand n us e ty
924 -- ty = exprType e = exprType e'
926 -- Note that SCCs are not treated specially. If we have
927 -- etaExpand 2 (\x -> scc "foo" e)
928 -- = (\xy -> (scc "foo" e) y)
929 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
931 etaExpand n us expr ty
932 | manifestArity expr >= n = expr -- The no-op case
933 | otherwise = eta_expand n us expr ty
936 -- manifestArity sees how many leading value lambdas there are
937 manifestArity :: CoreExpr -> Arity
938 manifestArity (Lam v e) | isId v = 1 + manifestArity e
939 | otherwise = manifestArity e
940 manifestArity (Note _ e) = manifestArity e
943 -- etaExpand deals with for-alls. For example:
945 -- where E :: forall a. a -> a
947 -- (/\b. \y::a -> E b y)
949 -- It deals with coerces too, though they are now rare
950 -- so perhaps the extra code isn't worth it
952 eta_expand n us expr ty
954 -- The ILX code generator requires eta expansion for type arguments
955 -- too, but alas the 'n' doesn't tell us how many of them there
956 -- may be. So we eagerly eta expand any big lambdas, and just
957 -- cross our fingers about possible loss of sharing in the ILX case.
958 -- The Right Thing is probably to make 'arity' include
959 -- type variables throughout the compiler. (ToDo.)
961 -- Saturated, so nothing to do
964 -- Short cut for the case where there already
965 -- is a lambda; no point in gratuitously adding more
966 eta_expand n us (Lam v body) ty
968 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
971 = Lam v (eta_expand (n-1) us body (funResultTy ty))
973 -- We used to have a special case that stepped inside Coerces here,
974 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
975 -- = Note note (eta_expand n us e ty)
976 -- BUT this led to an infinite loop
977 -- Example: newtype T = MkT (Int -> Int)
978 -- eta_expand 1 (coerce (Int->Int) e)
979 -- --> coerce (Int->Int) (eta_expand 1 T e)
981 -- --> coerce (Int->Int) (coerce T
982 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
983 -- by the splitNewType_maybe case below
986 eta_expand n us expr ty
987 = case splitForAllTy_maybe ty of {
988 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
992 case splitFunTy_maybe ty of {
993 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
995 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
1001 -- newtype T = MkT ([T] -> Int)
1002 -- Consider eta-expanding this
1005 -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
1006 -- Only try this for recursive newtypes; the non-recursive kind
1007 -- are transparent anyway
1009 case splitRecNewType_maybe ty of {
1010 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
1013 -- We have an expression of arity > 0, but its type isn't a function
1014 -- This *can* legitmately happen: e.g. coerce Int (\x. x)
1015 -- Essentially the programmer is playing fast and loose with types
1016 -- (Happy does this a lot). So we simply decline to eta-expand.
1021 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
1022 It tells how many things the expression can be applied to before doing
1023 any work. It doesn't look inside cases, lets, etc. The idea is that
1024 exprEtaExpandArity will do the hard work, leaving something that's easy
1025 for exprArity to grapple with. In particular, Simplify uses exprArity to
1026 compute the ArityInfo for the Id.
1028 Originally I thought that it was enough just to look for top-level lambdas, but
1029 it isn't. I've seen this
1031 foo = PrelBase.timesInt
1033 We want foo to get arity 2 even though the eta-expander will leave it
1034 unchanged, in the expectation that it'll be inlined. But occasionally it
1035 isn't, because foo is blacklisted (used in a rule).
1037 Similarly, see the ok_note check in exprEtaExpandArity. So
1038 f = __inline_me (\x -> e)
1039 won't be eta-expanded.
1041 And in any case it seems more robust to have exprArity be a bit more intelligent.
1042 But note that (\x y z -> f x y z)
1043 should have arity 3, regardless of f's arity.
1046 exprArity :: CoreExpr -> Arity
1049 go (Var v) = idArity v
1050 go (Lam x e) | isId x = go e + 1
1052 go (Note n e) = go e
1053 go (App e (Type t)) = go e
1054 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
1055 -- NB: exprIsCheap a!
1056 -- f (fac x) does not have arity 2,
1057 -- even if f has arity 3!
1058 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
1059 -- unknown, hence arity 0
1063 %************************************************************************
1065 \subsection{Equality}
1067 %************************************************************************
1069 @cheapEqExpr@ is a cheap equality test which bales out fast!
1070 True => definitely equal
1071 False => may or may not be equal
1074 cheapEqExpr :: Expr b -> Expr b -> Bool
1076 cheapEqExpr (Var v1) (Var v2) = v1==v2
1077 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1078 cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
1080 cheapEqExpr (App f1 a1) (App f2 a2)
1081 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1083 cheapEqExpr _ _ = False
1085 exprIsBig :: Expr b -> Bool
1086 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1087 exprIsBig (Lit _) = False
1088 exprIsBig (Var v) = False
1089 exprIsBig (Type t) = False
1090 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1091 exprIsBig other = True
1096 tcEqExpr :: CoreExpr -> CoreExpr -> Bool
1097 -- Used in rule matching, so does *not* look through
1098 -- newtypes, predicate types; hence tcEqExpr
1100 tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
1102 rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
1104 tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
1105 tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
1106 tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2
1107 tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
1108 tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
1109 tcEqExprX env (Let (NonRec v1 r1) e1)
1110 (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
1111 && tcEqExprX (rnBndr2 env v1 v2) e1 e2
1112 tcEqExprX env (Let (Rec ps1) e1)
1113 (Let (Rec ps2) e2) = equalLength ps1 ps2
1114 && and (zipWith eq_rhs ps1 ps2)
1115 && tcEqExprX env' e1 e2
1117 env' = foldl2 rn_bndr2 env ps2 ps2
1118 rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
1119 eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
1120 tcEqExprX env (Case e1 v1 t1 a1)
1121 (Case e2 v2 t2 a2) = tcEqExprX env e1 e2
1122 && tcEqTypeX env t1 t2
1123 && equalLength a1 a2
1124 && and (zipWith (eq_alt env') a1 a2)
1126 env' = rnBndr2 env v1 v2
1128 tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
1129 tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
1130 tcEqExprX env e1 e2 = False
1132 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
1134 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1135 eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2
1136 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1137 eq_note env other1 other2 = False
1141 %************************************************************************
1143 \subsection{The size of an expression}
1145 %************************************************************************
1148 coreBindsSize :: [CoreBind] -> Int
1149 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1151 exprSize :: CoreExpr -> Int
1152 -- A measure of the size of the expressions
1153 -- It also forces the expression pretty drastically as a side effect
1154 exprSize (Var v) = v `seq` 1
1155 exprSize (Lit lit) = lit `seq` 1
1156 exprSize (App f a) = exprSize f + exprSize a
1157 exprSize (Lam b e) = varSize b + exprSize e
1158 exprSize (Let b e) = bindSize b + exprSize e
1159 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1160 exprSize (Note n e) = noteSize n + exprSize e
1161 exprSize (Type t) = seqType t `seq` 1
1163 noteSize (SCC cc) = cc `seq` 1
1164 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1165 noteSize InlineMe = 1
1166 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1168 varSize :: Var -> Int
1169 varSize b | isTyVar b = 1
1170 | otherwise = seqType (idType b) `seq`
1171 megaSeqIdInfo (idInfo b) `seq`
1174 varsSize = foldr ((+) . varSize) 0
1176 bindSize (NonRec b e) = varSize b + exprSize e
1177 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1179 pairSize (b,e) = varSize b + exprSize e
1181 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1185 %************************************************************************
1187 \subsection{Hashing}
1189 %************************************************************************
1192 hashExpr :: CoreExpr -> Int
1193 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1196 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1198 hash_expr (Note _ e) = hash_expr e
1199 hash_expr (Let (NonRec b r) e) = hashId b
1200 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1201 hash_expr (Case _ b _ _) = hashId b
1202 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1203 hash_expr (Var v) = hashId v
1204 hash_expr (Lit lit) = hashLiteral lit
1205 hash_expr (Lam b _) = hashId b
1206 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1208 fast_hash_expr (Var v) = hashId v
1209 fast_hash_expr (Lit lit) = hashLiteral lit
1210 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1211 fast_hash_expr (App f a) = fast_hash_expr a
1212 fast_hash_expr (Lam b _) = hashId b
1213 fast_hash_expr other = 1
1216 hashId id = hashName (idName id)
1219 %************************************************************************
1221 \subsection{Determining non-updatable right-hand-sides}
1223 %************************************************************************
1225 Top-level constructor applications can usually be allocated
1226 statically, but they can't if the constructor, or any of the
1227 arguments, come from another DLL (because we can't refer to static
1228 labels in other DLLs).
1230 If this happens we simply make the RHS into an updatable thunk,
1231 and 'exectute' it rather than allocating it statically.
1234 rhsIsStatic :: PackageId -> CoreExpr -> Bool
1235 -- This function is called only on *top-level* right-hand sides
1236 -- Returns True if the RHS can be allocated statically, with
1237 -- no thunks involved at all.
1239 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1240 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1241 -- update flag on it.
1243 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1244 -- (a) a value lambda
1245 -- (b) a saturated constructor application with static args
1247 -- BUT watch out for
1248 -- (i) Any cross-DLL references kill static-ness completely
1249 -- because they must be 'executed' not statically allocated
1250 -- ("DLL" here really only refers to Windows DLLs, on other platforms,
1251 -- this is not necessary)
1253 -- (ii) We treat partial applications as redexes, because in fact we
1254 -- make a thunk for them that runs and builds a PAP
1255 -- at run-time. The only appliations that are treated as
1256 -- static are *saturated* applications of constructors.
1258 -- We used to try to be clever with nested structures like this:
1259 -- ys = (:) w ((:) w [])
1260 -- on the grounds that CorePrep will flatten ANF-ise it later.
1261 -- But supporting this special case made the function much more
1262 -- complicated, because the special case only applies if there are no
1263 -- enclosing type lambdas:
1264 -- ys = /\ a -> Foo (Baz ([] a))
1265 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1267 -- But in fact, even without -O, nested structures at top level are
1268 -- flattened by the simplifier, so we don't need to be super-clever here.
1272 -- f = \x::Int. x+7 TRUE
1273 -- p = (True,False) TRUE
1275 -- d = (fst p, False) FALSE because there's a redex inside
1276 -- (this particular one doesn't happen but...)
1278 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1279 -- n = /\a. Nil a TRUE
1281 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1284 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
1285 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1287 -- b) (C x xs), where C is a contructors is updatable if the application is
1290 -- c) don't look through unfolding of f in (f x).
1292 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1293 -- them as making the RHS re-entrant (non-updatable).
1295 rhsIsStatic this_pkg rhs = is_static False rhs
1297 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1300 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1302 is_static in_arg (Note (SCC _) e) = False
1303 is_static in_arg (Note _ e) = is_static in_arg e
1305 is_static in_arg (Lit lit)
1307 MachLabel _ _ -> False
1309 -- A MachLabel (foreign import "&foo") in an argument
1310 -- prevents a constructor application from being static. The
1311 -- reason is that it might give rise to unresolvable symbols
1312 -- in the object file: under Linux, references to "weak"
1313 -- symbols from the data segment give rise to "unresolvable
1314 -- relocation" errors at link time This might be due to a bug
1315 -- in the linker, but we'll work around it here anyway.
1318 is_static in_arg other_expr = go other_expr 0
1320 go (Var f) n_val_args
1321 #if mingw32_TARGET_OS
1322 | not (isDllName this_pkg (idName f))
1324 = saturated_data_con f n_val_args
1325 || (in_arg && n_val_args == 0)
1326 -- A naked un-applied variable is *not* deemed a static RHS
1328 -- Reason: better to update so that the indirection gets shorted
1329 -- out, and the true value will be seen
1330 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1331 -- are always updatable. If you do so, make sure that non-updatable
1332 -- ones have enough space for their static link field!
1334 go (App f a) n_val_args
1335 | isTypeArg a = go f n_val_args
1336 | not in_arg && is_static True a = go f (n_val_args + 1)
1337 -- The (not in_arg) checks that we aren't in a constructor argument;
1338 -- if we are, we don't allow (value) applications of any sort
1340 -- NB. In case you wonder, args are sometimes not atomic. eg.
1341 -- x = D# (1.0## /## 2.0##)
1342 -- can't float because /## can fail.
1344 go (Note (SCC _) f) n_val_args = False
1345 go (Note _ f) n_val_args = go f n_val_args
1347 go other n_val_args = False
1349 saturated_data_con f n_val_args
1350 = case isDataConWorkId_maybe f of
1351 Just dc -> n_val_args == dataConRepArity dc