2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
10 bindNonRec, needsCaseBinding,
11 mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
13 -- Taking expressions apart
14 findDefault, findAlt, isDefaultAlt, mergeAlts,
16 -- Properties of expressions
17 exprType, coreAltType,
18 exprIsDupable, exprIsTrivial, exprIsCheap,
19 exprIsHNF,exprOkForSpeculation, exprIsBig,
20 exprIsConApp_maybe, exprIsBottom,
23 -- Arity and eta expansion
24 manifestArity, exprArity,
25 exprEtaExpandArity, etaExpand,
34 cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg
37 #include "HsVersions.h"
40 import GLAEXTS -- For `xori`
43 import CoreFVs ( exprFreeVars )
44 import PprCore ( pprCoreExpr )
46 import VarSet ( unionVarSet )
48 import Name ( hashName )
49 import Packages ( HomeModules )
51 import Packages ( isDllName )
53 import Literal ( hashLiteral, literalType, litIsDupable,
54 litIsTrivial, isZeroLit, Literal( MachLabel ) )
55 import DataCon ( DataCon, dataConRepArity, dataConInstArgTys,
56 isVanillaDataCon, dataConTyCon )
57 import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
58 import Id ( Id, idType, globalIdDetails, idNewStrictness,
59 mkWildId, idArity, idName, idUnfolding, idInfo,
60 isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
61 isDataConWorkId, isBottomingId
63 import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
64 import NewDemand ( appIsBottom )
65 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
66 splitFunTy, tcEqTypeX,
67 applyTys, isUnLiftedType, seqType, mkTyVarTy,
68 splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
69 splitTyConApp_maybe, coreEqType, funResultTy, applyTy
71 import TyCon ( tyConArity )
72 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
73 import CostCentre ( CostCentre )
74 import BasicTypes ( Arity )
75 import Unique ( Unique )
77 import TysPrim ( alphaTy ) -- Debugging only
78 import Util ( equalLength, lengthAtLeast, foldl2 )
82 %************************************************************************
84 \subsection{Find the type of a Core atom/expression}
86 %************************************************************************
89 exprType :: CoreExpr -> Type
91 exprType (Var var) = idType var
92 exprType (Lit lit) = literalType lit
93 exprType (Let _ body) = exprType body
94 exprType (Case _ _ ty alts) = ty
95 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
96 exprType (Note other_note e) = exprType e
97 exprType (Lam binder expr) = mkPiType binder (exprType expr)
99 = case collectArgs e of
100 (fun, args) -> applyTypeToArgs e (exprType fun) args
102 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
104 coreAltType :: CoreAlt -> Type
105 coreAltType (_,_,rhs) = exprType rhs
108 @mkPiType@ makes a (->) type or a forall type, depending on whether
109 it is given a type variable or a term variable. We cleverly use the
110 lbvarinfo field to figure out the right annotation for the arrove in
111 case of a term variable.
114 mkPiType :: Var -> Type -> Type -- The more polymorphic version
115 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
117 mkPiTypes vs ty = foldr mkPiType ty vs
120 | isId v = mkFunTy (idType v) ty
121 | otherwise = mkForAllTy v ty
125 applyTypeToArg :: Type -> CoreExpr -> Type
126 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
127 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
129 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
130 -- A more efficient version of applyTypeToArg
131 -- when we have several args
132 -- The first argument is just for debugging
133 applyTypeToArgs e op_ty [] = op_ty
135 applyTypeToArgs e op_ty (Type ty : args)
136 = -- Accumulate type arguments so we can instantiate all at once
139 go rev_tys (Type ty : args) = go (ty:rev_tys) args
140 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
142 op_ty' = applyTys op_ty (reverse rev_tys)
144 applyTypeToArgs e op_ty (other_arg : args)
145 = case (splitFunTy_maybe op_ty) of
146 Just (_, res_ty) -> applyTypeToArgs e res_ty args
147 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
152 %************************************************************************
154 \subsection{Attaching notes}
156 %************************************************************************
158 mkNote removes redundant coercions, and SCCs where possible
162 mkNote :: Note -> CoreExpr -> CoreExpr
163 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
164 mkNote (SCC cc) expr = mkSCC cc expr
165 mkNote InlineMe expr = mkInlineMe expr
166 mkNote note expr = Note note expr
169 -- Slide InlineCall in around the function
170 -- No longer necessary I think (SLPJ Apr 99)
171 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
172 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
173 -- mkNote InlineCall expr = expr
176 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
177 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
178 not be *applied* to anything.
180 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
183 f = inline_me (coerce t fw)
184 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
185 We want the split, so that the coerces can cancel at the call site.
187 However, we can get left with tiresome type applications. Notably, consider
188 f = /\ a -> let t = e in (t, w)
189 Then lifting the let out of the big lambda gives
191 f = /\ a -> let t = inline_me (t' a) in (t, w)
192 The inline_me is to stop the simplifier inlining t' right back
193 into t's RHS. In the next phase we'll substitute for t (since
194 its rhs is trivial) and *then* we could get rid of the inline_me.
195 But it hardly seems worth it, so I don't bother.
198 mkInlineMe (Var v) = Var v
199 mkInlineMe e = Note InlineMe e
205 mkCoerce :: Type -> CoreExpr -> CoreExpr
206 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
208 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
209 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
210 = ASSERT( from_ty `coreEqType` to_ty2 )
211 mkCoerce2 to_ty from_ty2 expr
213 mkCoerce2 to_ty from_ty expr
214 | to_ty `coreEqType` from_ty = expr
215 | otherwise = ASSERT( from_ty `coreEqType` exprType expr )
216 Note (Coerce to_ty from_ty) expr
220 mkSCC :: CostCentre -> Expr b -> Expr b
221 -- Note: Nested SCC's *are* preserved for the benefit of
222 -- cost centre stack profiling
223 mkSCC cc (Lit lit) = Lit lit
224 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
225 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
226 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
227 mkSCC cc expr = Note (SCC cc) expr
231 %************************************************************************
233 \subsection{Other expression construction}
235 %************************************************************************
238 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
239 -- (bindNonRec x r b) produces either
242 -- case r of x { _DEFAULT_ -> b }
244 -- depending on whether x is unlifted or not
245 -- It's used by the desugarer to avoid building bindings
246 -- that give Core Lint a heart attack. Actually the simplifier
247 -- deals with them perfectly well.
249 bindNonRec bndr rhs body
250 | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
251 | otherwise = Let (NonRec bndr rhs) body
253 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
254 -- Make a case expression instead of a let
255 -- These can arise either from the desugarer,
256 -- or from beta reductions: (\x.e) (x +# y)
260 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
261 -- This guy constructs the value that the scrutinee must have
262 -- when you are in one particular branch of a case
263 mkAltExpr (DataAlt con) args inst_tys
264 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
265 mkAltExpr (LitAlt lit) [] []
268 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
269 mkIfThenElse guard then_expr else_expr
270 -- Not going to be refining, so okay to take the type of the "then" clause
271 = Case guard (mkWildId boolTy) (exprType then_expr)
272 [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
273 (DataAlt trueDataCon, [], then_expr) ]
277 %************************************************************************
279 \subsection{Taking expressions apart}
281 %************************************************************************
283 The default alternative must be first, if it exists at all.
284 This makes it easy to find, though it makes matching marginally harder.
287 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
288 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
289 findDefault alts = (alts, Nothing)
291 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
294 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
295 other -> go alts panic_deflt
297 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
300 go (alt@(con1,_,_) : alts) deflt
301 = case con `cmpAltCon` con1 of
302 LT -> deflt -- Missed it already; the alts are in increasing order
304 GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
306 isDefaultAlt :: CoreAlt -> Bool
307 isDefaultAlt (DEFAULT, _, _) = True
308 isDefaultAlt other = False
310 ---------------------------------
311 mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
312 -- Merge preserving order; alternatives in the first arg
313 -- shadow ones in the second
314 mergeAlts [] as2 = as2
315 mergeAlts as1 [] = as1
316 mergeAlts (a1:as1) (a2:as2)
317 = case a1 `cmpAlt` a2 of
318 LT -> a1 : mergeAlts as1 (a2:as2)
319 EQ -> a1 : mergeAlts as1 as2 -- Discard a2
320 GT -> a2 : mergeAlts (a1:as1) as2
324 %************************************************************************
326 \subsection{Figuring out things about expressions}
328 %************************************************************************
330 @exprIsTrivial@ is true of expressions we are unconditionally happy to
331 duplicate; simple variables and constants, and type
332 applications. Note that primop Ids aren't considered
335 @exprIsBottom@ is true of expressions that are guaranteed to diverge
338 There used to be a gruesome test for (hasNoBinding v) in the
340 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
341 The idea here is that a constructor worker, like $wJust, is
342 really short for (\x -> $wJust x), becuase $wJust has no binding.
343 So it should be treated like a lambda. Ditto unsaturated primops.
344 But now constructor workers are not "have-no-binding" Ids. And
345 completely un-applied primops and foreign-call Ids are sufficiently
346 rare that I plan to allow them to be duplicated and put up with
349 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
350 a) it really generates code, (and a heap object when it's
351 a function arg) to capture the cost centre
352 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
355 exprIsTrivial (Var v) = True -- See notes above
356 exprIsTrivial (Type _) = True
357 exprIsTrivial (Lit lit) = litIsTrivial lit
358 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
359 exprIsTrivial (Note (SCC _) e) = False -- See notes above
360 exprIsTrivial (Note _ e) = exprIsTrivial e
361 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
362 exprIsTrivial other = False
366 @exprIsDupable@ is true of expressions that can be duplicated at a modest
367 cost in code size. This will only happen in different case
368 branches, so there's no issue about duplicating work.
370 That is, exprIsDupable returns True of (f x) even if
371 f is very very expensive to call.
373 Its only purpose is to avoid fruitless let-binding
374 and then inlining of case join points
378 exprIsDupable (Type _) = True
379 exprIsDupable (Var v) = True
380 exprIsDupable (Lit lit) = litIsDupable lit
381 exprIsDupable (Note InlineMe e) = True
382 exprIsDupable (Note _ e) = exprIsDupable e
386 go (Var v) n_args = True
387 go (App f a) n_args = n_args < dupAppSize
390 go other n_args = False
393 dupAppSize = 4 -- Size of application we are prepared to duplicate
396 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
397 it is obviously in weak head normal form, or is cheap to get to WHNF.
398 [Note that that's not the same as exprIsDupable; an expression might be
399 big, and hence not dupable, but still cheap.]
401 By ``cheap'' we mean a computation we're willing to:
402 push inside a lambda, or
403 inline at more than one place
404 That might mean it gets evaluated more than once, instead of being
405 shared. The main examples of things which aren't WHNF but are
410 (where e, and all the ei are cheap)
413 (where e and b are cheap)
416 (where op is a cheap primitive operator)
419 (because we are happy to substitute it inside a lambda)
421 Notice that a variable is considered 'cheap': we can push it inside a lambda,
422 because sharing will make sure it is only evaluated once.
425 exprIsCheap :: CoreExpr -> Bool
426 exprIsCheap (Lit lit) = True
427 exprIsCheap (Type _) = True
428 exprIsCheap (Var _) = True
429 exprIsCheap (Note InlineMe e) = True
430 exprIsCheap (Note _ e) = exprIsCheap e
431 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
432 exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
433 and [exprIsCheap rhs | (_,_,rhs) <- alts]
434 -- Experimentally, treat (case x of ...) as cheap
435 -- (and case __coerce x etc.)
436 -- This improves arities of overloaded functions where
437 -- there is only dictionary selection (no construction) involved
438 exprIsCheap (Let (NonRec x _) e)
439 | isUnLiftedType (idType x) = exprIsCheap e
441 -- strict lets always have cheap right hand sides, and
444 exprIsCheap other_expr
445 = go other_expr 0 True
447 go (Var f) n_args args_cheap
448 = (idAppIsCheap f n_args && args_cheap)
449 -- A constructor, cheap primop, or partial application
451 || idAppIsBottom f n_args
452 -- Application of a function which
453 -- always gives bottom; we treat this as cheap
454 -- because it certainly doesn't need to be shared!
456 go (App f a) n_args args_cheap
457 | not (isRuntimeArg a) = go f n_args args_cheap
458 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
460 go other n_args args_cheap = False
462 idAppIsCheap :: Id -> Int -> Bool
463 idAppIsCheap id n_val_args
464 | n_val_args == 0 = True -- Just a type application of
465 -- a variable (f t1 t2 t3)
468 = case globalIdDetails id of
469 DataConWorkId _ -> True
470 RecordSelId {} -> n_val_args == 1 -- I'm experimenting with making record selection
471 ClassOpId _ -> n_val_args == 1 -- look cheap, so we will substitute it inside a
472 -- lambda. Particularly for dictionary field selection.
473 -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
474 -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
476 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
477 -- that return a type variable, since the result
478 -- might be applied to something, but I'm not going
479 -- to bother to check the number of args
480 other -> n_val_args < idArity id
483 exprOkForSpeculation returns True of an expression that it is
485 * safe to evaluate even if normal order eval might not
486 evaluate the expression at all, or
488 * safe *not* to evaluate even if normal order would do so
492 the expression guarantees to terminate,
494 without raising an exception,
495 without causing a side effect (e.g. writing a mutable variable)
498 let x = case y# +# 1# of { r# -> I# r# }
501 case y# +# 1# of { r# ->
506 We can only do this if the (y+1) is ok for speculation: it has no
507 side effects, and can't diverge or raise an exception.
510 exprOkForSpeculation :: CoreExpr -> Bool
511 exprOkForSpeculation (Lit _) = True
512 exprOkForSpeculation (Type _) = True
513 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
514 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
515 exprOkForSpeculation other_expr
516 = case collectArgs other_expr of
517 (Var f, args) -> spec_ok (globalIdDetails f) args
521 spec_ok (DataConWorkId _) args
522 = True -- The strictness of the constructor has already
523 -- been expressed by its "wrapper", so we don't need
524 -- to take the arguments into account
526 spec_ok (PrimOpId op) args
527 | isDivOp op, -- Special case for dividing operations that fail
528 [arg1, Lit lit] <- args -- only if the divisor is zero
529 = not (isZeroLit lit) && exprOkForSpeculation arg1
530 -- Often there is a literal divisor, and this
531 -- can get rid of a thunk in an inner looop
534 = primOpOkForSpeculation op &&
535 all exprOkForSpeculation args
536 -- A bit conservative: we don't really need
537 -- to care about lazy arguments, but this is easy
539 spec_ok other args = False
541 isDivOp :: PrimOp -> Bool
542 -- True of dyadic operators that can fail
543 -- only if the second arg is zero
544 -- This function probably belongs in PrimOp, or even in
545 -- an automagically generated file.. but it's such a
546 -- special case I thought I'd leave it here for now.
547 isDivOp IntQuotOp = True
548 isDivOp IntRemOp = True
549 isDivOp WordQuotOp = True
550 isDivOp WordRemOp = True
551 isDivOp IntegerQuotRemOp = True
552 isDivOp IntegerDivModOp = True
553 isDivOp FloatDivOp = True
554 isDivOp DoubleDivOp = True
555 isDivOp other = False
560 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
561 exprIsBottom e = go 0 e
563 -- n is the number of args
564 go n (Note _ e) = go n e
565 go n (Let _ e) = go n e
566 go n (Case e _ _ _) = go 0 e -- Just check the scrut
567 go n (App e _) = go (n+1) e
568 go n (Var v) = idAppIsBottom v n
570 go n (Lam _ _) = False
571 go n (Type _) = False
573 idAppIsBottom :: Id -> Int -> Bool
574 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
577 @exprIsHNF@ returns true for expressions that are certainly *already*
578 evaluated to *head* normal form. This is used to decide whether it's ok
581 case x of _ -> e ===> e
583 and to decide whether it's safe to discard a `seq`
585 So, it does *not* treat variables as evaluated, unless they say they are.
587 But it *does* treat partial applications and constructor applications
588 as values, even if their arguments are non-trivial, provided the argument
590 e.g. (:) (f x) (map f xs) is a value
591 map (...redex...) is a value
592 Because `seq` on such things completes immediately
594 For unlifted argument types, we have to be careful:
596 Suppose (f x) diverges; then C (f x) is not a value. True, but
597 this form is illegal (see the invariants in CoreSyn). Args of unboxed
598 type must be ok-for-speculation (or trivial).
601 exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
602 exprIsHNF (Var v) -- NB: There are no value args at this point
603 = isDataConWorkId v -- Catches nullary constructors,
604 -- so that [] and () are values, for example
605 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
606 || isEvaldUnfolding (idUnfolding v)
607 -- Check the thing's unfolding; it might be bound to a value
608 -- A worry: what if an Id's unfolding is just itself:
609 -- then we could get an infinite loop...
611 exprIsHNF (Lit l) = True
612 exprIsHNF (Type ty) = True -- Types are honorary Values;
613 -- we don't mind copying them
614 exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
615 exprIsHNF (Note _ e) = exprIsHNF e
616 exprIsHNF (App e (Type _)) = exprIsHNF e
617 exprIsHNF (App e a) = app_is_value e [a]
618 exprIsHNF other = False
620 -- There is at least one value argument
621 app_is_value (Var fun) args
622 | isDataConWorkId fun -- Constructor apps are values
623 || idArity fun > valArgCount args -- Under-applied function
624 = check_args (idType fun) args
625 app_is_value (App f a) as = app_is_value f (a:as)
626 app_is_value other as = False
628 -- 'check_args' checks that unlifted-type args
629 -- are in fact guaranteed non-divergent
630 check_args fun_ty [] = True
631 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
632 Just (_, ty) -> check_args ty args
633 check_args fun_ty (arg : args)
634 | isUnLiftedType arg_ty = exprOkForSpeculation arg
635 | otherwise = check_args res_ty args
637 (arg_ty, res_ty) = splitFunTy fun_ty
641 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
642 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
643 = -- Maybe this is over the top, but here we try to turn
644 -- coerce (S,T) ( x, y )
646 -- ( coerce S x, coerce T y )
647 -- This happens in anger in PrelArrExts which has a coerce
648 -- case coerce memcpy a b of
650 -- where the memcpy is in the IO monad, but the call is in
652 case exprIsConApp_maybe expr of {
656 case splitTyConApp_maybe to_ty of {
658 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
659 | not (isVanillaDataCon dc) -> Nothing
661 -- Type constructor must match
662 -- We knock out existentials to keep matters simple(r)
664 arity = tyConArity tc
665 val_args = drop arity args
666 to_arg_tys = dataConInstArgTys dc tc_arg_tys
667 mk_coerce ty arg = mkCoerce ty arg
668 new_val_args = zipWith mk_coerce to_arg_tys val_args
670 ASSERT( all isTypeArg (take arity args) )
671 ASSERT( equalLength val_args to_arg_tys )
672 Just (dc, map Type tc_arg_tys ++ new_val_args)
675 exprIsConApp_maybe (Note _ expr)
676 = exprIsConApp_maybe expr
677 -- We ignore InlineMe notes in case we have
678 -- x = __inline_me__ (a,b)
679 -- All part of making sure that INLINE pragmas never hurt
680 -- Marcin tripped on this one when making dictionaries more inlinable
682 -- In fact, we ignore all notes. For example,
683 -- case _scc_ "foo" (C a b) of
685 -- should be optimised away, but it will be only if we look
686 -- through the SCC note.
688 exprIsConApp_maybe expr = analyse (collectArgs expr)
690 analyse (Var fun, args)
691 | Just con <- isDataConWorkId_maybe fun,
692 args `lengthAtLeast` dataConRepArity con
693 -- Might be > because the arity excludes type args
696 -- Look through unfoldings, but only cheap ones, because
697 -- we are effectively duplicating the unfolding
698 analyse (Var fun, [])
699 | let unf = idUnfolding fun,
701 = exprIsConApp_maybe (unfoldingTemplate unf)
703 analyse other = Nothing
708 %************************************************************************
710 \subsection{Eta reduction and expansion}
712 %************************************************************************
715 exprEtaExpandArity :: CoreExpr -> Arity
716 {- The Arity returned is the number of value args the
717 thing can be applied to without doing much work
719 exprEtaExpandArity is used when eta expanding
722 It returns 1 (or more) to:
723 case x of p -> \s -> ...
724 because for I/O ish things we really want to get that \s to the top.
725 We are prepared to evaluate x each time round the loop in order to get that
727 It's all a bit more subtle than it looks:
731 Consider one-shot lambdas
732 let x = expensive in \y z -> E
733 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
734 Hence the ArityType returned by arityType
736 2. The state-transformer hack
738 The one-shot lambda special cause is particularly important/useful for
739 IO state transformers, where we often get
740 let x = E in \ s -> ...
742 and the \s is a real-world state token abstraction. Such abstractions
743 are almost invariably 1-shot, so we want to pull the \s out, past the
744 let x=E, even if E is expensive. So we treat state-token lambdas as
745 one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
747 3. Dealing with bottom
750 f = \x -> error "foo"
751 Here, arity 1 is fine. But if it is
755 then we want to get arity 2. Tecnically, this isn't quite right, because
757 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
758 do so; it improves some programs significantly, and increasing convergence
759 isn't a bad thing. Hence the ABot/ATop in ArityType.
761 Actually, the situation is worse. Consider
765 Can we eta-expand here? At first the answer looks like "yes of course", but
768 This should diverge! But if we eta-expand, it won't. Again, we ignore this
769 "problem", because being scrupulous would lose an important transformation for
775 Non-recursive newtypes are transparent, and should not get in the way.
776 We do (currently) eta-expand recursive newtypes too. So if we have, say
778 newtype T = MkT ([T] -> Int)
782 where f has arity 1. Then: etaExpandArity e = 1;
783 that is, etaExpandArity looks through the coerce.
785 When we eta-expand e to arity 1: eta_expand 1 e T
786 we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
788 HOWEVER, note that if you use coerce bogusly you can ge
790 And since negate has arity 2, you might try to eta expand. But you can't
791 decopose Int to a function type. Hence the final case in eta_expand.
795 exprEtaExpandArity e = arityDepth (arityType e)
797 -- A limited sort of function type
798 data ArityType = AFun Bool ArityType -- True <=> one-shot
799 | ATop -- Know nothing
802 arityDepth :: ArityType -> Arity
803 arityDepth (AFun _ ty) = 1 + arityDepth ty
806 andArityType ABot at2 = at2
807 andArityType ATop at2 = ATop
808 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
809 andArityType at1 at2 = andArityType at2 at1
811 arityType :: CoreExpr -> ArityType
812 -- (go1 e) = [b1,..,bn]
813 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
814 -- where bi is True <=> the lambda is one-shot
816 arityType (Note n e) = arityType e
817 -- Not needed any more: etaExpand is cleverer
818 -- | ok_note n = arityType e
819 -- | otherwise = ATop
822 = mk (idArity v) (arg_tys (idType v))
824 mk :: Arity -> [Type] -> ArityType
825 -- The argument types are only to steer the "state hack"
826 -- Consider case x of
828 -- False -> \(s:RealWorld) -> e
829 -- where foo has arity 1. Then we want the state hack to
830 -- apply to foo too, so we can eta expand the case.
831 mk 0 tys | isBottomingId v = ABot
833 mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
834 mk n [] = AFun False (mk (n-1) [])
836 arg_tys :: Type -> [Type] -- Ignore for-alls
838 | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
839 | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
842 -- Lambdas; increase arity
843 arityType (Lam x e) | isId x = AFun (isOneShotBndr x) (arityType e)
844 | otherwise = arityType e
846 -- Applications; decrease arity
847 arityType (App f (Type _)) = arityType f
848 arityType (App f a) = case arityType f of
849 AFun one_shot xs | exprIsCheap a -> xs
852 -- Case/Let; keep arity if either the expression is cheap
853 -- or it's a 1-shot lambda
854 -- The former is not really right for Haskell
855 -- f x = case x of { (a,b) -> \y. e }
857 -- f x y = case x of { (a,b) -> e }
858 -- The difference is observable using 'seq'
859 arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
860 xs@(AFun one_shot _) | one_shot -> xs
861 xs | exprIsCheap scrut -> xs
864 arityType (Let b e) = case arityType e of
865 xs@(AFun one_shot _) | one_shot -> xs
866 xs | all exprIsCheap (rhssOfBind b) -> xs
869 arityType other = ATop
871 {- NOT NEEDED ANY MORE: etaExpand is cleverer
872 ok_note InlineMe = False
874 -- Notice that we do not look through __inline_me__
875 -- This may seem surprising, but consider
876 -- f = _inline_me (\x -> e)
877 -- We DO NOT want to eta expand this to
878 -- f = \x -> (_inline_me (\x -> e)) x
879 -- because the _inline_me gets dropped now it is applied,
888 etaExpand :: Arity -- Result should have this number of value args
890 -> CoreExpr -> Type -- Expression and its type
892 -- (etaExpand n us e ty) returns an expression with
893 -- the same meaning as 'e', but with arity 'n'.
895 -- Given e' = etaExpand n us e ty
897 -- ty = exprType e = exprType e'
899 -- Note that SCCs are not treated specially. If we have
900 -- etaExpand 2 (\x -> scc "foo" e)
901 -- = (\xy -> (scc "foo" e) y)
902 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
904 etaExpand n us expr ty
905 | manifestArity expr >= n = expr -- The no-op case
906 | otherwise = eta_expand n us expr ty
909 -- manifestArity sees how many leading value lambdas there are
910 manifestArity :: CoreExpr -> Arity
911 manifestArity (Lam v e) | isId v = 1 + manifestArity e
912 | otherwise = manifestArity e
913 manifestArity (Note _ e) = manifestArity e
916 -- etaExpand deals with for-alls. For example:
918 -- where E :: forall a. a -> a
920 -- (/\b. \y::a -> E b y)
922 -- It deals with coerces too, though they are now rare
923 -- so perhaps the extra code isn't worth it
925 eta_expand n us expr ty
927 -- The ILX code generator requires eta expansion for type arguments
928 -- too, but alas the 'n' doesn't tell us how many of them there
929 -- may be. So we eagerly eta expand any big lambdas, and just
930 -- cross our fingers about possible loss of sharing in the ILX case.
931 -- The Right Thing is probably to make 'arity' include
932 -- type variables throughout the compiler. (ToDo.)
934 -- Saturated, so nothing to do
937 -- Short cut for the case where there already
938 -- is a lambda; no point in gratuitously adding more
939 eta_expand n us (Lam v body) ty
941 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
944 = Lam v (eta_expand (n-1) us body (funResultTy ty))
946 -- We used to have a special case that stepped inside Coerces here,
947 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
948 -- = Note note (eta_expand n us e ty)
949 -- BUT this led to an infinite loop
950 -- Example: newtype T = MkT (Int -> Int)
951 -- eta_expand 1 (coerce (Int->Int) e)
952 -- --> coerce (Int->Int) (eta_expand 1 T e)
954 -- --> coerce (Int->Int) (coerce T
955 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
956 -- by the splitNewType_maybe case below
959 eta_expand n us expr ty
960 = case splitForAllTy_maybe ty of {
961 Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
965 case splitFunTy_maybe ty of {
966 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
968 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
974 -- newtype T = MkT ([T] -> Int)
975 -- Consider eta-expanding this
978 -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
979 -- Only try this for recursive newtypes; the non-recursive kind
980 -- are transparent anyway
982 case splitRecNewType_maybe ty of {
983 Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
986 -- We have an expression of arity > 0, but its type isn't a function
987 -- This *can* legitmately happen: e.g. coerce Int (\x. x)
988 -- Essentially the programmer is playing fast and loose with types
989 -- (Happy does this a lot). So we simply decline to eta-expand.
994 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
995 It tells how many things the expression can be applied to before doing
996 any work. It doesn't look inside cases, lets, etc. The idea is that
997 exprEtaExpandArity will do the hard work, leaving something that's easy
998 for exprArity to grapple with. In particular, Simplify uses exprArity to
999 compute the ArityInfo for the Id.
1001 Originally I thought that it was enough just to look for top-level lambdas, but
1002 it isn't. I've seen this
1004 foo = PrelBase.timesInt
1006 We want foo to get arity 2 even though the eta-expander will leave it
1007 unchanged, in the expectation that it'll be inlined. But occasionally it
1008 isn't, because foo is blacklisted (used in a rule).
1010 Similarly, see the ok_note check in exprEtaExpandArity. So
1011 f = __inline_me (\x -> e)
1012 won't be eta-expanded.
1014 And in any case it seems more robust to have exprArity be a bit more intelligent.
1015 But note that (\x y z -> f x y z)
1016 should have arity 3, regardless of f's arity.
1019 exprArity :: CoreExpr -> Arity
1022 go (Var v) = idArity v
1023 go (Lam x e) | isId x = go e + 1
1025 go (Note n e) = go e
1026 go (App e (Type t)) = go e
1027 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
1028 -- NB: exprIsCheap a!
1029 -- f (fac x) does not have arity 2,
1030 -- even if f has arity 3!
1031 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
1032 -- unknown, hence arity 0
1036 %************************************************************************
1038 \subsection{Equality}
1040 %************************************************************************
1042 @cheapEqExpr@ is a cheap equality test which bales out fast!
1043 True => definitely equal
1044 False => may or may not be equal
1047 cheapEqExpr :: Expr b -> Expr b -> Bool
1049 cheapEqExpr (Var v1) (Var v2) = v1==v2
1050 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1051 cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
1053 cheapEqExpr (App f1 a1) (App f2 a2)
1054 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1056 cheapEqExpr _ _ = False
1058 exprIsBig :: Expr b -> Bool
1059 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1060 exprIsBig (Lit _) = False
1061 exprIsBig (Var v) = False
1062 exprIsBig (Type t) = False
1063 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1064 exprIsBig other = True
1069 tcEqExpr :: CoreExpr -> CoreExpr -> Bool
1070 -- Used in rule matching, so does *not* look through
1071 -- newtypes, predicate types; hence tcEqExpr
1073 tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
1075 rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
1077 tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
1078 tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
1079 tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2
1080 tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
1081 tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
1082 tcEqExprX env (Let (NonRec v1 r1) e1)
1083 (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
1084 && tcEqExprX (rnBndr2 env v1 v2) e1 e2
1085 tcEqExprX env (Let (Rec ps1) e1)
1086 (Let (Rec ps2) e2) = equalLength ps1 ps2
1087 && and (zipWith eq_rhs ps1 ps2)
1088 && tcEqExprX env' e1 e2
1090 env' = foldl2 rn_bndr2 env ps2 ps2
1091 rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
1092 eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
1093 tcEqExprX env (Case e1 v1 t1 a1)
1094 (Case e2 v2 t2 a2) = tcEqExprX env e1 e2
1095 && tcEqTypeX env t1 t2
1096 && equalLength a1 a2
1097 && and (zipWith (eq_alt env') a1 a2)
1099 env' = rnBndr2 env v1 v2
1101 tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
1102 tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
1103 tcEqExprX env e1 e2 = False
1105 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
1107 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1108 eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2
1109 eq_note env InlineCall InlineCall = True
1110 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1111 eq_note env other1 other2 = False
1115 %************************************************************************
1117 \subsection{The size of an expression}
1119 %************************************************************************
1122 coreBindsSize :: [CoreBind] -> Int
1123 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1125 exprSize :: CoreExpr -> Int
1126 -- A measure of the size of the expressions
1127 -- It also forces the expression pretty drastically as a side effect
1128 exprSize (Var v) = v `seq` 1
1129 exprSize (Lit lit) = lit `seq` 1
1130 exprSize (App f a) = exprSize f + exprSize a
1131 exprSize (Lam b e) = varSize b + exprSize e
1132 exprSize (Let b e) = bindSize b + exprSize e
1133 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1134 exprSize (Note n e) = noteSize n + exprSize e
1135 exprSize (Type t) = seqType t `seq` 1
1137 noteSize (SCC cc) = cc `seq` 1
1138 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1139 noteSize InlineCall = 1
1140 noteSize InlineMe = 1
1141 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1143 varSize :: Var -> Int
1144 varSize b | isTyVar b = 1
1145 | otherwise = seqType (idType b) `seq`
1146 megaSeqIdInfo (idInfo b) `seq`
1149 varsSize = foldr ((+) . varSize) 0
1151 bindSize (NonRec b e) = varSize b + exprSize e
1152 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1154 pairSize (b,e) = varSize b + exprSize e
1156 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1160 %************************************************************************
1162 \subsection{Hashing}
1164 %************************************************************************
1167 hashExpr :: CoreExpr -> Int
1168 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1171 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1173 hash_expr (Note _ e) = hash_expr e
1174 hash_expr (Let (NonRec b r) e) = hashId b
1175 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1176 hash_expr (Case _ b _ _) = hashId b
1177 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1178 hash_expr (Var v) = hashId v
1179 hash_expr (Lit lit) = hashLiteral lit
1180 hash_expr (Lam b _) = hashId b
1181 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1183 fast_hash_expr (Var v) = hashId v
1184 fast_hash_expr (Lit lit) = hashLiteral lit
1185 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1186 fast_hash_expr (App f a) = fast_hash_expr a
1187 fast_hash_expr (Lam b _) = hashId b
1188 fast_hash_expr other = 1
1191 hashId id = hashName (idName id)
1194 %************************************************************************
1196 \subsection{Determining non-updatable right-hand-sides}
1198 %************************************************************************
1200 Top-level constructor applications can usually be allocated
1201 statically, but they can't if the constructor, or any of the
1202 arguments, come from another DLL (because we can't refer to static
1203 labels in other DLLs).
1205 If this happens we simply make the RHS into an updatable thunk,
1206 and 'exectute' it rather than allocating it statically.
1209 rhsIsStatic :: HomeModules -> CoreExpr -> Bool
1210 -- This function is called only on *top-level* right-hand sides
1211 -- Returns True if the RHS can be allocated statically, with
1212 -- no thunks involved at all.
1214 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1215 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1216 -- update flag on it.
1218 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1219 -- (a) a value lambda
1220 -- (b) a saturated constructor application with static args
1222 -- BUT watch out for
1223 -- (i) Any cross-DLL references kill static-ness completely
1224 -- because they must be 'executed' not statically allocated
1225 -- ("DLL" here really only refers to Windows DLLs, on other platforms,
1226 -- this is not necessary)
1228 -- (ii) We treat partial applications as redexes, because in fact we
1229 -- make a thunk for them that runs and builds a PAP
1230 -- at run-time. The only appliations that are treated as
1231 -- static are *saturated* applications of constructors.
1233 -- We used to try to be clever with nested structures like this:
1234 -- ys = (:) w ((:) w [])
1235 -- on the grounds that CorePrep will flatten ANF-ise it later.
1236 -- But supporting this special case made the function much more
1237 -- complicated, because the special case only applies if there are no
1238 -- enclosing type lambdas:
1239 -- ys = /\ a -> Foo (Baz ([] a))
1240 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1242 -- But in fact, even without -O, nested structures at top level are
1243 -- flattened by the simplifier, so we don't need to be super-clever here.
1247 -- f = \x::Int. x+7 TRUE
1248 -- p = (True,False) TRUE
1250 -- d = (fst p, False) FALSE because there's a redex inside
1251 -- (this particular one doesn't happen but...)
1253 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1254 -- n = /\a. Nil a TRUE
1256 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1259 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
1260 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1262 -- b) (C x xs), where C is a contructors is updatable if the application is
1265 -- c) don't look through unfolding of f in (f x).
1267 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1268 -- them as making the RHS re-entrant (non-updatable).
1270 rhsIsStatic hmods rhs = is_static False rhs
1272 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1275 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1277 is_static in_arg (Note (SCC _) e) = False
1278 is_static in_arg (Note _ e) = is_static in_arg e
1280 is_static in_arg (Lit lit)
1282 MachLabel _ _ -> False
1284 -- A MachLabel (foreign import "&foo") in an argument
1285 -- prevents a constructor application from being static. The
1286 -- reason is that it might give rise to unresolvable symbols
1287 -- in the object file: under Linux, references to "weak"
1288 -- symbols from the data segment give rise to "unresolvable
1289 -- relocation" errors at link time This might be due to a bug
1290 -- in the linker, but we'll work around it here anyway.
1293 is_static in_arg other_expr = go other_expr 0
1295 go (Var f) n_val_args
1296 #if mingw32_TARGET_OS
1297 | not (isDllName hmods (idName f))
1299 = saturated_data_con f n_val_args
1300 || (in_arg && n_val_args == 0)
1301 -- A naked un-applied variable is *not* deemed a static RHS
1303 -- Reason: better to update so that the indirection gets shorted
1304 -- out, and the true value will be seen
1305 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1306 -- are always updatable. If you do so, make sure that non-updatable
1307 -- ones have enough space for their static link field!
1309 go (App f a) n_val_args
1310 | isTypeArg a = go f n_val_args
1311 | not in_arg && is_static True a = go f (n_val_args + 1)
1312 -- The (not in_arg) checks that we aren't in a constructor argument;
1313 -- if we are, we don't allow (value) applications of any sort
1315 -- NB. In case you wonder, args are sometimes not atomic. eg.
1316 -- x = D# (1.0## /## 2.0##)
1317 -- can't float because /## can fail.
1319 go (Note (SCC _) f) n_val_args = False
1320 go (Note _ f) n_val_args = go f n_val_args
1322 go other n_val_args = False
1324 saturated_data_con f n_val_args
1325 = case isDataConWorkId_maybe f of
1326 Just dc -> n_val_args == dataConRepArity dc