2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 mkNote, mkInlineMe, mkSCC, mkCoerce,
10 bindNonRec, mkIfThenElse, mkAltExpr,
13 -- Properties of expressions
14 exprType, coreAltsType,
15 exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
16 exprIsValue,exprOkForSpeculation, exprIsBig,
18 idAppIsBottom, idAppIsCheap,
20 -- Expr transformation
21 etaReduceExpr, exprEtaExpandArity,
30 cheapEqExpr, eqExpr, applyTypeToArgs
33 #include "HsVersions.h"
36 import GlaExts -- For `xori`
39 import CoreFVs ( exprFreeVars )
40 import PprCore ( pprCoreExpr )
41 import Var ( Var, isId, isTyVar )
44 import Name ( hashName )
45 import Literal ( hashLiteral, literalType, litIsDupable )
46 import DataCon ( DataCon, dataConRepArity )
47 import PrimOp ( primOpOkForSpeculation, primOpIsCheap,
49 import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo,
50 mkWildId, idArity, idName, idUnfolding, idInfo,
51 isDataConId_maybe, isPrimOpId_maybe
53 import IdInfo ( LBVarInfo(..),
56 import Demand ( appIsBottom )
57 import Type ( Type, mkFunTy, mkForAllTy,
59 isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
60 applyTys, isUnLiftedType, seqType
62 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
63 import CostCentre ( CostCentre )
64 import Maybes ( maybeToBool )
66 import TysPrim ( alphaTy ) -- Debugging only
70 %************************************************************************
72 \subsection{Find the type of a Core atom/expression}
74 %************************************************************************
77 exprType :: CoreExpr -> Type
79 exprType (Var var) = idType var
80 exprType (Lit lit) = literalType lit
81 exprType (Let _ body) = exprType body
82 exprType (Case _ _ alts) = coreAltsType alts
83 exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
84 exprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (exprType e))
85 exprType (Note other_note e) = exprType e
86 exprType (Lam binder expr) = mkPiType binder (exprType expr)
88 = case collectArgs e of
89 (fun, args) -> applyTypeToArgs e (exprType fun) args
91 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
93 coreAltsType :: [CoreAlt] -> Type
94 coreAltsType ((_,_,rhs) : _) = exprType rhs
97 @mkPiType@ makes a (->) type or a forall type, depending on whether
98 it is given a type variable or a term variable. We cleverly use the
99 lbvarinfo field to figure out the right annotation for the arrove in
100 case of a term variable.
103 mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work...
104 mkPiType v ty | isId v = (case idLBVarInfo v of
105 IsOneShotLambda -> mkUsgTy UsOnce
107 mkFunTy (idType v) ty
108 | isTyVar v = mkForAllTy v ty
112 -- The first argument is just for debugging
113 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
114 applyTypeToArgs e op_ty [] = op_ty
116 applyTypeToArgs e op_ty (Type ty : args)
117 = -- Accumulate type arguments so we can instantiate all at once
118 ASSERT2( all isNotUsgTy tys,
119 ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+>
120 ppr (Type ty : args) <+> text "i.e." <+> ppr tys )
121 applyTypeToArgs e (applyTys op_ty tys) rest_args
123 (tys, rest_args) = go [ty] args
124 go tys (Type ty : args) = go (ty:tys) args
125 go tys rest_args = (reverse tys, rest_args)
127 applyTypeToArgs e op_ty (other_arg : args)
128 = case (splitFunTy_maybe op_ty) of
129 Just (_, res_ty) -> applyTypeToArgs e res_ty args
130 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
135 %************************************************************************
137 \subsection{Attaching notes}
139 %************************************************************************
141 mkNote removes redundant coercions, and SCCs where possible
144 mkNote :: Note -> CoreExpr -> CoreExpr
145 mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr
146 mkNote (SCC cc) expr = mkSCC cc expr
147 mkNote InlineMe expr = mkInlineMe expr
148 mkNote note expr = Note note expr
150 -- Slide InlineCall in around the function
151 -- No longer necessary I think (SLPJ Apr 99)
152 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
153 -- mkNote InlineCall (Var v) = Note InlineCall (Var v)
154 -- mkNote InlineCall expr = expr
157 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
158 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
159 not be *applied* to anything.
162 mkInlineMe e | exprIsTrivial e = e
163 | otherwise = Note InlineMe e
169 mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
171 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
172 = ASSERT( from_ty == to_ty2 )
173 mkCoerce to_ty from_ty2 expr
175 mkCoerce to_ty from_ty expr
176 | to_ty == from_ty = expr
177 | otherwise = ASSERT( from_ty == exprType expr )
178 Note (Coerce to_ty from_ty) expr
182 mkSCC :: CostCentre -> Expr b -> Expr b
183 -- Note: Nested SCC's *are* preserved for the benefit of
184 -- cost centre stack profiling (Durham)
186 mkSCC cc (Lit lit) = Lit lit
187 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
188 mkSCC cc expr = Note (SCC cc) expr
192 %************************************************************************
194 \subsection{Other expression construction}
196 %************************************************************************
199 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
200 -- (bindNonRec x r b) produces either
203 -- case r of x { _DEFAULT_ -> b }
205 -- depending on whether x is unlifted or not
206 -- It's used by the desugarer to avoid building bindings
207 -- that give Core Lint a heart attack. Actually the simplifier
208 -- deals with them perfectly well.
209 bindNonRec bndr rhs body
210 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
211 | otherwise = Let (NonRec bndr rhs) body
215 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
216 -- This guy constructs the value that the scrutinee must have
217 -- when you are in one particular branch of a case
218 mkAltExpr (DataAlt con) args inst_tys
219 = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
220 mkAltExpr (LitAlt lit) [] []
223 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
224 mkIfThenElse guard then_expr else_expr
225 = Case guard (mkWildId boolTy)
226 [ (DataAlt trueDataCon, [], then_expr),
227 (DataAlt falseDataCon, [], else_expr) ]
230 %************************************************************************
232 \subsection{Figuring out things about expressions}
234 %************************************************************************
236 @exprIsTrivial@ is true of expressions we are unconditionally happy to
237 duplicate; simple variables and constants, and type
238 applications. Note that primop Ids aren't considered
241 @exprIsBottom@ is true of expressions that are guaranteed to diverge
245 exprIsTrivial (Var v)
246 | Just op <- isPrimOpId_maybe v = primOpIsDupable op
248 exprIsTrivial (Type _) = True
249 exprIsTrivial (Lit lit) = True
250 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
251 exprIsTrivial (Note _ e) = exprIsTrivial e
252 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
253 exprIsTrivial other = False
257 @exprIsDupable@ is true of expressions that can be duplicated at a modest
258 cost in code size. This will only happen in different case
259 branches, so there's no issue about duplicating work.
261 That is, exprIsDupable returns True of (f x) even if
262 f is very very expensive to call.
264 Its only purpose is to avoid fruitless let-binding
265 and then inlining of case join points
269 exprIsDupable (Type _) = True
270 exprIsDupable (Var v) = True
271 exprIsDupable (Lit lit) = litIsDupable lit
272 exprIsDupable (Note _ e) = exprIsDupable e
276 go (Var v) n_args = True
277 go (App f a) n_args = n_args < dupAppSize
280 go other n_args = False
283 dupAppSize = 4 -- Size of application we are prepared to duplicate
286 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
287 it is obviously in weak head normal form, or is cheap to get to WHNF.
288 [Note that that's not the same as exprIsDupable; an expression might be
289 big, and hence not dupable, but still cheap.]
291 By ``cheap'' we mean a computation we're willing to:
292 push inside a lambda, or
293 inline at more than one place
294 That might mean it gets evaluated more than once, instead of being
295 shared. The main examples of things which aren't WHNF but are
300 (where e, and all the ei are cheap)
303 (where e and b are cheap)
306 (where op is a cheap primitive operator)
309 (because we are happy to substitute it inside a lambda)
311 Notice that a variable is considered 'cheap': we can push it inside a lambda,
312 because sharing will make sure it is only evaluated once.
315 exprIsCheap :: CoreExpr -> Bool
316 exprIsCheap (Lit lit) = True
317 exprIsCheap (Type _) = True
318 exprIsCheap (Var _) = True
319 exprIsCheap (Note _ e) = exprIsCheap e
320 exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
321 exprIsCheap (Case e _ alts) = exprIsCheap e &&
322 and [exprIsCheap rhs | (_,_,rhs) <- alts]
323 -- Experimentally, treat (case x of ...) as cheap
324 -- (and case __coerce x etc.)
325 -- This improves arities of overloaded functions where
326 -- there is only dictionary selection (no construction) involved
327 exprIsCheap (Let (NonRec x _) e)
328 | isUnLiftedType (idType x) = exprIsCheap e
330 -- strict lets always have cheap right hand sides, and
333 exprIsCheap other_expr
334 = go other_expr 0 True
336 go (Var f) n_args args_cheap
337 = (idAppIsCheap f n_args && args_cheap)
338 -- A constructor, cheap primop, or partial application
340 || idAppIsBottom f n_args
341 -- Application of a function which
342 -- always gives bottom; we treat this as cheap
343 -- because it certainly doesn't need to be shared!
345 go (App f a) n_args args_cheap
346 | isTypeArg a = go f n_args args_cheap
347 | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
349 go other n_args args_cheap = False
351 idAppIsCheap :: Id -> Int -> Bool
352 idAppIsCheap id n_val_args
353 | n_val_args == 0 = True -- Just a type application of
354 -- a variable (f t1 t2 t3)
356 | otherwise = case idFlavour id of
358 RecordSelId _ -> True -- I'm experimenting with making record selection
359 -- look cheap, so we will substitute it inside a
360 -- lambda. Particularly for dictionary field selection
362 PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
363 -- that return a type variable, since the result
364 -- might be applied to something, but I'm not going
365 -- to bother to check the number of args
366 other -> n_val_args < idArity id
369 exprOkForSpeculation returns True of an expression that it is
371 * safe to evaluate even if normal order eval might not
372 evaluate the expression at all, or
374 * safe *not* to evaluate even if normal order would do so
378 the expression guarantees to terminate,
380 without raising an exception,
381 without causing a side effect (e.g. writing a mutable variable)
384 let x = case y# +# 1# of { r# -> I# r# }
387 case y# +# 1# of { r# ->
392 We can only do this if the (y+1) is ok for speculation: it has no
393 side effects, and can't diverge or raise an exception.
396 exprOkForSpeculation :: CoreExpr -> Bool
397 exprOkForSpeculation (Lit _) = True
398 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
399 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
400 exprOkForSpeculation other_expr
401 = go other_expr 0 True
403 go (Var f) n_args args_ok
404 = case idFlavour f of
405 DataConId _ -> True -- The strictness of the constructor has already
406 -- been expressed by its "wrapper", so we don't need
407 -- to take the arguments into account
409 PrimOpId op -> primOpOkForSpeculation op && args_ok
410 -- A bit conservative: we don't really need
411 -- to care about lazy arguments, but this is easy
415 go (App f a) n_args args_ok
416 | isTypeArg a = go f n_args args_ok
417 | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
419 go other n_args args_ok = False
424 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
425 exprIsBottom e = go 0 e
427 -- n is the number of args
428 go n (Note _ e) = go n e
429 go n (Let _ e) = go n e
430 go n (Case e _ _) = go 0 e -- Just check the scrut
431 go n (App e _) = go (n+1) e
432 go n (Var v) = idAppIsBottom v n
434 go n (Lam _ _) = False
436 idAppIsBottom :: Id -> Int -> Bool
437 idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
440 @exprIsValue@ returns true for expressions that are certainly *already*
441 evaluated to WHNF. This is used to decide wether it's ok to change
442 case x of _ -> e ===> e
444 and to decide whether it's safe to discard a `seq`
446 So, it does *not* treat variables as evaluated, unless they say they are
449 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
450 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
452 exprIsValue (Lit l) = True
453 exprIsValue (Lam b e) = isId b || exprIsValue e
454 exprIsValue (Note _ e) = exprIsValue e
455 exprIsValue other_expr
458 go (Var f) n_args = idAppIsValue f n_args
461 | isTypeArg a = go f n_args
462 | otherwise = go f (n_args + 1)
464 go (Note _ f) n_args = go f n_args
466 go other n_args = False
468 idAppIsValue :: Id -> Int -> Bool
469 idAppIsValue id n_val_args
470 = case idFlavour id of
472 PrimOpId _ -> n_val_args < idArity id
473 other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
474 | otherwise -> n_val_args < idArity id
475 -- A worry: what if an Id's unfolding is just itself:
476 -- then we could get an infinite loop...
480 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
481 exprIsConApp_maybe expr
482 = analyse (collectArgs expr)
484 analyse (Var fun, args)
485 | maybeToBool maybe_con_app = maybe_con_app
487 maybe_con_app = case isDataConId_maybe fun of
488 Just con | length args >= dataConRepArity con
489 -- Might be > because the arity excludes type args
493 analyse (Var fun, [])
494 = case maybeUnfoldingTemplate (idUnfolding fun) of
496 Just unf -> exprIsConApp_maybe unf
498 analyse other = Nothing
502 %************************************************************************
504 \subsection{Eta reduction and expansion}
506 %************************************************************************
508 @etaReduceExpr@ trys an eta reduction at the top level of a Core Expr.
510 e.g. \ x y -> f x y ===> f
512 But we only do this if it gets rid of a whole lambda, not part.
513 The idea is that lambdas are often quite helpful: they indicate
514 head normal forms, so we don't want to chuck them away lightly.
517 etaReduceExpr :: CoreExpr -> CoreExpr
518 -- ToDo: we should really check that we don't turn a non-bottom
519 -- lambda into a bottom variable. Sigh
521 etaReduceExpr expr@(Lam bndr body)
522 = check (reverse binders) body
524 (binders, body) = collectBinders expr
527 | not (any (`elemVarSet` body_fvs) binders)
530 body_fvs = exprFreeVars body
532 check (b : bs) (App fun arg)
533 | (varToCoreExpr b `cheapEqExpr` arg)
536 check _ _ = expr -- Bale out
538 etaReduceExpr expr = expr -- The common case
543 exprEtaExpandArity :: CoreExpr -> Int -- The number of args the thing can be applied to
544 -- without doing much work
545 -- This is used when eta expanding
546 -- e ==> \xy -> e x y
548 -- It returns 1 (or more) to:
549 -- case x of p -> \s -> ...
550 -- because for I/O ish things we really want to get that \s to the top.
551 -- We are prepared to evaluate x each time round the loop in order to get that
552 -- Hence "generous" arity
555 = go e `max` 0 -- Never go -ve!
557 go (Var v) = idArity v
558 go (App f (Type _)) = go f
559 go (App f a) | exprIsCheap a = go f - 1
560 go (Lam x e) | isId x = go e + 1
562 go (Note n e) | ok_note n = go e
563 go (Case scrut _ alts)
564 | exprIsCheap scrut = min_zero [go rhs | (_,_,rhs) <- alts]
566 | all exprIsCheap (rhssOfBind b) = go e
570 ok_note (Coerce _ _) = True
571 ok_note InlineCall = True
572 ok_note other = False
573 -- Notice that we do not look through __inline_me__
574 -- This one is a bit more surprising, but consider
575 -- f = _inline_me (\x -> e)
576 -- We DO NOT want to eta expand this to
577 -- f = \x -> (_inline_me (\x -> e)) x
578 -- because the _inline_me gets dropped now it is applied,
583 min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
584 min_zero (x:xs) = go x xs
586 go 0 xs = 0 -- Nothing beats zero
588 go min (x:xs) | x < min = go x xs
589 | otherwise = go min xs
594 %************************************************************************
596 \subsection{Equality}
598 %************************************************************************
600 @cheapEqExpr@ is a cheap equality test which bales out fast!
601 True => definitely equal
602 False => may or may not be equal
605 cheapEqExpr :: Expr b -> Expr b -> Bool
607 cheapEqExpr (Var v1) (Var v2) = v1==v2
608 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
609 cheapEqExpr (Type t1) (Type t2) = t1 == t2
611 cheapEqExpr (App f1 a1) (App f2 a2)
612 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
614 cheapEqExpr _ _ = False
616 exprIsBig :: Expr b -> Bool
617 -- Returns True of expressions that are too big to be compared by cheapEqExpr
618 exprIsBig (Lit _) = False
619 exprIsBig (Var v) = False
620 exprIsBig (Type t) = False
621 exprIsBig (App f a) = exprIsBig f || exprIsBig a
622 exprIsBig other = True
627 eqExpr :: CoreExpr -> CoreExpr -> Bool
628 -- Works ok at more general type, but only needed at CoreExpr
630 = eq emptyVarEnv e1 e2
632 -- The "env" maps variables in e1 to variables in ty2
633 -- So when comparing lambdas etc,
634 -- we in effect substitute v2 for v1 in e1 before continuing
635 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
636 Just v1' -> v1' == v2
639 eq env (Lit lit1) (Lit lit2) = lit1 == lit2
640 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
641 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
642 eq env (Let (NonRec v1 r1) e1)
643 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
644 eq env (Let (Rec ps1) e1)
645 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
646 and (zipWith eq_rhs ps1 ps2) &&
649 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
650 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
651 eq env (Case e1 v1 a1)
652 (Case e2 v2 a2) = eq env e1 e2 &&
653 length a1 == length a2 &&
654 and (zipWith (eq_alt env') a1 a2)
656 env' = extendVarEnv env v1 v2
658 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
659 eq env (Type t1) (Type t2) = t1 == t2
662 eq_list env [] [] = True
663 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
664 eq_list env es1 es2 = False
666 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
667 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
669 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
670 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
671 eq_note env InlineCall InlineCall = True
672 eq_note env other1 other2 = False
676 %************************************************************************
678 \subsection{The size of an expression}
680 %************************************************************************
683 coreBindsSize :: [CoreBind] -> Int
684 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
686 exprSize :: CoreExpr -> Int
687 -- A measure of the size of the expressions
688 -- It also forces the expression pretty drastically as a side effect
689 exprSize (Var v) = varSize v
690 exprSize (Lit lit) = lit `seq` 1
691 exprSize (App f a) = exprSize f + exprSize a
692 exprSize (Lam b e) = varSize b + exprSize e
693 exprSize (Let b e) = bindSize b + exprSize e
694 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
695 exprSize (Note n e) = noteSize n + exprSize e
696 exprSize (Type t) = seqType t `seq` 1
698 noteSize (SCC cc) = cc `seq` 1
699 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
700 noteSize InlineCall = 1
701 noteSize InlineMe = 1
702 noteSize (TermUsg usg) = usg `seq` 1
704 varSize :: Var -> Int
705 varSize b | isTyVar b = 1
706 | otherwise = seqType (idType b) `seq`
707 megaSeqIdInfo (idInfo b) `seq`
710 varsSize = foldr ((+) . varSize) 0
712 bindSize (NonRec b e) = varSize b + exprSize e
713 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
715 pairSize (b,e) = varSize b + exprSize e
717 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
721 %************************************************************************
725 %************************************************************************
728 hashExpr :: CoreExpr -> Int
729 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
732 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
734 hash_expr (Note _ e) = hash_expr e
735 hash_expr (Let (NonRec b r) e) = hashId b
736 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
737 hash_expr (Case _ b _) = hashId b
738 hash_expr (App f e) = hash_expr f * fast_hash_expr e
739 hash_expr (Var v) = hashId v
740 hash_expr (Lit lit) = hashLiteral lit
741 hash_expr (Lam b _) = hashId b
742 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
744 fast_hash_expr (Var v) = hashId v
745 fast_hash_expr (Lit lit) = hashLiteral lit
746 fast_hash_expr (App f (Type _)) = fast_hash_expr f
747 fast_hash_expr (App f a) = fast_hash_expr a
748 fast_hash_expr (Lam b _) = hashId b
749 fast_hash_expr other = 1
752 hashId id = hashName (idName id)