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,
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 )
49 import Packages ( isDllName, HomeModules )
50 import Literal ( hashLiteral, literalType, litIsDupable,
51 litIsTrivial, isZeroLit, Literal( MachLabel ) )
52 import DataCon ( DataCon, dataConRepArity, dataConArgTys,
53 isVanillaDataCon, dataConTyCon )
54 import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
55 import Id ( Id, idType, globalIdDetails, idNewStrictness,
56 mkWildId, idArity, idName, idUnfolding, idInfo,
57 isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
58 isDataConWorkId, isBottomingId
60 import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
61 import NewDemand ( appIsBottom )
62 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
63 splitFunTy, tcEqTypeX,
64 applyTys, isUnLiftedType, seqType, mkTyVarTy,
65 splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
66 splitTyConApp_maybe, coreEqType, funResultTy, applyTy
68 import TyCon ( tyConArity )
70 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
71 import CostCentre ( CostCentre )
72 import BasicTypes ( Arity )
73 import Unique ( Unique )
75 import TysPrim ( alphaTy ) -- Debugging only
76 import Util ( equalLength, lengthAtLeast, foldl2 )
80 %************************************************************************
82 \subsection{Find the type of a Core atom/expression}
84 %************************************************************************
87 exprType :: CoreExpr -> Type
89 exprType (Var var) = idType var
90 exprType (Lit lit) = literalType lit
91 exprType (Let _ body) = exprType body
92 exprType (Case _ _ ty alts) = ty
93 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
94 exprType (Note other_note e) = exprType e
95 exprType (Lam binder expr) = mkPiType binder (exprType expr)
97 = case collectArgs e of
98 (fun, args) -> applyTypeToArgs e (exprType fun) args
100 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
102 coreAltType :: CoreAlt -> Type
103 coreAltType (_,_,rhs) = exprType rhs
106 @mkPiType@ makes a (->) type or a forall type, depending on whether
107 it is given a type variable or a term variable. We cleverly use the
108 lbvarinfo field to figure out the right annotation for the arrove in
109 case of a term variable.
112 mkPiType :: Var -> Type -> Type -- The more polymorphic version
113 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
115 mkPiTypes vs ty = foldr mkPiType ty vs
118 | isId v = mkFunTy (idType v) ty
119 | otherwise = mkForAllTy v ty
123 applyTypeToArg :: Type -> CoreExpr -> Type
124 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
125 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
127 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
128 -- A more efficient version of applyTypeToArg
129 -- when we have several args
130 -- The first argument is just for debugging
131 applyTypeToArgs e op_ty [] = op_ty
133 applyTypeToArgs e op_ty (Type ty : args)
134 = -- Accumulate type arguments so we can instantiate all at once
137 go rev_tys (Type ty : args) = go (ty:rev_tys) args
138 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
140 op_ty' = applyTys op_ty (reverse rev_tys)
142 applyTypeToArgs e op_ty (other_arg : args)
143 = case (splitFunTy_maybe op_ty) of
144 Just (_, res_ty) -> applyTypeToArgs e res_ty args
145 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
150 %************************************************************************
152 \subsection{Attaching notes}
154 %************************************************************************
156 mkNote removes redundant coercions, and SCCs where possible
160 mkNote :: Note -> CoreExpr -> CoreExpr
161 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
162 mkNote (SCC cc) expr = mkSCC cc expr
163 mkNote InlineMe expr = mkInlineMe expr
164 mkNote note expr = Note note expr
167 -- Slide InlineCall in around the function
168 -- No longer necessary I think (SLPJ Apr 99)
169 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
170 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
171 -- mkNote InlineCall expr = expr
174 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
175 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
176 not be *applied* to anything.
178 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
181 f = inline_me (coerce t fw)
182 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
183 We want the split, so that the coerces can cancel at the call site.
185 However, we can get left with tiresome type applications. Notably, consider
186 f = /\ a -> let t = e in (t, w)
187 Then lifting the let out of the big lambda gives
189 f = /\ a -> let t = inline_me (t' a) in (t, w)
190 The inline_me is to stop the simplifier inlining t' right back
191 into t's RHS. In the next phase we'll substitute for t (since
192 its rhs is trivial) and *then* we could get rid of the inline_me.
193 But it hardly seems worth it, so I don't bother.
196 mkInlineMe (Var v) = Var v
197 mkInlineMe e = Note InlineMe e
203 mkCoerce :: Type -> CoreExpr -> CoreExpr
204 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
206 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
207 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
208 = ASSERT( from_ty `coreEqType` to_ty2 )
209 mkCoerce2 to_ty from_ty2 expr
211 mkCoerce2 to_ty from_ty expr
212 | to_ty `coreEqType` from_ty = expr
213 | otherwise = ASSERT( from_ty `coreEqType` exprType expr )
214 Note (Coerce to_ty from_ty) expr
218 mkSCC :: CostCentre -> Expr b -> Expr b
219 -- Note: Nested SCC's *are* preserved for the benefit of
220 -- cost centre stack profiling
221 mkSCC cc (Lit lit) = Lit lit
222 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
223 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
224 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
225 mkSCC cc expr = Note (SCC cc) expr
229 %************************************************************************
231 \subsection{Other expression construction}
233 %************************************************************************
236 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
237 -- (bindNonRec x r b) produces either
240 -- case r of x { _DEFAULT_ -> b }
242 -- depending on whether x is unlifted or not
243 -- It's used by the desugarer to avoid building bindings
244 -- that give Core Lint a heart attack. Actually the simplifier
245 -- deals with them perfectly well.
247 bindNonRec bndr rhs body
248 | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
249 | otherwise = Let (NonRec bndr rhs) body
251 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
252 -- Make a case expression instead of a let
253 -- These can arise either from the desugarer,
254 -- or from beta reductions: (\x.e) (x +# y)
258 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
259 -- This guy constructs the value that the scrutinee must have
260 -- when you are in one particular branch of a case
261 mkAltExpr (DataAlt con) args inst_tys
262 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
263 mkAltExpr (LitAlt lit) [] []
266 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
267 mkIfThenElse guard then_expr else_expr
268 -- Not going to be refining, so okay to take the type of the "then" clause
269 = Case guard (mkWildId boolTy) (exprType then_expr)
270 [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
271 (DataAlt trueDataCon, [], then_expr) ]
275 %************************************************************************
277 \subsection{Taking expressions apart}
279 %************************************************************************
281 The default alternative must be first, if it exists at all.
282 This makes it easy to find, though it makes matching marginally harder.
285 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
286 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
287 findDefault alts = (alts, Nothing)
289 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
292 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
293 other -> go alts panic_deflt
295 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
298 go (alt@(con1,_,_) : alts) deflt
299 = case con `cmpAltCon` con1 of
300 LT -> deflt -- Missed it already; the alts are in increasing order
302 GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
304 isDefaultAlt :: CoreAlt -> Bool
305 isDefaultAlt (DEFAULT, _, _) = True
306 isDefaultAlt other = False
310 %************************************************************************
312 \subsection{Figuring out things about expressions}
314 %************************************************************************
316 @exprIsTrivial@ is true of expressions we are unconditionally happy to
317 duplicate; simple variables and constants, and type
318 applications. Note that primop Ids aren't considered
321 @exprIsBottom@ is true of expressions that are guaranteed to diverge
324 There used to be a gruesome test for (hasNoBinding v) in the
326 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
327 The idea here is that a constructor worker, like $wJust, is
328 really short for (\x -> $wJust x), becuase $wJust has no binding.
329 So it should be treated like a lambda. Ditto unsaturated primops.
330 But now constructor workers are not "have-no-binding" Ids. And
331 completely un-applied primops and foreign-call Ids are sufficiently
332 rare that I plan to allow them to be duplicated and put up with
335 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
336 a) it really generates code, (and a heap object when it's
337 a function arg) to capture the cost centre
338 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
341 exprIsTrivial (Var v) = True -- See notes above
342 exprIsTrivial (Type _) = True
343 exprIsTrivial (Lit lit) = litIsTrivial lit
344 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
345 exprIsTrivial (Note (SCC _) e) = False -- See notes above
346 exprIsTrivial (Note _ e) = exprIsTrivial e
347 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
348 exprIsTrivial other = False
352 @exprIsDupable@ is true of expressions that can be duplicated at a modest
353 cost in code size. This will only happen in different case
354 branches, so there's no issue about duplicating work.
356 That is, exprIsDupable returns True of (f x) even if
357 f is very very expensive to call.
359 Its only purpose is to avoid fruitless let-binding
360 and then inlining of case join points
364 exprIsDupable (Type _) = True
365 exprIsDupable (Var v) = True
366 exprIsDupable (Lit lit) = litIsDupable lit
367 exprIsDupable (Note InlineMe e) = True
368 exprIsDupable (Note _ e) = exprIsDupable e
372 go (Var v) n_args = True
373 go (App f a) n_args = n_args < dupAppSize
376 go other n_args = False
379 dupAppSize = 4 -- Size of application we are prepared to duplicate
382 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
383 it is obviously in weak head normal form, or is cheap to get to WHNF.
384 [Note that that's not the same as exprIsDupable; an expression might be
385 big, and hence not dupable, but still cheap.]
387 By ``cheap'' we mean a computation we're willing to:
388 push inside a lambda, or
389 inline at more than one place
390 That might mean it gets evaluated more than once, instead of being
391 shared. The main examples of things which aren't WHNF but are
396 (where e, and all the ei are cheap)
399 (where e and b are cheap)
402 (where op is a cheap primitive operator)
405 (because we are happy to substitute it inside a lambda)
407 Notice that a variable is considered 'cheap': we can push it inside a lambda,
408 because sharing will make sure it is only evaluated once.
411 exprIsCheap :: CoreExpr -> Bool
412 exprIsCheap (Lit lit) = True
413 exprIsCheap (Type _) = True
414 exprIsCheap (Var _) = True
415 exprIsCheap (Note InlineMe e) = True
416 exprIsCheap (Note _ e) = exprIsCheap e
417 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)
454 = case globalIdDetails id of
455 DataConWorkId _ -> True
456 RecordSelId _ _ -> n_val_args == 1 -- I'm experimenting with making record selection
457 ClassOpId _ -> n_val_args == 1 -- look cheap, so we will substitute it inside a
458 -- lambda. Particularly for dictionary field selection.
459 -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
460 -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
462 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
463 -- that return a type variable, since the result
464 -- might be applied to something, but I'm not going
465 -- to bother to check the number of args
466 other -> n_val_args < idArity id
469 exprOkForSpeculation returns True of an expression that it is
471 * safe to evaluate even if normal order eval might not
472 evaluate the expression at all, or
474 * safe *not* to evaluate even if normal order would do so
478 the expression guarantees to terminate,
480 without raising an exception,
481 without causing a side effect (e.g. writing a mutable variable)
484 let x = case y# +# 1# of { r# -> I# r# }
487 case y# +# 1# of { r# ->
492 We can only do this if the (y+1) is ok for speculation: it has no
493 side effects, and can't diverge or raise an exception.
496 exprOkForSpeculation :: CoreExpr -> Bool
497 exprOkForSpeculation (Lit _) = True
498 exprOkForSpeculation (Type _) = True
499 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
500 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
501 exprOkForSpeculation other_expr
502 = case collectArgs other_expr of
503 (Var f, args) -> spec_ok (globalIdDetails f) args
507 spec_ok (DataConWorkId _) args
508 = True -- The strictness of the constructor has already
509 -- been expressed by its "wrapper", so we don't need
510 -- to take the arguments into account
512 spec_ok (PrimOpId op) args
513 | isDivOp op, -- Special case for dividing operations that fail
514 [arg1, Lit lit] <- args -- only if the divisor is zero
515 = not (isZeroLit lit) && exprOkForSpeculation arg1
516 -- Often there is a literal divisor, and this
517 -- can get rid of a thunk in an inner looop
520 = primOpOkForSpeculation op &&
521 all exprOkForSpeculation args
522 -- A bit conservative: we don't really need
523 -- to care about lazy arguments, but this is easy
525 spec_ok other args = False
527 isDivOp :: PrimOp -> Bool
528 -- True of dyadic operators that can fail
529 -- only if the second arg is zero
530 -- This function probably belongs in PrimOp, or even in
531 -- an automagically generated file.. but it's such a
532 -- special case I thought I'd leave it here for now.
533 isDivOp IntQuotOp = True
534 isDivOp IntRemOp = True
535 isDivOp WordQuotOp = True
536 isDivOp WordRemOp = True
537 isDivOp IntegerQuotRemOp = True
538 isDivOp IntegerDivModOp = True
539 isDivOp FloatDivOp = True
540 isDivOp DoubleDivOp = True
541 isDivOp other = False
546 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
547 exprIsBottom e = go 0 e
549 -- n is the number of args
550 go n (Note _ e) = go n e
551 go n (Let _ e) = go n e
552 go n (Case e _ _ _) = go 0 e -- Just check the scrut
553 go n (App e _) = go (n+1) e
554 go n (Var v) = idAppIsBottom v n
556 go n (Lam _ _) = False
557 go n (Type _) = False
559 idAppIsBottom :: Id -> Int -> Bool
560 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
563 @exprIsHNF@ returns true for expressions that are certainly *already*
564 evaluated to *head* normal form. This is used to decide whether it's ok
567 case x of _ -> e ===> e
569 and to decide whether it's safe to discard a `seq`
571 So, it does *not* treat variables as evaluated, unless they say they are.
573 But it *does* treat partial applications and constructor applications
574 as values, even if their arguments are non-trivial, provided the argument
576 e.g. (:) (f x) (map f xs) is a value
577 map (...redex...) is a value
578 Because `seq` on such things completes immediately
580 For unlifted argument types, we have to be careful:
582 Suppose (f x) diverges; then C (f x) is not a value. True, but
583 this form is illegal (see the invariants in CoreSyn). Args of unboxed
584 type must be ok-for-speculation (or trivial).
587 exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
588 exprIsHNF (Var v) -- NB: There are no value args at this point
589 = isDataConWorkId v -- Catches nullary constructors,
590 -- so that [] and () are values, for example
591 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
592 || isEvaldUnfolding (idUnfolding v)
593 -- Check the thing's unfolding; it might be bound to a value
594 -- A worry: what if an Id's unfolding is just itself:
595 -- then we could get an infinite loop...
597 exprIsHNF (Lit l) = True
598 exprIsHNF (Type ty) = True -- Types are honorary Values;
599 -- we don't mind copying them
600 exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
601 exprIsHNF (Note _ e) = exprIsHNF e
602 exprIsHNF (App e (Type _)) = exprIsHNF e
603 exprIsHNF (App e a) = app_is_value e [a]
604 exprIsHNF other = False
606 -- There is at least one value argument
607 app_is_value (Var fun) args
608 | isDataConWorkId fun -- Constructor apps are values
609 || idArity fun > valArgCount args -- Under-applied function
610 = check_args (idType fun) args
611 app_is_value (App f a) as = app_is_value f (a:as)
612 app_is_value other as = False
614 -- 'check_args' checks that unlifted-type args
615 -- are in fact guaranteed non-divergent
616 check_args fun_ty [] = True
617 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
618 Just (_, ty) -> check_args ty args
619 check_args fun_ty (arg : args)
620 | isUnLiftedType arg_ty = exprOkForSpeculation arg
621 | otherwise = check_args res_ty args
623 (arg_ty, res_ty) = splitFunTy fun_ty
627 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
628 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
629 = -- Maybe this is over the top, but here we try to turn
630 -- coerce (S,T) ( x, y )
632 -- ( coerce S x, coerce T y )
633 -- This happens in anger in PrelArrExts which has a coerce
634 -- case coerce memcpy a b of
636 -- where the memcpy is in the IO monad, but the call is in
638 case exprIsConApp_maybe expr of {
642 case splitTyConApp_maybe to_ty of {
644 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
645 | not (isVanillaDataCon dc) -> Nothing
647 -- Type constructor must match
648 -- We knock out existentials to keep matters simple(r)
650 arity = tyConArity tc
651 val_args = drop arity args
652 to_arg_tys = dataConArgTys dc tc_arg_tys
653 mk_coerce ty arg = mkCoerce ty arg
654 new_val_args = zipWith mk_coerce to_arg_tys val_args
656 ASSERT( all isTypeArg (take arity args) )
657 ASSERT( equalLength val_args to_arg_tys )
658 Just (dc, map Type tc_arg_tys ++ new_val_args)
661 exprIsConApp_maybe (Note _ expr)
662 = exprIsConApp_maybe expr
663 -- We ignore InlineMe notes in case we have
664 -- x = __inline_me__ (a,b)
665 -- All part of making sure that INLINE pragmas never hurt
666 -- Marcin tripped on this one when making dictionaries more inlinable
668 -- In fact, we ignore all notes. For example,
669 -- case _scc_ "foo" (C a b) of
671 -- should be optimised away, but it will be only if we look
672 -- through the SCC note.
674 exprIsConApp_maybe expr = analyse (collectArgs expr)
676 analyse (Var fun, args)
677 | Just con <- isDataConWorkId_maybe fun,
678 args `lengthAtLeast` dataConRepArity con
679 -- Might be > because the arity excludes type args
682 -- Look through unfoldings, but only cheap ones, because
683 -- we are effectively duplicating the unfolding
684 analyse (Var fun, [])
685 | let unf = idUnfolding fun,
687 = exprIsConApp_maybe (unfoldingTemplate unf)
689 analyse other = Nothing
694 %************************************************************************
696 \subsection{Eta reduction and expansion}
698 %************************************************************************
701 exprEtaExpandArity :: CoreExpr -> Arity
702 {- The Arity returned is the number of value args the
703 thing can be applied to without doing much work
705 exprEtaExpandArity is used when eta expanding
708 It returns 1 (or more) to:
709 case x of p -> \s -> ...
710 because for I/O ish things we really want to get that \s to the top.
711 We are prepared to evaluate x each time round the loop in order to get that
713 It's all a bit more subtle than it looks:
717 Consider one-shot lambdas
718 let x = expensive in \y z -> E
719 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
720 Hence the ArityType returned by arityType
722 2. The state-transformer hack
724 The one-shot lambda special cause is particularly important/useful for
725 IO state transformers, where we often get
726 let x = E in \ s -> ...
728 and the \s is a real-world state token abstraction. Such abstractions
729 are almost invariably 1-shot, so we want to pull the \s out, past the
730 let x=E, even if E is expensive. So we treat state-token lambdas as
731 one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
733 3. Dealing with bottom
736 f = \x -> error "foo"
737 Here, arity 1 is fine. But if it is
741 then we want to get arity 2. Tecnically, this isn't quite right, because
743 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
744 do so; it improves some programs significantly, and increasing convergence
745 isn't a bad thing. Hence the ABot/ATop in ArityType.
747 Actually, the situation is worse. Consider
751 Can we eta-expand here? At first the answer looks like "yes of course", but
754 This should diverge! But if we eta-expand, it won't. Again, we ignore this
755 "problem", because being scrupulous would lose an important transformation for
760 exprEtaExpandArity e = arityDepth (arityType e)
762 -- A limited sort of function type
763 data ArityType = AFun Bool ArityType -- True <=> one-shot
764 | ATop -- Know nothing
767 arityDepth :: ArityType -> Arity
768 arityDepth (AFun _ ty) = 1 + arityDepth ty
771 andArityType ABot at2 = at2
772 andArityType ATop at2 = ATop
773 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
774 andArityType at1 at2 = andArityType at2 at1
776 arityType :: CoreExpr -> ArityType
777 -- (go1 e) = [b1,..,bn]
778 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
779 -- where bi is True <=> the lambda is one-shot
781 arityType (Note n e) = arityType e
782 -- Not needed any more: etaExpand is cleverer
783 -- | ok_note n = arityType e
784 -- | otherwise = ATop
787 = mk (idArity v) (arg_tys (idType v))
789 mk :: Arity -> [Type] -> ArityType
790 -- The argument types are only to steer the "state hack"
791 -- Consider case x of
793 -- False -> \(s:RealWorld) -> e
794 -- where foo has arity 1. Then we want the state hack to
795 -- apply to foo too, so we can eta expand the case.
796 mk 0 tys | isBottomingId v = ABot
798 mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
799 mk n [] = AFun False (mk (n-1) [])
801 arg_tys :: Type -> [Type] -- Ignore for-alls
803 | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
804 | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
807 -- Lambdas; increase arity
808 arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
809 | otherwise = arityType e
811 -- Applications; decrease arity
812 arityType (App f (Type _)) = arityType f
813 arityType (App f a) = case arityType f of
814 AFun one_shot xs | exprIsCheap a -> xs
817 -- Case/Let; keep arity if either the expression is cheap
818 -- or it's a 1-shot lambda
819 -- The former is not really right for Haskell
820 -- f x = case x of { (a,b) -> \y. e }
822 -- f x y = case x of { (a,b) -> e }
823 -- The difference is observable using 'seq'
824 arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
825 xs@(AFun one_shot _) | one_shot -> xs
826 xs | exprIsCheap scrut -> xs
829 arityType (Let b e) = case arityType e of
830 xs@(AFun one_shot _) | one_shot -> xs
831 xs | all exprIsCheap (rhssOfBind b) -> xs
834 arityType other = ATop
836 {- NOT NEEDED ANY MORE: etaExpand is cleverer
837 ok_note InlineMe = False
839 -- Notice that we do not look through __inline_me__
840 -- This may seem surprising, but consider
841 -- f = _inline_me (\x -> e)
842 -- We DO NOT want to eta expand this to
843 -- f = \x -> (_inline_me (\x -> e)) x
844 -- because the _inline_me gets dropped now it is applied,
853 etaExpand :: Arity -- Result should have this number of value args
855 -> CoreExpr -> Type -- Expression and its type
857 -- (etaExpand n us e ty) returns an expression with
858 -- the same meaning as 'e', but with arity 'n'.
860 -- Given e' = etaExpand n us e ty
862 -- ty = exprType e = exprType e'
864 -- Note that SCCs are not treated specially. If we have
865 -- etaExpand 2 (\x -> scc "foo" e)
866 -- = (\xy -> (scc "foo" e) y)
867 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
869 etaExpand n us expr ty
870 | manifestArity expr >= n = expr -- The no-op case
871 | otherwise = eta_expand n us expr ty
874 -- manifestArity sees how many leading value lambdas there are
875 manifestArity :: CoreExpr -> Arity
876 manifestArity (Lam v e) | isId v = 1 + manifestArity e
877 | otherwise = manifestArity e
878 manifestArity (Note _ e) = manifestArity e
881 -- etaExpand deals with for-alls. For example:
883 -- where E :: forall a. a -> a
885 -- (/\b. \y::a -> E b y)
887 -- It deals with coerces too, though they are now rare
888 -- so perhaps the extra code isn't worth it
890 eta_expand n us expr ty
892 -- The ILX code generator requires eta expansion for type arguments
893 -- too, but alas the 'n' doesn't tell us how many of them there
894 -- may be. So we eagerly eta expand any big lambdas, and just
895 -- cross our fingers about possible loss of sharing in the ILX case.
896 -- The Right Thing is probably to make 'arity' include
897 -- type variables throughout the compiler. (ToDo.)
899 -- Saturated, so nothing to do
902 -- Short cut for the case where there already
903 -- is a lambda; no point in gratuitously adding more
904 eta_expand n us (Lam v body) ty
906 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
909 = Lam v (eta_expand (n-1) us body (funResultTy ty))
911 -- We used to have a special case that stepped inside Coerces here,
912 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
913 -- = Note note (eta_expand n us e ty)
914 -- BUT this led to an infinite loop
915 -- Example: newtype T = MkT (Int -> Int)
916 -- eta_expand 1 (coerce (Int->Int) e)
917 -- --> coerce (Int->Int) (eta_expand 1 T e)
919 -- --> coerce (Int->Int) (coerce T
920 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
921 -- by the splitNewType_maybe case below
924 eta_expand n us expr ty
925 = case splitForAllTy_maybe ty of {
926 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
930 case splitFunTy_maybe ty of {
931 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
933 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
939 -- newtype T = MkT ([T] -> Int)
940 -- Consider eta-expanding this
943 -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
944 -- Only try this for recursive newtypes; the non-recursive kind
945 -- are transparent anyway
947 case splitRecNewType_maybe ty of {
948 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
949 Nothing -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
953 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
954 It tells how many things the expression can be applied to before doing
955 any work. It doesn't look inside cases, lets, etc. The idea is that
956 exprEtaExpandArity will do the hard work, leaving something that's easy
957 for exprArity to grapple with. In particular, Simplify uses exprArity to
958 compute the ArityInfo for the Id.
960 Originally I thought that it was enough just to look for top-level lambdas, but
961 it isn't. I've seen this
963 foo = PrelBase.timesInt
965 We want foo to get arity 2 even though the eta-expander will leave it
966 unchanged, in the expectation that it'll be inlined. But occasionally it
967 isn't, because foo is blacklisted (used in a rule).
969 Similarly, see the ok_note check in exprEtaExpandArity. So
970 f = __inline_me (\x -> e)
971 won't be eta-expanded.
973 And in any case it seems more robust to have exprArity be a bit more intelligent.
974 But note that (\x y z -> f x y z)
975 should have arity 3, regardless of f's arity.
978 exprArity :: CoreExpr -> Arity
981 go (Var v) = idArity v
982 go (Lam x e) | isId x = go e + 1
985 go (App e (Type t)) = go e
986 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
987 -- NB: exprIsCheap a!
988 -- f (fac x) does not have arity 2,
989 -- even if f has arity 3!
990 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
991 -- unknown, hence arity 0
995 %************************************************************************
997 \subsection{Equality}
999 %************************************************************************
1001 @cheapEqExpr@ is a cheap equality test which bales out fast!
1002 True => definitely equal
1003 False => may or may not be equal
1006 cheapEqExpr :: Expr b -> Expr b -> Bool
1008 cheapEqExpr (Var v1) (Var v2) = v1==v2
1009 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1010 cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
1012 cheapEqExpr (App f1 a1) (App f2 a2)
1013 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1015 cheapEqExpr _ _ = False
1017 exprIsBig :: Expr b -> Bool
1018 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1019 exprIsBig (Lit _) = False
1020 exprIsBig (Var v) = False
1021 exprIsBig (Type t) = False
1022 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1023 exprIsBig other = True
1028 tcEqExpr :: CoreExpr -> CoreExpr -> Bool
1029 -- Used in rule matching, so does *not* look through
1030 -- newtypes, predicate types; hence tcEqExpr
1032 tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
1034 rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
1036 tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
1037 tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
1038 tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2
1039 tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
1040 tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
1041 tcEqExprX env (Let (NonRec v1 r1) e1)
1042 (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
1043 && tcEqExprX (rnBndr2 env v1 v2) e1 e2
1044 tcEqExprX env (Let (Rec ps1) e1)
1045 (Let (Rec ps2) e2) = equalLength ps1 ps2
1046 && and (zipWith eq_rhs ps1 ps2)
1047 && tcEqExprX env' e1 e2
1049 env' = foldl2 rn_bndr2 env ps2 ps2
1050 rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
1051 eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
1052 tcEqExprX env (Case e1 v1 t1 a1)
1053 (Case e2 v2 t2 a2) = tcEqExprX env e1 e2
1054 && tcEqTypeX env t1 t2
1055 && equalLength a1 a2
1056 && and (zipWith (eq_alt env') a1 a2)
1058 env' = rnBndr2 env v1 v2
1060 tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
1061 tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
1062 tcEqExprX env e1 e2 = False
1064 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
1066 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1067 eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2
1068 eq_note env InlineCall InlineCall = True
1069 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1070 eq_note env other1 other2 = False
1074 %************************************************************************
1076 \subsection{The size of an expression}
1078 %************************************************************************
1081 coreBindsSize :: [CoreBind] -> Int
1082 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1084 exprSize :: CoreExpr -> Int
1085 -- A measure of the size of the expressions
1086 -- It also forces the expression pretty drastically as a side effect
1087 exprSize (Var v) = v `seq` 1
1088 exprSize (Lit lit) = lit `seq` 1
1089 exprSize (App f a) = exprSize f + exprSize a
1090 exprSize (Lam b e) = varSize b + exprSize e
1091 exprSize (Let b e) = bindSize b + exprSize e
1092 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1093 exprSize (Note n e) = noteSize n + exprSize e
1094 exprSize (Type t) = seqType t `seq` 1
1096 noteSize (SCC cc) = cc `seq` 1
1097 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1098 noteSize InlineCall = 1
1099 noteSize InlineMe = 1
1100 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1102 varSize :: Var -> Int
1103 varSize b | isTyVar b = 1
1104 | otherwise = seqType (idType b) `seq`
1105 megaSeqIdInfo (idInfo b) `seq`
1108 varsSize = foldr ((+) . varSize) 0
1110 bindSize (NonRec b e) = varSize b + exprSize e
1111 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1113 pairSize (b,e) = varSize b + exprSize e
1115 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1119 %************************************************************************
1121 \subsection{Hashing}
1123 %************************************************************************
1126 hashExpr :: CoreExpr -> Int
1127 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1130 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1132 hash_expr (Note _ e) = hash_expr e
1133 hash_expr (Let (NonRec b r) e) = hashId b
1134 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 :: HomeModules -> 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
1184 -- ("DLL" here really only refers to Windows DLLs, on other platforms,
1185 -- this is not necessary)
1187 -- (ii) We treat partial applications as redexes, because in fact we
1188 -- make a thunk for them that runs and builds a PAP
1189 -- at run-time. The only appliations that are treated as
1190 -- static are *saturated* applications of constructors.
1192 -- We used to try to be clever with nested structures like this:
1193 -- ys = (:) w ((:) w [])
1194 -- on the grounds that CorePrep will flatten ANF-ise it later.
1195 -- But supporting this special case made the function much more
1196 -- complicated, because the special case only applies if there are no
1197 -- enclosing type lambdas:
1198 -- ys = /\ a -> Foo (Baz ([] a))
1199 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1201 -- But in fact, even without -O, nested structures at top level are
1202 -- flattened by the simplifier, so we don't need to be super-clever here.
1206 -- f = \x::Int. x+7 TRUE
1207 -- p = (True,False) TRUE
1209 -- d = (fst p, False) FALSE because there's a redex inside
1210 -- (this particular one doesn't happen but...)
1212 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1213 -- n = /\a. Nil a TRUE
1215 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1218 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
1219 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1221 -- b) (C x xs), where C is a contructors is updatable if the application is
1224 -- c) don't look through unfolding of f in (f x).
1226 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1227 -- them as making the RHS re-entrant (non-updatable).
1229 rhsIsStatic hmods rhs = is_static False rhs
1231 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1234 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1236 is_static in_arg (Note (SCC _) e) = False
1237 is_static in_arg (Note _ e) = is_static in_arg e
1239 is_static in_arg (Lit lit)
1241 MachLabel _ _ -> False
1243 -- A MachLabel (foreign import "&foo") in an argument
1244 -- prevents a constructor application from being static. The
1245 -- reason is that it might give rise to unresolvable symbols
1246 -- in the object file: under Linux, references to "weak"
1247 -- symbols from the data segment give rise to "unresolvable
1248 -- relocation" errors at link time This might be due to a bug
1249 -- in the linker, but we'll work around it here anyway.
1252 is_static in_arg other_expr = go other_expr 0
1254 go (Var f) n_val_args
1255 #if mingw32_TARGET_OS
1256 | not (isDllName hmods (idName f))
1258 = saturated_data_con f n_val_args
1259 || (in_arg && n_val_args == 0)
1260 -- A naked un-applied variable is *not* deemed a static RHS
1262 -- Reason: better to update so that the indirection gets shorted
1263 -- out, and the true value will be seen
1264 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1265 -- are always updatable. If you do so, make sure that non-updatable
1266 -- ones have enough space for their static link field!
1268 go (App f a) n_val_args
1269 | isTypeArg a = go f n_val_args
1270 | not in_arg && is_static True a = go f (n_val_args + 1)
1271 -- The (not in_arg) checks that we aren't in a constructor argument;
1272 -- if we are, we don't allow (value) applications of any sort
1274 -- NB. In case you wonder, args are sometimes not atomic. eg.
1275 -- x = D# (1.0## /## 2.0##)
1276 -- can't float because /## can fail.
1278 go (Note (SCC _) f) n_val_args = False
1279 go (Note _ f) n_val_args = go f n_val_args
1281 go other n_val_args = False
1283 saturated_data_con f n_val_args
1284 = case isDataConWorkId_maybe f of
1285 Just dc -> n_val_args == dataConRepArity dc