2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
10 bindNonRec, needsCaseBinding,
11 mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
13 -- Taking expressions apart
14 findDefault, findAlt, hasDefault,
16 -- Properties of expressions
17 exprType, coreAltsType,
18 exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
19 exprIsValue,exprOkForSpeculation, exprIsBig,
23 -- Arity and eta expansion
24 manifestArity, exprArity,
25 exprEtaExpandArity, etaExpand,
34 cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
37 #include "HsVersions.h"
40 import GLAEXTS -- For `xori`
43 import PprCore ( pprCoreExpr )
44 import Var ( Var, isId, isTyVar )
46 import Name ( hashName, isDllName )
47 import Literal ( hashLiteral, literalType, litIsDupable,
48 litIsTrivial, isZeroLit, isLitLitLit )
49 import DataCon ( DataCon, dataConRepArity, dataConArgTys,
50 isExistentialDataCon, dataConTyCon, dataConName )
51 import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
52 import Id ( Id, idType, globalIdDetails, idNewStrictness,
53 mkWildId, idArity, idName, idUnfolding, idInfo,
54 isOneShotLambda, isDataConWorkId_maybe, mkSysLocal,
55 isDataConWorkId, isBottomingId
57 import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
58 import NewDemand ( appIsBottom )
59 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
61 applyTys, isUnLiftedType, seqType, mkTyVarTy,
62 splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
63 splitTyConApp_maybe, eqType, funResultTy, applyTy,
66 import TyCon ( tyConArity )
67 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
68 import CostCentre ( CostCentre )
69 import BasicTypes ( Arity )
70 import Unique ( Unique )
72 import TysPrim ( alphaTy ) -- Debugging only
73 import Util ( equalLength, lengthAtLeast )
74 import TysPrim ( statePrimTyCon )
78 %************************************************************************
80 \subsection{Find the type of a Core atom/expression}
82 %************************************************************************
85 exprType :: CoreExpr -> Type
87 exprType (Var var) = idType var
88 exprType (Lit lit) = literalType lit
89 exprType (Let _ body) = exprType body
90 exprType (Case _ _ alts) = coreAltsType alts
91 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
92 exprType (Note other_note e) = exprType e
93 exprType (Lam binder expr) = mkPiType binder (exprType expr)
95 = case collectArgs e of
96 (fun, args) -> applyTypeToArgs e (exprType fun) args
98 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
100 coreAltsType :: [CoreAlt] -> Type
101 coreAltsType ((_,_,rhs) : _) = exprType rhs
104 @mkPiType@ makes a (->) type or a forall type, depending on whether
105 it is given a type variable or a term variable. We cleverly use the
106 lbvarinfo field to figure out the right annotation for the arrove in
107 case of a term variable.
110 mkPiType :: Var -> Type -> Type -- The more polymorphic version
111 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
113 mkPiTypes vs ty = foldr mkPiType ty vs
116 | isId v = mkFunTy (idType v) ty
117 | otherwise = mkForAllTy v ty
121 applyTypeToArg :: Type -> CoreExpr -> Type
122 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
123 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
125 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
126 -- A more efficient version of applyTypeToArg
127 -- when we have several args
128 -- The first argument is just for debugging
129 applyTypeToArgs e op_ty [] = op_ty
131 applyTypeToArgs e op_ty (Type ty : args)
132 = -- Accumulate type arguments so we can instantiate all at once
135 go rev_tys (Type ty : args) = go (ty:rev_tys) args
136 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
138 op_ty' = applyTys op_ty (reverse rev_tys)
140 applyTypeToArgs e op_ty (other_arg : args)
141 = case (splitFunTy_maybe op_ty) of
142 Just (_, res_ty) -> applyTypeToArgs e res_ty args
143 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
148 %************************************************************************
150 \subsection{Attaching notes}
152 %************************************************************************
154 mkNote removes redundant coercions, and SCCs where possible
157 mkNote :: Note -> CoreExpr -> CoreExpr
158 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
159 mkNote (SCC cc) expr = mkSCC cc expr
160 mkNote InlineMe expr = mkInlineMe expr
161 mkNote note expr = Note note expr
163 -- Slide InlineCall in around the function
164 -- No longer necessary I think (SLPJ Apr 99)
165 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
166 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
167 -- mkNote InlineCall expr = expr
170 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
171 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
172 not be *applied* to anything.
174 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
177 f = inline_me (coerce t fw)
178 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
179 We want the split, so that the coerces can cancel at the call site.
181 However, we can get left with tiresome type applications. Notably, consider
182 f = /\ a -> let t = e in (t, w)
183 Then lifting the let out of the big lambda gives
185 f = /\ a -> let t = inline_me (t' a) in (t, w)
186 The inline_me is to stop the simplifier inlining t' right back
187 into t's RHS. In the next phase we'll substitute for t (since
188 its rhs is trivial) and *then* we could get rid of the inline_me.
189 But it hardly seems worth it, so I don't bother.
192 mkInlineMe (Var v) = Var v
193 mkInlineMe e = Note InlineMe e
199 mkCoerce :: Type -> CoreExpr -> CoreExpr
200 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
202 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
203 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
204 = ASSERT( from_ty `eqType` to_ty2 )
205 mkCoerce2 to_ty from_ty2 expr
207 mkCoerce2 to_ty from_ty expr
208 | to_ty `eqType` from_ty = expr
209 | otherwise = ASSERT( from_ty `eqType` exprType expr )
210 Note (Coerce to_ty from_ty) expr
214 mkSCC :: CostCentre -> Expr b -> Expr b
215 -- Note: Nested SCC's *are* preserved for the benefit of
216 -- cost centre stack profiling
217 mkSCC cc (Lit lit) = Lit lit
218 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
219 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
220 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
221 mkSCC cc expr = Note (SCC cc) expr
225 %************************************************************************
227 \subsection{Other expression construction}
229 %************************************************************************
232 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
233 -- (bindNonRec x r b) produces either
236 -- case r of x { _DEFAULT_ -> b }
238 -- depending on whether x is unlifted or not
239 -- It's used by the desugarer to avoid building bindings
240 -- that give Core Lint a heart attack. Actually the simplifier
241 -- deals with them perfectly well.
242 bindNonRec bndr rhs body
243 | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
244 | otherwise = Let (NonRec bndr rhs) body
246 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
247 -- Make a case expression instead of a let
248 -- These can arise either from the desugarer,
249 -- or from beta reductions: (\x.e) (x +# y)
253 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
254 -- This guy constructs the value that the scrutinee must have
255 -- when you are in one particular branch of a case
256 mkAltExpr (DataAlt con) args inst_tys
257 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
258 mkAltExpr (LitAlt lit) [] []
261 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
262 mkIfThenElse guard then_expr else_expr
263 = Case guard (mkWildId boolTy)
264 [ (DataAlt trueDataCon, [], then_expr),
265 (DataAlt falseDataCon, [], else_expr) ]
269 %************************************************************************
271 \subsection{Taking expressions apart}
273 %************************************************************************
275 The default alternative must be first, if it exists at all.
276 This makes it easy to find, though it makes matching marginally harder.
279 hasDefault :: [CoreAlt] -> Bool
280 hasDefault ((DEFAULT,_,_) : alts) = True
283 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
284 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
285 findDefault alts = (alts, Nothing)
287 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
290 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
291 other -> go alts panic_deflt
294 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
297 go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
298 | otherwise = ASSERT( not (con1 == DEFAULT) )
303 %************************************************************************
305 \subsection{Figuring out things about expressions}
307 %************************************************************************
309 @exprIsTrivial@ is true of expressions we are unconditionally happy to
310 duplicate; simple variables and constants, and type
311 applications. Note that primop Ids aren't considered
314 @exprIsBottom@ is true of expressions that are guaranteed to diverge
317 There used to be a gruesome test for (hasNoBinding v) in the
319 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
320 The idea here is that a constructor worker, like $wJust, is
321 really short for (\x -> $wJust x), becuase $wJust has no binding.
322 So it should be treated like a lambda. Ditto unsaturated primops.
323 But now constructor workers are not "have-no-binding" Ids. And
324 completely un-applied primops and foreign-call Ids are sufficiently
325 rare that I plan to allow them to be duplicated and put up with
328 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
329 a) it really generates code, (and a heap object when it's
330 a function arg) to capture the cost centre
331 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
334 exprIsTrivial (Var v) = True -- See notes above
335 exprIsTrivial (Type _) = True
336 exprIsTrivial (Lit lit) = litIsTrivial lit
337 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
338 exprIsTrivial (Note (SCC _) e) = False -- See notes above
339 exprIsTrivial (Note _ e) = exprIsTrivial e
340 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
341 exprIsTrivial other = False
345 @exprIsDupable@ is true of expressions that can be duplicated at a modest
346 cost in code size. This will only happen in different case
347 branches, so there's no issue about duplicating work.
349 That is, exprIsDupable returns True of (f x) even if
350 f is very very expensive to call.
352 Its only purpose is to avoid fruitless let-binding
353 and then inlining of case join points
357 exprIsDupable (Type _) = True
358 exprIsDupable (Var v) = True
359 exprIsDupable (Lit lit) = litIsDupable lit
360 exprIsDupable (Note InlineMe e) = True
361 exprIsDupable (Note _ e) = exprIsDupable e
365 go (Var v) n_args = True
366 go (App f a) n_args = n_args < dupAppSize
369 go other n_args = False
372 dupAppSize = 4 -- Size of application we are prepared to duplicate
375 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
376 it is obviously in weak head normal form, or is cheap to get to WHNF.
377 [Note that that's not the same as exprIsDupable; an expression might be
378 big, and hence not dupable, but still cheap.]
380 By ``cheap'' we mean a computation we're willing to:
381 push inside a lambda, or
382 inline at more than one place
383 That might mean it gets evaluated more than once, instead of being
384 shared. The main examples of things which aren't WHNF but are
389 (where e, and all the ei are cheap)
392 (where e and b are cheap)
395 (where op is a cheap primitive operator)
398 (because we are happy to substitute it inside a lambda)
400 Notice that a variable is considered 'cheap': we can push it inside a lambda,
401 because sharing will make sure it is only evaluated once.
404 exprIsCheap :: CoreExpr -> Bool
405 exprIsCheap (Lit lit) = True
406 exprIsCheap (Type _) = True
407 exprIsCheap (Var _) = True
408 exprIsCheap (Note InlineMe e) = True
409 exprIsCheap (Note _ e) = exprIsCheap e
410 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
411 exprIsCheap (Case e _ alts) = exprIsCheap e &&
412 and [exprIsCheap rhs | (_,_,rhs) <- alts]
413 -- Experimentally, treat (case x of ...) as cheap
414 -- (and case __coerce x etc.)
415 -- This improves arities of overloaded functions where
416 -- there is only dictionary selection (no construction) involved
417 exprIsCheap (Let (NonRec x _) e)
418 | isUnLiftedType (idType x) = exprIsCheap e
420 -- strict lets always have cheap right hand sides, and
423 exprIsCheap other_expr
424 = go other_expr 0 True
426 go (Var f) n_args args_cheap
427 = (idAppIsCheap f n_args && args_cheap)
428 -- A constructor, cheap primop, or partial application
430 || idAppIsBottom f n_args
431 -- Application of a function which
432 -- always gives bottom; we treat this as cheap
433 -- because it certainly doesn't need to be shared!
435 go (App f a) n_args args_cheap
436 | not (isRuntimeArg a) = go f n_args args_cheap
437 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
439 go other n_args args_cheap = False
441 idAppIsCheap :: Id -> Int -> Bool
442 idAppIsCheap id n_val_args
443 | n_val_args == 0 = True -- Just a type application of
444 -- a variable (f t1 t2 t3)
446 | otherwise = case globalIdDetails id of
447 DataConWorkId _ -> True
448 RecordSelId _ -> True -- I'm experimenting with making record selection
449 ClassOpId _ -> True -- look cheap, so we will substitute it inside a
450 -- lambda. Particularly for dictionary field selection
452 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
453 -- that return a type variable, since the result
454 -- might be applied to something, but I'm not going
455 -- to bother to check the number of args
456 other -> n_val_args < idArity id
459 exprOkForSpeculation returns True of an expression that it is
461 * safe to evaluate even if normal order eval might not
462 evaluate the expression at all, or
464 * safe *not* to evaluate even if normal order would do so
468 the expression guarantees to terminate,
470 without raising an exception,
471 without causing a side effect (e.g. writing a mutable variable)
474 let x = case y# +# 1# of { r# -> I# r# }
477 case y# +# 1# of { r# ->
482 We can only do this if the (y+1) is ok for speculation: it has no
483 side effects, and can't diverge or raise an exception.
486 exprOkForSpeculation :: CoreExpr -> Bool
487 exprOkForSpeculation (Lit _) = True
488 exprOkForSpeculation (Type _) = True
489 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
490 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
491 exprOkForSpeculation other_expr
492 = case collectArgs other_expr of
493 (Var f, args) -> spec_ok (globalIdDetails f) args
497 spec_ok (DataConWorkId _) args
498 = True -- The strictness of the constructor has already
499 -- been expressed by its "wrapper", so we don't need
500 -- to take the arguments into account
502 spec_ok (PrimOpId op) args
503 | isDivOp op, -- Special case for dividing operations that fail
504 [arg1, Lit lit] <- args -- only if the divisor is zero
505 = not (isZeroLit lit) && exprOkForSpeculation arg1
506 -- Often there is a literal divisor, and this
507 -- can get rid of a thunk in an inner looop
510 = primOpOkForSpeculation op &&
511 all exprOkForSpeculation args
512 -- A bit conservative: we don't really need
513 -- to care about lazy arguments, but this is easy
515 spec_ok other args = False
517 isDivOp :: PrimOp -> Bool
518 -- True of dyadic operators that can fail
519 -- only if the second arg is zero
520 -- This function probably belongs in PrimOp, or even in
521 -- an automagically generated file.. but it's such a
522 -- special case I thought I'd leave it here for now.
523 isDivOp IntQuotOp = True
524 isDivOp IntRemOp = True
525 isDivOp WordQuotOp = True
526 isDivOp WordRemOp = True
527 isDivOp IntegerQuotRemOp = True
528 isDivOp IntegerDivModOp = True
529 isDivOp FloatDivOp = True
530 isDivOp DoubleDivOp = True
531 isDivOp other = False
536 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
537 exprIsBottom e = go 0 e
539 -- n is the number of args
540 go n (Note _ e) = go n e
541 go n (Let _ e) = go n e
542 go n (Case e _ _) = go 0 e -- Just check the scrut
543 go n (App e _) = go (n+1) e
544 go n (Var v) = idAppIsBottom v n
546 go n (Lam _ _) = False
548 idAppIsBottom :: Id -> Int -> Bool
549 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
552 @exprIsValue@ returns true for expressions that are certainly *already*
553 evaluated to *head* normal form. This is used to decide whether it's ok
556 case x of _ -> e ===> e
558 and to decide whether it's safe to discard a `seq`
560 So, it does *not* treat variables as evaluated, unless they say they are.
562 But it *does* treat partial applications and constructor applications
563 as values, even if their arguments are non-trivial, provided the argument
565 e.g. (:) (f x) (map f xs) is a value
566 map (...redex...) is a value
567 Because `seq` on such things completes immediately
569 For unlifted argument types, we have to be careful:
571 Suppose (f x) diverges; then C (f x) is not a value. True, but
572 this form is illegal (see the invariants in CoreSyn). Args of unboxed
573 type must be ok-for-speculation (or trivial).
576 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
577 exprIsValue (Var v) -- NB: There are no value args at this point
578 = isDataConWorkId v -- Catches nullary constructors,
579 -- so that [] and () are values, for example
580 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
581 || isEvaldUnfolding (idUnfolding v)
582 -- Check the thing's unfolding; it might be bound to a value
583 -- A worry: what if an Id's unfolding is just itself:
584 -- then we could get an infinite loop...
586 exprIsValue (Lit l) = True
587 exprIsValue (Type ty) = True -- Types are honorary Values;
588 -- we don't mind copying them
589 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
590 exprIsValue (Note _ e) = exprIsValue e
591 exprIsValue (App e (Type _)) = exprIsValue e
592 exprIsValue (App e a) = app_is_value e [a]
593 exprIsValue other = False
595 -- There is at least one value argument
596 app_is_value (Var fun) args
597 | isDataConWorkId fun -- Constructor apps are values
598 || idArity fun > valArgCount args -- Under-applied function
599 = check_args (idType fun) args
600 app_is_value (App f a) as = app_is_value f (a:as)
601 app_is_value other as = False
603 -- 'check_args' checks that unlifted-type args
604 -- are in fact guaranteed non-divergent
605 check_args fun_ty [] = True
606 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
607 Just (_, ty) -> check_args ty args
608 check_args fun_ty (arg : args)
609 | isUnLiftedType arg_ty = exprOkForSpeculation arg
610 | otherwise = check_args res_ty args
612 (arg_ty, res_ty) = splitFunTy fun_ty
616 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
617 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
618 = -- Maybe this is over the top, but here we try to turn
619 -- coerce (S,T) ( x, y )
621 -- ( coerce S x, coerce T y )
622 -- This happens in anger in PrelArrExts which has a coerce
623 -- case coerce memcpy a b of
625 -- where the memcpy is in the IO monad, but the call is in
627 case exprIsConApp_maybe expr of {
631 case splitTyConApp_maybe to_ty of {
633 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
634 | isExistentialDataCon dc -> Nothing
636 -- Type constructor must match
637 -- We knock out existentials to keep matters simple(r)
639 arity = tyConArity tc
640 val_args = drop arity args
641 to_arg_tys = dataConArgTys dc tc_arg_tys
642 mk_coerce ty arg = mkCoerce ty arg
643 new_val_args = zipWith mk_coerce to_arg_tys val_args
645 ASSERT( all isTypeArg (take arity args) )
646 ASSERT( equalLength val_args to_arg_tys )
647 Just (dc, map Type tc_arg_tys ++ new_val_args)
650 exprIsConApp_maybe (Note _ expr)
651 = exprIsConApp_maybe expr
652 -- We ignore InlineMe notes in case we have
653 -- x = __inline_me__ (a,b)
654 -- All part of making sure that INLINE pragmas never hurt
655 -- Marcin tripped on this one when making dictionaries more inlinable
657 -- In fact, we ignore all notes. For example,
658 -- case _scc_ "foo" (C a b) of
660 -- should be optimised away, but it will be only if we look
661 -- through the SCC note.
663 exprIsConApp_maybe expr = analyse (collectArgs expr)
665 analyse (Var fun, args)
666 | Just con <- isDataConWorkId_maybe fun,
667 args `lengthAtLeast` dataConRepArity con
668 -- Might be > because the arity excludes type args
671 -- Look through unfoldings, but only cheap ones, because
672 -- we are effectively duplicating the unfolding
673 analyse (Var fun, [])
674 | let unf = idUnfolding fun,
676 = exprIsConApp_maybe (unfoldingTemplate unf)
678 analyse other = Nothing
683 %************************************************************************
685 \subsection{Eta reduction and expansion}
687 %************************************************************************
690 exprEtaExpandArity :: CoreExpr -> Arity
691 {- The Arity returned is the number of value args the
692 thing can be applied to without doing much work
694 exprEtaExpandArity is used when eta expanding
697 It returns 1 (or more) to:
698 case x of p -> \s -> ...
699 because for I/O ish things we really want to get that \s to the top.
700 We are prepared to evaluate x each time round the loop in order to get that
702 It's all a bit more subtle than it looks:
706 Consider one-shot lambdas
707 let x = expensive in \y z -> E
708 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
709 Hence the ArityType returned by arityType
711 2. The state-transformer hack
713 The one-shot lambda special cause is particularly important/useful for
714 IO state transformers, where we often get
715 let x = E in \ s -> ...
717 and the \s is a real-world state token abstraction. Such abstractions
718 are almost invariably 1-shot, so we want to pull the \s out, past the
719 let x=E, even if E is expensive. So we treat state-token lambdas as
720 one-shot even if they aren't really. The hack is in Id.isOneShotLambda.
722 3. Dealing with bottom
725 f = \x -> error "foo"
726 Here, arity 1 is fine. But if it is
730 then we want to get arity 2. Tecnically, this isn't quite right, because
732 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
733 do so; it improves some programs significantly, and increasing convergence
734 isn't a bad thing. Hence the ABot/ATop in ArityType.
736 Actually, the situation is worse. Consider
740 Can we eta-expand here? At first the answer looks like "yes of course", but
743 This should diverge! But if we eta-expand, it won't. Again, we ignore this
744 "problem", because being scrupulous would lose an important transformation for
749 exprEtaExpandArity e = arityDepth (arityType e)
751 -- A limited sort of function type
752 data ArityType = AFun Bool ArityType -- True <=> one-shot
753 | ATop -- Know nothing
756 arityDepth :: ArityType -> Arity
757 arityDepth (AFun _ ty) = 1 + arityDepth ty
760 andArityType ABot at2 = at2
761 andArityType ATop at2 = ATop
762 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
763 andArityType at1 at2 = andArityType at2 at1
765 arityType :: CoreExpr -> ArityType
766 -- (go1 e) = [b1,..,bn]
767 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
768 -- where bi is True <=> the lambda is one-shot
770 arityType (Note n e) = arityType e
771 -- Not needed any more: etaExpand is cleverer
772 -- | ok_note n = arityType e
773 -- | otherwise = ATop
778 mk :: Arity -> ArityType
779 mk 0 | isBottomingId v = ABot
781 mk n = AFun False (mk (n-1))
783 -- When the type of the Id encodes one-shot-ness,
784 -- use the idinfo here
786 -- Lambdas; increase arity
787 arityType (Lam x e) | isId x = AFun (isOneShotLambda x || isStateHack x) (arityType e)
788 | otherwise = arityType e
790 -- Applications; decrease arity
791 arityType (App f (Type _)) = arityType f
792 arityType (App f a) = case arityType f of
793 AFun one_shot xs | exprIsCheap a -> xs
796 -- Case/Let; keep arity if either the expression is cheap
797 -- or it's a 1-shot lambda
798 arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
799 xs@(AFun one_shot _) | one_shot -> xs
800 xs | exprIsCheap scrut -> xs
803 arityType (Let b e) = case arityType e of
804 xs@(AFun one_shot _) | one_shot -> xs
805 xs | all exprIsCheap (rhssOfBind b) -> xs
808 arityType other = ATop
810 isStateHack id = case splitTyConApp_maybe (idType id) of
811 Just (tycon,_) | tycon == statePrimTyCon -> True
814 -- The last clause is a gross hack. It claims that
815 -- every function over realWorldStatePrimTy is a one-shot
816 -- function. This is pretty true in practice, and makes a big
817 -- difference. For example, consider
818 -- a `thenST` \ r -> ...E...
819 -- The early full laziness pass, if it doesn't know that r is one-shot
820 -- will pull out E (let's say it doesn't mention r) to give
821 -- let lvl = E in a `thenST` \ r -> ...lvl...
822 -- When `thenST` gets inlined, we end up with
823 -- let lvl = E in \s -> case a s of (r, s') -> ...lvl...
824 -- and we don't re-inline E.
826 -- It would be better to spot that r was one-shot to start with, but
827 -- I don't want to rely on that.
829 -- Another good example is in fill_in in PrelPack.lhs. We should be able to
830 -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
832 {- NOT NEEDED ANY MORE: etaExpand is cleverer
833 ok_note InlineMe = False
835 -- Notice that we do not look through __inline_me__
836 -- This may seem surprising, but consider
837 -- f = _inline_me (\x -> e)
838 -- We DO NOT want to eta expand this to
839 -- f = \x -> (_inline_me (\x -> e)) x
840 -- because the _inline_me gets dropped now it is applied,
849 etaExpand :: Arity -- Result should have this number of value args
851 -> CoreExpr -> Type -- Expression and its type
853 -- (etaExpand n us e ty) returns an expression with
854 -- the same meaning as 'e', but with arity 'n'.
856 -- Given e' = etaExpand n us e ty
858 -- ty = exprType e = exprType e'
860 -- Note that SCCs are not treated specially. If we have
861 -- etaExpand 2 (\x -> scc "foo" e)
862 -- = (\xy -> (scc "foo" e) y)
863 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
865 etaExpand n us expr ty
866 | manifestArity expr >= n = expr -- The no-op case
867 | otherwise = eta_expand n us expr ty
870 -- manifestArity sees how many leading value lambdas there are
871 manifestArity :: CoreExpr -> Arity
872 manifestArity (Lam v e) | isId v = 1 + manifestArity e
873 | otherwise = manifestArity e
874 manifestArity (Note _ e) = manifestArity e
877 -- etaExpand deals with for-alls. For example:
879 -- where E :: forall a. a -> a
881 -- (/\b. \y::a -> E b y)
883 -- It deals with coerces too, though they are now rare
884 -- so perhaps the extra code isn't worth it
886 eta_expand n us expr ty
888 -- The ILX code generator requires eta expansion for type arguments
889 -- too, but alas the 'n' doesn't tell us how many of them there
890 -- may be. So we eagerly eta expand any big lambdas, and just
891 -- cross our fingers about possible loss of sharing in the ILX case.
892 -- The Right Thing is probably to make 'arity' include
893 -- type variables throughout the compiler. (ToDo.)
895 -- Saturated, so nothing to do
898 -- Short cut for the case where there already
899 -- is a lambda; no point in gratuitously adding more
900 eta_expand n us (Lam v body) ty
902 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
905 = Lam v (eta_expand (n-1) us body (funResultTy ty))
907 -- We used to have a special case that stepped inside Coerces here,
908 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
909 -- = Note note (eta_expand n us e ty)
910 -- BUT this led to an infinite loop
911 -- Example: newtype T = MkT (Int -> Int)
912 -- eta_expand 1 (coerce (Int->Int) e)
913 -- --> coerce (Int->Int) (eta_expand 1 T e)
915 -- --> coerce (Int->Int) (coerce T
916 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
917 -- by the splitNewType_maybe case below
920 eta_expand n us expr ty
921 = case splitForAllTy_maybe ty of {
922 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
926 case splitFunTy_maybe ty of {
927 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
929 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
935 -- newtype T = MkT (Int -> Int)
936 -- Consider eta-expanding this
939 -- coerce T (\x::Int -> (coerce (Int->Int) e) x)
941 case splitNewType_maybe ty of {
942 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
943 Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
947 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
948 It tells how many things the expression can be applied to before doing
949 any work. It doesn't look inside cases, lets, etc. The idea is that
950 exprEtaExpandArity will do the hard work, leaving something that's easy
951 for exprArity to grapple with. In particular, Simplify uses exprArity to
952 compute the ArityInfo for the Id.
954 Originally I thought that it was enough just to look for top-level lambdas, but
955 it isn't. I've seen this
957 foo = PrelBase.timesInt
959 We want foo to get arity 2 even though the eta-expander will leave it
960 unchanged, in the expectation that it'll be inlined. But occasionally it
961 isn't, because foo is blacklisted (used in a rule).
963 Similarly, see the ok_note check in exprEtaExpandArity. So
964 f = __inline_me (\x -> e)
965 won't be eta-expanded.
967 And in any case it seems more robust to have exprArity be a bit more intelligent.
968 But note that (\x y z -> f x y z)
969 should have arity 3, regardless of f's arity.
972 exprArity :: CoreExpr -> Arity
975 go (Var v) = idArity v
976 go (Lam x e) | isId x = go e + 1
979 go (App e (Type t)) = go e
980 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
981 -- NB: exprIsCheap a!
982 -- f (fac x) does not have arity 2,
983 -- even if f has arity 3!
984 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
985 -- unknown, hence arity 0
989 %************************************************************************
991 \subsection{Equality}
993 %************************************************************************
995 @cheapEqExpr@ is a cheap equality test which bales out fast!
996 True => definitely equal
997 False => may or may not be equal
1000 cheapEqExpr :: Expr b -> Expr b -> Bool
1002 cheapEqExpr (Var v1) (Var v2) = v1==v2
1003 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1004 cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
1006 cheapEqExpr (App f1 a1) (App f2 a2)
1007 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1009 cheapEqExpr _ _ = False
1011 exprIsBig :: Expr b -> Bool
1012 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1013 exprIsBig (Lit _) = False
1014 exprIsBig (Var v) = False
1015 exprIsBig (Type t) = False
1016 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1017 exprIsBig other = True
1022 eqExpr :: CoreExpr -> CoreExpr -> Bool
1023 -- Works ok at more general type, but only needed at CoreExpr
1024 -- Used in rule matching, so when we find a type we use
1025 -- eqTcType, which doesn't look through newtypes
1026 -- [And it doesn't risk falling into a black hole either.]
1028 = eq emptyVarEnv e1 e2
1030 -- The "env" maps variables in e1 to variables in ty2
1031 -- So when comparing lambdas etc,
1032 -- we in effect substitute v2 for v1 in e1 before continuing
1033 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
1034 Just v1' -> v1' == v2
1037 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
1038 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
1039 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
1040 eq env (Let (NonRec v1 r1) e1)
1041 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
1042 eq env (Let (Rec ps1) e1)
1043 (Let (Rec ps2) e2) = equalLength ps1 ps2 &&
1044 and (zipWith eq_rhs ps1 ps2) &&
1047 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
1048 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
1049 eq env (Case e1 v1 a1)
1050 (Case e2 v2 a2) = eq env e1 e2 &&
1051 equalLength a1 a2 &&
1052 and (zipWith (eq_alt env') a1 a2)
1054 env' = extendVarEnv env v1 v2
1056 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
1057 eq env (Type t1) (Type t2) = t1 `eqType` t2
1058 eq env e1 e2 = False
1060 eq_list env [] [] = True
1061 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
1062 eq_list env es1 es2 = False
1064 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
1065 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
1067 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1068 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
1069 eq_note env InlineCall InlineCall = True
1070 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1071 eq_note env other1 other2 = False
1075 %************************************************************************
1077 \subsection{The size of an expression}
1079 %************************************************************************
1082 coreBindsSize :: [CoreBind] -> Int
1083 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1085 exprSize :: CoreExpr -> Int
1086 -- A measure of the size of the expressions
1087 -- It also forces the expression pretty drastically as a side effect
1088 exprSize (Var v) = v `seq` 1
1089 exprSize (Lit lit) = lit `seq` 1
1090 exprSize (App f a) = exprSize f + exprSize a
1091 exprSize (Lam b e) = varSize b + exprSize e
1092 exprSize (Let b e) = bindSize b + exprSize e
1093 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
1094 exprSize (Note n e) = noteSize n + exprSize e
1095 exprSize (Type t) = seqType t `seq` 1
1097 noteSize (SCC cc) = cc `seq` 1
1098 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1099 noteSize InlineCall = 1
1100 noteSize InlineMe = 1
1101 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1103 varSize :: Var -> Int
1104 varSize b | isTyVar b = 1
1105 | otherwise = seqType (idType b) `seq`
1106 megaSeqIdInfo (idInfo b) `seq`
1109 varsSize = foldr ((+) . varSize) 0
1111 bindSize (NonRec b e) = varSize b + exprSize e
1112 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1114 pairSize (b,e) = varSize b + exprSize e
1116 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1120 %************************************************************************
1122 \subsection{Hashing}
1124 %************************************************************************
1127 hashExpr :: CoreExpr -> Int
1128 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1131 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1133 hash_expr (Note _ e) = hash_expr e
1134 hash_expr (Let (NonRec b r) e) = hashId b
1135 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1136 hash_expr (Case _ b _) = hashId b
1137 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1138 hash_expr (Var v) = hashId v
1139 hash_expr (Lit lit) = hashLiteral lit
1140 hash_expr (Lam b _) = hashId b
1141 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1143 fast_hash_expr (Var v) = hashId v
1144 fast_hash_expr (Lit lit) = hashLiteral lit
1145 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1146 fast_hash_expr (App f a) = fast_hash_expr a
1147 fast_hash_expr (Lam b _) = hashId b
1148 fast_hash_expr other = 1
1151 hashId id = hashName (idName id)
1154 %************************************************************************
1156 \subsection{Determining non-updatable right-hand-sides}
1158 %************************************************************************
1160 Top-level constructor applications can usually be allocated
1161 statically, but they can't if
1162 a) the constructor, or any of the arguments, come from another DLL
1163 b) any of the arguments are LitLits
1164 (because we can't refer to static labels in other DLLs).
1166 If this happens we simply make the RHS into an updatable thunk,
1167 and 'exectute' it rather than allocating it statically.
1170 rhsIsStatic :: CoreExpr -> Bool
1171 -- This function is called only on *top-level* right-hand sides
1172 -- Returns True if the RHS can be allocated statically, with
1173 -- no thunks involved at all.
1175 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1176 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1177 -- update flag on it.
1179 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1180 -- (a) a value lambda
1181 -- (b) a saturated constructor application with static args
1183 -- BUT watch out for
1184 -- (i) Any cross-DLL references kill static-ness completely
1185 -- because they must be 'executed' not statically allocated
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.exprIsValue, 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 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) = not (isLitLitLit lit)
1240 -- lit-lit arguments cannot be used in static constructors either.
1241 -- (litlits are deprecated, so I'm not going to bother cleaning up this infelicity --SDM).
1243 is_static in_arg other_expr = go other_expr 0
1245 go (Var f) n_val_args
1246 | not (isDllName (idName f))
1247 = saturated_data_con f n_val_args
1248 || (in_arg && n_val_args == 0)
1249 -- A naked un-applied variable is *not* deemed a static RHS
1251 -- Reason: better to update so that the indirection gets shorted
1252 -- out, and the true value will be seen
1253 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1254 -- are always updatable. If you do so, make sure that non-updatable
1255 -- ones have enough space for their static link field!
1257 go (App f a) n_val_args
1258 | isTypeArg a = go f n_val_args
1259 | not in_arg && is_static True a = go f (n_val_args + 1)
1260 -- The (not in_arg) checks that we aren't in a constructor argument;
1261 -- if we are, we don't allow (value) applications of any sort
1263 -- NB. In case you wonder, args are sometimes not atomic. eg.
1264 -- x = D# (1.0## /## 2.0##)
1265 -- can't float because /## can fail.
1267 go (Note (SCC _) f) n_val_args = False
1268 go (Note _ f) n_val_args = go f n_val_args
1270 go other n_val_args = False
1272 saturated_data_con f n_val_args
1273 = case isDataConWorkId_maybe f of
1274 Just dc -> n_val_args == dataConRepArity dc