2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
10 bindNonRec, needsCaseBinding,
11 mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
13 -- Taking expressions apart
16 -- Properties of expressions
17 exprType, coreAltType,
18 exprIsDupable, exprIsTrivial, exprIsCheap,
19 exprIsValue,exprOkForSpeculation, exprIsBig,
20 exprIsConApp_maybe, exprIsBottom,
23 -- Arity and eta expansion
24 manifestArity, exprArity,
25 exprEtaExpandArity, etaExpand,
34 cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg
37 #include "HsVersions.h"
40 import GLAEXTS -- For `xori`
43 import CoreFVs ( exprFreeVars )
44 import PprCore ( pprCoreExpr )
46 import VarSet ( unionVarSet )
48 import Name ( hashName )
49 import Packages ( isDllName, 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
306 %************************************************************************
308 \subsection{Figuring out things about expressions}
310 %************************************************************************
312 @exprIsTrivial@ is true of expressions we are unconditionally happy to
313 duplicate; simple variables and constants, and type
314 applications. Note that primop Ids aren't considered
317 @exprIsBottom@ is true of expressions that are guaranteed to diverge
320 There used to be a gruesome test for (hasNoBinding v) in the
322 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
323 The idea here is that a constructor worker, like $wJust, is
324 really short for (\x -> $wJust x), becuase $wJust has no binding.
325 So it should be treated like a lambda. Ditto unsaturated primops.
326 But now constructor workers are not "have-no-binding" Ids. And
327 completely un-applied primops and foreign-call Ids are sufficiently
328 rare that I plan to allow them to be duplicated and put up with
331 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
332 a) it really generates code, (and a heap object when it's
333 a function arg) to capture the cost centre
334 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
337 exprIsTrivial (Var v) = True -- See notes above
338 exprIsTrivial (Type _) = True
339 exprIsTrivial (Lit lit) = litIsTrivial lit
340 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
341 exprIsTrivial (Note (SCC _) e) = False -- See notes above
342 exprIsTrivial (Note _ e) = exprIsTrivial e
343 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
344 exprIsTrivial other = False
348 @exprIsDupable@ is true of expressions that can be duplicated at a modest
349 cost in code size. This will only happen in different case
350 branches, so there's no issue about duplicating work.
352 That is, exprIsDupable returns True of (f x) even if
353 f is very very expensive to call.
355 Its only purpose is to avoid fruitless let-binding
356 and then inlining of case join points
360 exprIsDupable (Type _) = True
361 exprIsDupable (Var v) = True
362 exprIsDupable (Lit lit) = litIsDupable lit
363 exprIsDupable (Note InlineMe e) = True
364 exprIsDupable (Note _ e) = exprIsDupable e
368 go (Var v) n_args = True
369 go (App f a) n_args = n_args < dupAppSize
372 go other n_args = False
375 dupAppSize = 4 -- Size of application we are prepared to duplicate
378 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
379 it is obviously in weak head normal form, or is cheap to get to WHNF.
380 [Note that that's not the same as exprIsDupable; an expression might be
381 big, and hence not dupable, but still cheap.]
383 By ``cheap'' we mean a computation we're willing to:
384 push inside a lambda, or
385 inline at more than one place
386 That might mean it gets evaluated more than once, instead of being
387 shared. The main examples of things which aren't WHNF but are
392 (where e, and all the ei are cheap)
395 (where e and b are cheap)
398 (where op is a cheap primitive operator)
401 (because we are happy to substitute it inside a lambda)
403 Notice that a variable is considered 'cheap': we can push it inside a lambda,
404 because sharing will make sure it is only evaluated once.
407 exprIsCheap :: CoreExpr -> Bool
408 exprIsCheap (Lit lit) = True
409 exprIsCheap (Type _) = True
410 exprIsCheap (Var _) = True
411 exprIsCheap (Note InlineMe e) = True
412 exprIsCheap (Note _ e) = exprIsCheap e
413 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
414 exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
415 and [exprIsCheap rhs | (_,_,rhs) <- alts]
416 -- Experimentally, treat (case x of ...) as cheap
417 -- (and case __coerce x etc.)
418 -- This improves arities of overloaded functions where
419 -- there is only dictionary selection (no construction) involved
420 exprIsCheap (Let (NonRec x _) e)
421 | isUnLiftedType (idType x) = exprIsCheap e
423 -- strict lets always have cheap right hand sides, and
426 exprIsCheap other_expr
427 = go other_expr 0 True
429 go (Var f) n_args args_cheap
430 = (idAppIsCheap f n_args && args_cheap)
431 -- A constructor, cheap primop, or partial application
433 || idAppIsBottom f n_args
434 -- Application of a function which
435 -- always gives bottom; we treat this as cheap
436 -- because it certainly doesn't need to be shared!
438 go (App f a) n_args args_cheap
439 | not (isRuntimeArg a) = go f n_args args_cheap
440 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
442 go other n_args args_cheap = False
444 idAppIsCheap :: Id -> Int -> Bool
445 idAppIsCheap id n_val_args
446 | n_val_args == 0 = True -- Just a type application of
447 -- a variable (f t1 t2 t3)
449 | otherwise = case globalIdDetails id of
450 DataConWorkId _ -> True
451 RecordSelId _ _ -> True -- I'm experimenting with making record selection
452 ClassOpId _ -> True -- look cheap, so we will substitute it inside a
453 -- lambda. Particularly for dictionary field selection
455 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
456 -- that return a type variable, since the result
457 -- might be applied to something, but I'm not going
458 -- to bother to check the number of args
459 other -> n_val_args < idArity id
462 exprOkForSpeculation returns True of an expression that it is
464 * safe to evaluate even if normal order eval might not
465 evaluate the expression at all, or
467 * safe *not* to evaluate even if normal order would do so
471 the expression guarantees to terminate,
473 without raising an exception,
474 without causing a side effect (e.g. writing a mutable variable)
477 let x = case y# +# 1# of { r# -> I# r# }
480 case y# +# 1# of { r# ->
485 We can only do this if the (y+1) is ok for speculation: it has no
486 side effects, and can't diverge or raise an exception.
489 exprOkForSpeculation :: CoreExpr -> Bool
490 exprOkForSpeculation (Lit _) = True
491 exprOkForSpeculation (Type _) = True
492 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
493 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
494 exprOkForSpeculation other_expr
495 = case collectArgs other_expr of
496 (Var f, args) -> spec_ok (globalIdDetails f) args
500 spec_ok (DataConWorkId _) args
501 = True -- The strictness of the constructor has already
502 -- been expressed by its "wrapper", so we don't need
503 -- to take the arguments into account
505 spec_ok (PrimOpId op) args
506 | isDivOp op, -- Special case for dividing operations that fail
507 [arg1, Lit lit] <- args -- only if the divisor is zero
508 = not (isZeroLit lit) && exprOkForSpeculation arg1
509 -- Often there is a literal divisor, and this
510 -- can get rid of a thunk in an inner looop
513 = primOpOkForSpeculation op &&
514 all exprOkForSpeculation args
515 -- A bit conservative: we don't really need
516 -- to care about lazy arguments, but this is easy
518 spec_ok other args = False
520 isDivOp :: PrimOp -> Bool
521 -- True of dyadic operators that can fail
522 -- only if the second arg is zero
523 -- This function probably belongs in PrimOp, or even in
524 -- an automagically generated file.. but it's such a
525 -- special case I thought I'd leave it here for now.
526 isDivOp IntQuotOp = True
527 isDivOp IntRemOp = True
528 isDivOp WordQuotOp = True
529 isDivOp WordRemOp = True
530 isDivOp IntegerQuotRemOp = True
531 isDivOp IntegerDivModOp = True
532 isDivOp FloatDivOp = True
533 isDivOp DoubleDivOp = True
534 isDivOp other = False
539 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
540 exprIsBottom e = go 0 e
542 -- n is the number of args
543 go n (Note _ e) = go n e
544 go n (Let _ e) = go n e
545 go n (Case e _ _ _) = go 0 e -- Just check the scrut
546 go n (App e _) = go (n+1) e
547 go n (Var v) = idAppIsBottom v n
549 go n (Lam _ _) = False
550 go n (Type _) = False
552 idAppIsBottom :: Id -> Int -> Bool
553 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
556 @exprIsValue@ returns true for expressions that are certainly *already*
557 evaluated to *head* normal form. This is used to decide whether it's ok
560 case x of _ -> e ===> e
562 and to decide whether it's safe to discard a `seq`
564 So, it does *not* treat variables as evaluated, unless they say they are.
566 But it *does* treat partial applications and constructor applications
567 as values, even if their arguments are non-trivial, provided the argument
569 e.g. (:) (f x) (map f xs) is a value
570 map (...redex...) is a value
571 Because `seq` on such things completes immediately
573 For unlifted argument types, we have to be careful:
575 Suppose (f x) diverges; then C (f x) is not a value. True, but
576 this form is illegal (see the invariants in CoreSyn). Args of unboxed
577 type must be ok-for-speculation (or trivial).
580 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
581 exprIsValue (Var v) -- NB: There are no value args at this point
582 = isDataConWorkId v -- Catches nullary constructors,
583 -- so that [] and () are values, for example
584 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
585 || isEvaldUnfolding (idUnfolding v)
586 -- Check the thing's unfolding; it might be bound to a value
587 -- A worry: what if an Id's unfolding is just itself:
588 -- then we could get an infinite loop...
590 exprIsValue (Lit l) = True
591 exprIsValue (Type ty) = True -- Types are honorary Values;
592 -- we don't mind copying them
593 exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e
594 exprIsValue (Note _ e) = exprIsValue e
595 exprIsValue (App e (Type _)) = exprIsValue e
596 exprIsValue (App e a) = app_is_value e [a]
597 exprIsValue other = False
599 -- There is at least one value argument
600 app_is_value (Var fun) args
601 | isDataConWorkId fun -- Constructor apps are values
602 || idArity fun > valArgCount args -- Under-applied function
603 = check_args (idType fun) args
604 app_is_value (App f a) as = app_is_value f (a:as)
605 app_is_value other as = False
607 -- 'check_args' checks that unlifted-type args
608 -- are in fact guaranteed non-divergent
609 check_args fun_ty [] = True
610 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
611 Just (_, ty) -> check_args ty args
612 check_args fun_ty (arg : args)
613 | isUnLiftedType arg_ty = exprOkForSpeculation arg
614 | otherwise = check_args res_ty args
616 (arg_ty, res_ty) = splitFunTy fun_ty
620 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
621 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
622 = -- Maybe this is over the top, but here we try to turn
623 -- coerce (S,T) ( x, y )
625 -- ( coerce S x, coerce T y )
626 -- This happens in anger in PrelArrExts which has a coerce
627 -- case coerce memcpy a b of
629 -- where the memcpy is in the IO monad, but the call is in
631 case exprIsConApp_maybe expr of {
635 case splitTyConApp_maybe to_ty of {
637 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
638 | not (isVanillaDataCon dc) -> Nothing
640 -- Type constructor must match
641 -- We knock out existentials to keep matters simple(r)
643 arity = tyConArity tc
644 val_args = drop arity args
645 to_arg_tys = dataConArgTys dc tc_arg_tys
646 mk_coerce ty arg = mkCoerce ty arg
647 new_val_args = zipWith mk_coerce to_arg_tys val_args
649 ASSERT( all isTypeArg (take arity args) )
650 ASSERT( equalLength val_args to_arg_tys )
651 Just (dc, map Type tc_arg_tys ++ new_val_args)
654 exprIsConApp_maybe (Note _ expr)
655 = exprIsConApp_maybe expr
656 -- We ignore InlineMe notes in case we have
657 -- x = __inline_me__ (a,b)
658 -- All part of making sure that INLINE pragmas never hurt
659 -- Marcin tripped on this one when making dictionaries more inlinable
661 -- In fact, we ignore all notes. For example,
662 -- case _scc_ "foo" (C a b) of
664 -- should be optimised away, but it will be only if we look
665 -- through the SCC note.
667 exprIsConApp_maybe expr = analyse (collectArgs expr)
669 analyse (Var fun, args)
670 | Just con <- isDataConWorkId_maybe fun,
671 args `lengthAtLeast` dataConRepArity con
672 -- Might be > because the arity excludes type args
675 -- Look through unfoldings, but only cheap ones, because
676 -- we are effectively duplicating the unfolding
677 analyse (Var fun, [])
678 | let unf = idUnfolding fun,
680 = exprIsConApp_maybe (unfoldingTemplate unf)
682 analyse other = Nothing
687 %************************************************************************
689 \subsection{Eta reduction and expansion}
691 %************************************************************************
694 exprEtaExpandArity :: CoreExpr -> Arity
695 {- The Arity returned is the number of value args the
696 thing can be applied to without doing much work
698 exprEtaExpandArity is used when eta expanding
701 It returns 1 (or more) to:
702 case x of p -> \s -> ...
703 because for I/O ish things we really want to get that \s to the top.
704 We are prepared to evaluate x each time round the loop in order to get that
706 It's all a bit more subtle than it looks:
710 Consider one-shot lambdas
711 let x = expensive in \y z -> E
712 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
713 Hence the ArityType returned by arityType
715 2. The state-transformer hack
717 The one-shot lambda special cause is particularly important/useful for
718 IO state transformers, where we often get
719 let x = E in \ s -> ...
721 and the \s is a real-world state token abstraction. Such abstractions
722 are almost invariably 1-shot, so we want to pull the \s out, past the
723 let x=E, even if E is expensive. So we treat state-token lambdas as
724 one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
726 3. Dealing with bottom
729 f = \x -> error "foo"
730 Here, arity 1 is fine. But if it is
734 then we want to get arity 2. Tecnically, this isn't quite right, because
736 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
737 do so; it improves some programs significantly, and increasing convergence
738 isn't a bad thing. Hence the ABot/ATop in ArityType.
740 Actually, the situation is worse. Consider
744 Can we eta-expand here? At first the answer looks like "yes of course", but
747 This should diverge! But if we eta-expand, it won't. Again, we ignore this
748 "problem", because being scrupulous would lose an important transformation for
753 exprEtaExpandArity e = arityDepth (arityType e)
755 -- A limited sort of function type
756 data ArityType = AFun Bool ArityType -- True <=> one-shot
757 | ATop -- Know nothing
760 arityDepth :: ArityType -> Arity
761 arityDepth (AFun _ ty) = 1 + arityDepth ty
764 andArityType ABot at2 = at2
765 andArityType ATop at2 = ATop
766 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
767 andArityType at1 at2 = andArityType at2 at1
769 arityType :: CoreExpr -> ArityType
770 -- (go1 e) = [b1,..,bn]
771 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
772 -- where bi is True <=> the lambda is one-shot
774 arityType (Note n e) = arityType e
775 -- Not needed any more: etaExpand is cleverer
776 -- | ok_note n = arityType e
777 -- | otherwise = ATop
780 = mk (idArity v) (arg_tys (idType v))
782 mk :: Arity -> [Type] -> ArityType
783 -- The argument types are only to steer the "state hack"
784 -- Consider case x of
786 -- False -> \(s:RealWorld) -> e
787 -- where foo has arity 1. Then we want the state hack to
788 -- apply to foo too, so we can eta expand the case.
789 mk 0 tys | isBottomingId v = ABot
791 mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
792 mk n [] = AFun False (mk (n-1) [])
794 arg_tys :: Type -> [Type] -- Ignore for-alls
796 | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
797 | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
800 -- Lambdas; increase arity
801 arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
802 | otherwise = arityType e
804 -- Applications; decrease arity
805 arityType (App f (Type _)) = arityType f
806 arityType (App f a) = case arityType f of
807 AFun one_shot xs | exprIsCheap a -> xs
810 -- Case/Let; keep arity if either the expression is cheap
811 -- or it's a 1-shot lambda
812 -- The former is not really right for Haskell
813 -- f x = case x of { (a,b) -> \y. e }
815 -- f x y = case x of { (a,b) -> e }
816 -- The difference is observable using 'seq'
817 arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
818 xs@(AFun one_shot _) | one_shot -> xs
819 xs | exprIsCheap scrut -> xs
822 arityType (Let b e) = case arityType e of
823 xs@(AFun one_shot _) | one_shot -> xs
824 xs | all exprIsCheap (rhssOfBind b) -> xs
827 arityType other = ATop
829 {- NOT NEEDED ANY MORE: etaExpand is cleverer
830 ok_note InlineMe = False
832 -- Notice that we do not look through __inline_me__
833 -- This may seem surprising, but consider
834 -- f = _inline_me (\x -> e)
835 -- We DO NOT want to eta expand this to
836 -- f = \x -> (_inline_me (\x -> e)) x
837 -- because the _inline_me gets dropped now it is applied,
846 etaExpand :: Arity -- Result should have this number of value args
848 -> CoreExpr -> Type -- Expression and its type
850 -- (etaExpand n us e ty) returns an expression with
851 -- the same meaning as 'e', but with arity 'n'.
853 -- Given e' = etaExpand n us e ty
855 -- ty = exprType e = exprType e'
857 -- Note that SCCs are not treated specially. If we have
858 -- etaExpand 2 (\x -> scc "foo" e)
859 -- = (\xy -> (scc "foo" e) y)
860 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
862 etaExpand n us expr ty
863 | manifestArity expr >= n = expr -- The no-op case
864 | otherwise = eta_expand n us expr ty
867 -- manifestArity sees how many leading value lambdas there are
868 manifestArity :: CoreExpr -> Arity
869 manifestArity (Lam v e) | isId v = 1 + manifestArity e
870 | otherwise = manifestArity e
871 manifestArity (Note _ e) = manifestArity e
874 -- etaExpand deals with for-alls. For example:
876 -- where E :: forall a. a -> a
878 -- (/\b. \y::a -> E b y)
880 -- It deals with coerces too, though they are now rare
881 -- so perhaps the extra code isn't worth it
883 eta_expand n us expr ty
885 -- The ILX code generator requires eta expansion for type arguments
886 -- too, but alas the 'n' doesn't tell us how many of them there
887 -- may be. So we eagerly eta expand any big lambdas, and just
888 -- cross our fingers about possible loss of sharing in the ILX case.
889 -- The Right Thing is probably to make 'arity' include
890 -- type variables throughout the compiler. (ToDo.)
892 -- Saturated, so nothing to do
895 -- Short cut for the case where there already
896 -- is a lambda; no point in gratuitously adding more
897 eta_expand n us (Lam v body) ty
899 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
902 = Lam v (eta_expand (n-1) us body (funResultTy ty))
904 -- We used to have a special case that stepped inside Coerces here,
905 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
906 -- = Note note (eta_expand n us e ty)
907 -- BUT this led to an infinite loop
908 -- Example: newtype T = MkT (Int -> Int)
909 -- eta_expand 1 (coerce (Int->Int) e)
910 -- --> coerce (Int->Int) (eta_expand 1 T e)
912 -- --> coerce (Int->Int) (coerce T
913 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
914 -- by the splitNewType_maybe case below
917 eta_expand n us expr ty
918 = case splitForAllTy_maybe ty of {
919 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
923 case splitFunTy_maybe ty of {
924 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
926 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
932 -- newtype T = MkT ([T] -> Int)
933 -- Consider eta-expanding this
936 -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
937 -- Only try this for recursive newtypes; the non-recursive kind
938 -- are transparent anyway
940 case splitRecNewType_maybe ty of {
941 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
942 Nothing -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
946 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
947 It tells how many things the expression can be applied to before doing
948 any work. It doesn't look inside cases, lets, etc. The idea is that
949 exprEtaExpandArity will do the hard work, leaving something that's easy
950 for exprArity to grapple with. In particular, Simplify uses exprArity to
951 compute the ArityInfo for the Id.
953 Originally I thought that it was enough just to look for top-level lambdas, but
954 it isn't. I've seen this
956 foo = PrelBase.timesInt
958 We want foo to get arity 2 even though the eta-expander will leave it
959 unchanged, in the expectation that it'll be inlined. But occasionally it
960 isn't, because foo is blacklisted (used in a rule).
962 Similarly, see the ok_note check in exprEtaExpandArity. So
963 f = __inline_me (\x -> e)
964 won't be eta-expanded.
966 And in any case it seems more robust to have exprArity be a bit more intelligent.
967 But note that (\x y z -> f x y z)
968 should have arity 3, regardless of f's arity.
971 exprArity :: CoreExpr -> Arity
974 go (Var v) = idArity v
975 go (Lam x e) | isId x = go e + 1
978 go (App e (Type t)) = go e
979 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
980 -- NB: exprIsCheap a!
981 -- f (fac x) does not have arity 2,
982 -- even if f has arity 3!
983 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
984 -- unknown, hence arity 0
988 %************************************************************************
990 \subsection{Equality}
992 %************************************************************************
994 @cheapEqExpr@ is a cheap equality test which bales out fast!
995 True => definitely equal
996 False => may or may not be equal
999 cheapEqExpr :: Expr b -> Expr b -> Bool
1001 cheapEqExpr (Var v1) (Var v2) = v1==v2
1002 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1003 cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
1005 cheapEqExpr (App f1 a1) (App f2 a2)
1006 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1008 cheapEqExpr _ _ = False
1010 exprIsBig :: Expr b -> Bool
1011 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1012 exprIsBig (Lit _) = False
1013 exprIsBig (Var v) = False
1014 exprIsBig (Type t) = False
1015 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1016 exprIsBig other = True
1021 tcEqExpr :: CoreExpr -> CoreExpr -> Bool
1022 -- Used in rule matching, so does *not* look through
1023 -- newtypes, predicate types; hence tcEqExpr
1025 tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
1027 rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
1029 tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
1030 tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
1031 tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2
1032 tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
1033 tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
1034 tcEqExprX env (Let (NonRec v1 r1) e1)
1035 (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
1036 && tcEqExprX (rnBndr2 env v1 v2) e1 e2
1037 tcEqExprX env (Let (Rec ps1) e1)
1038 (Let (Rec ps2) e2) = equalLength ps1 ps2
1039 && and (zipWith eq_rhs ps1 ps2)
1040 && tcEqExprX env' e1 e2
1042 env' = foldl2 rn_bndr2 env ps2 ps2
1043 rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
1044 eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
1045 tcEqExprX env (Case e1 v1 t1 a1)
1046 (Case e2 v2 t2 a2) = tcEqExprX env e1 e2
1047 && tcEqTypeX env t1 t2
1048 && equalLength a1 a2
1049 && and (zipWith (eq_alt env') a1 a2)
1051 env' = rnBndr2 env v1 v2
1053 tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
1054 tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
1055 tcEqExprX env e1 e2 = False
1057 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
1059 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1060 eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2
1061 eq_note env InlineCall InlineCall = True
1062 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1063 eq_note env other1 other2 = False
1067 %************************************************************************
1069 \subsection{The size of an expression}
1071 %************************************************************************
1074 coreBindsSize :: [CoreBind] -> Int
1075 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1077 exprSize :: CoreExpr -> Int
1078 -- A measure of the size of the expressions
1079 -- It also forces the expression pretty drastically as a side effect
1080 exprSize (Var v) = v `seq` 1
1081 exprSize (Lit lit) = lit `seq` 1
1082 exprSize (App f a) = exprSize f + exprSize a
1083 exprSize (Lam b e) = varSize b + exprSize e
1084 exprSize (Let b e) = bindSize b + exprSize e
1085 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1086 exprSize (Note n e) = noteSize n + exprSize e
1087 exprSize (Type t) = seqType t `seq` 1
1089 noteSize (SCC cc) = cc `seq` 1
1090 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1091 noteSize InlineCall = 1
1092 noteSize InlineMe = 1
1093 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1095 varSize :: Var -> Int
1096 varSize b | isTyVar b = 1
1097 | otherwise = seqType (idType b) `seq`
1098 megaSeqIdInfo (idInfo b) `seq`
1101 varsSize = foldr ((+) . varSize) 0
1103 bindSize (NonRec b e) = varSize b + exprSize e
1104 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1106 pairSize (b,e) = varSize b + exprSize e
1108 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1112 %************************************************************************
1114 \subsection{Hashing}
1116 %************************************************************************
1119 hashExpr :: CoreExpr -> Int
1120 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1123 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1125 hash_expr (Note _ e) = hash_expr e
1126 hash_expr (Let (NonRec b r) e) = hashId b
1127 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1128 hash_expr (Case _ b _ _) = hashId b
1129 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1130 hash_expr (Var v) = hashId v
1131 hash_expr (Lit lit) = hashLiteral lit
1132 hash_expr (Lam b _) = hashId b
1133 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1135 fast_hash_expr (Var v) = hashId v
1136 fast_hash_expr (Lit lit) = hashLiteral lit
1137 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1138 fast_hash_expr (App f a) = fast_hash_expr a
1139 fast_hash_expr (Lam b _) = hashId b
1140 fast_hash_expr other = 1
1143 hashId id = hashName (idName id)
1146 %************************************************************************
1148 \subsection{Determining non-updatable right-hand-sides}
1150 %************************************************************************
1152 Top-level constructor applications can usually be allocated
1153 statically, but they can't if the constructor, or any of the
1154 arguments, come from another DLL (because we can't refer to static
1155 labels in other DLLs).
1157 If this happens we simply make the RHS into an updatable thunk,
1158 and 'exectute' it rather than allocating it statically.
1161 rhsIsStatic :: HomeModules -> CoreExpr -> Bool
1162 -- This function is called only on *top-level* right-hand sides
1163 -- Returns True if the RHS can be allocated statically, with
1164 -- no thunks involved at all.
1166 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1167 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1168 -- update flag on it.
1170 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1171 -- (a) a value lambda
1172 -- (b) a saturated constructor application with static args
1174 -- BUT watch out for
1175 -- (i) Any cross-DLL references kill static-ness completely
1176 -- because they must be 'executed' not statically allocated
1177 -- ("DLL" here really only refers to Windows DLLs, on other platforms,
1178 -- this is not necessary)
1180 -- (ii) We treat partial applications as redexes, because in fact we
1181 -- make a thunk for them that runs and builds a PAP
1182 -- at run-time. The only appliations that are treated as
1183 -- static are *saturated* applications of constructors.
1185 -- We used to try to be clever with nested structures like this:
1186 -- ys = (:) w ((:) w [])
1187 -- on the grounds that CorePrep will flatten ANF-ise it later.
1188 -- But supporting this special case made the function much more
1189 -- complicated, because the special case only applies if there are no
1190 -- enclosing type lambdas:
1191 -- ys = /\ a -> Foo (Baz ([] a))
1192 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1194 -- But in fact, even without -O, nested structures at top level are
1195 -- flattened by the simplifier, so we don't need to be super-clever here.
1199 -- f = \x::Int. x+7 TRUE
1200 -- p = (True,False) TRUE
1202 -- d = (fst p, False) FALSE because there's a redex inside
1203 -- (this particular one doesn't happen but...)
1205 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1206 -- n = /\a. Nil a TRUE
1208 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1211 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1212 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1214 -- b) (C x xs), where C is a contructors is updatable if the application is
1217 -- c) don't look through unfolding of f in (f x).
1219 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1220 -- them as making the RHS re-entrant (non-updatable).
1222 rhsIsStatic hmods rhs = is_static False rhs
1224 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1227 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1229 is_static in_arg (Note (SCC _) e) = False
1230 is_static in_arg (Note _ e) = is_static in_arg e
1232 is_static in_arg (Lit lit)
1234 MachLabel _ _ -> False
1236 -- A MachLabel (foreign import "&foo") in an argument
1237 -- prevents a constructor application from being static. The
1238 -- reason is that it might give rise to unresolvable symbols
1239 -- in the object file: under Linux, references to "weak"
1240 -- symbols from the data segment give rise to "unresolvable
1241 -- relocation" errors at link time This might be due to a bug
1242 -- in the linker, but we'll work around it here anyway.
1245 is_static in_arg other_expr = go other_expr 0
1247 go (Var f) n_val_args
1248 #if mingw32_TARGET_OS
1249 | not (isDllName hmods (idName f))
1251 = saturated_data_con f n_val_args
1252 || (in_arg && n_val_args == 0)
1253 -- A naked un-applied variable is *not* deemed a static RHS
1255 -- Reason: better to update so that the indirection gets shorted
1256 -- out, and the true value will be seen
1257 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1258 -- are always updatable. If you do so, make sure that non-updatable
1259 -- ones have enough space for their static link field!
1261 go (App f a) n_val_args
1262 | isTypeArg a = go f n_val_args
1263 | not in_arg && is_static True a = go f (n_val_args + 1)
1264 -- The (not in_arg) checks that we aren't in a constructor argument;
1265 -- if we are, we don't allow (value) applications of any sort
1267 -- NB. In case you wonder, args are sometimes not atomic. eg.
1268 -- x = D# (1.0## /## 2.0##)
1269 -- can't float because /## can fail.
1271 go (Note (SCC _) f) n_val_args = False
1272 go (Note _ f) n_val_args = go f n_val_args
1274 go other n_val_args = False
1276 saturated_data_con f n_val_args
1277 = case isDataConWorkId_maybe f of
1278 Just dc -> n_val_args == dataConRepArity dc