2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
8 coreExprType, coreAltsType,
10 exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
12 exprOkForSpeculation, exprIsBig, hashExpr,
13 exprArity, exprEtaExpandArity,
14 cheapEqExpr, eqExpr, applyTypeToArgs
17 #include "HsVersions.h"
20 import {-# SOURCE #-} CoreUnfold ( isEvaldUnfolding )
22 import GlaExts -- For `xori`
25 import PprCore ( pprCoreExpr )
26 import Var ( IdOrTyVar, isId, isTyVar )
29 import Name ( isLocallyDefined, hashName )
30 import Const ( Con, isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
31 conType, conOkForSpeculation, conStrictness, hashCon
33 import Id ( Id, idType, setIdType, idUnique, idAppIsBottom,
35 getIdSpecialisation, setIdSpecialisation,
36 getInlinePragma, setInlinePragma,
37 getIdUnfolding, setIdUnfolding, idInfo
39 import IdInfo ( arityLowerBound, InlinePragInfo(..), lbvarInfo, LBVarInfo(..) )
40 import Type ( Type, mkFunTy, mkForAllTy,
41 splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
42 isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
43 tidyTyVar, applyTys, isUnLiftedType
45 import Demand ( isPrim, isLazy )
46 import Unique ( buildIdKey, augmentIdKey )
47 import Util ( zipWithEqual, mapAccumL )
49 import TysPrim ( alphaTy ) -- Debugging only
53 %************************************************************************
55 \subsection{Find the type of a Core atom/expression}
57 %************************************************************************
60 coreExprType :: CoreExpr -> Type
62 coreExprType (Var var) = idType var
63 coreExprType (Let _ body) = coreExprType body
64 coreExprType (Case _ _ alts) = coreAltsType alts
65 coreExprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
66 coreExprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (coreExprType e))
67 coreExprType (Note other_note e) = coreExprType e
68 coreExprType e@(Con con args) = ASSERT2( all (\ a -> case a of { Type ty -> isNotUsgTy ty; _ -> True }) args, ppr e)
69 applyTypeToArgs e (conType con) args
71 coreExprType (Lam binder expr)
72 | isId binder = (case (lbvarInfo . idInfo) binder of
73 IsOneShotLambda -> mkUsgTy UsOnce
75 idType binder `mkFunTy` coreExprType expr
76 | isTyVar binder = mkForAllTy binder (coreExprType expr)
78 coreExprType e@(App _ _)
79 = case collectArgs e of
80 (fun, args) -> applyTypeToArgs e (coreExprType fun) args
82 coreExprType other = pprTrace "coreExprType" (pprCoreExpr other) alphaTy
84 coreAltsType :: [CoreAlt] -> Type
85 coreAltsType ((_,_,rhs) : _) = coreExprType rhs
89 -- The first argument is just for debugging
90 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
91 applyTypeToArgs e op_ty [] = op_ty
93 applyTypeToArgs e op_ty (Type ty : args)
94 = -- Accumulate type arguments so we can instantiate all at once
95 ASSERT2( all isNotUsgTy tys, ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+> ppr (Type ty : args) <+> text "i.e." <+> ppr tys )
96 applyTypeToArgs e (applyTys op_ty tys) rest_args
98 (tys, rest_args) = go [ty] args
99 go tys (Type ty : args) = go (ty:tys) args
100 go tys rest_args = (reverse tys, rest_args)
102 applyTypeToArgs e op_ty (other_arg : args)
103 = case (splitFunTy_maybe op_ty) of
104 Just (_, res_ty) -> applyTypeToArgs e res_ty args
105 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
109 %************************************************************************
111 \subsection{Figuring out things about expressions}
113 %************************************************************************
115 @exprIsTrivial@ is true of expressions we are unconditionally
116 happy to duplicate; simple variables and constants,
117 and type applications.
119 @exprIsBottom@ is true of expressions that are guaranteed to diverge
123 exprIsTrivial (Type _) = True
124 exprIsTrivial (Var v) = True
125 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
126 exprIsTrivial (Note _ e) = exprIsTrivial e
127 exprIsTrivial (Con con args) = conIsTrivial con && all isTypeArg args
128 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
129 exprIsTrivial other = False
133 @exprIsDupable@ is true of expressions that can be duplicated at a modest
134 cost in code size. This will only happen in different case
135 branches, so there's no issue about duplicating work.
137 That is, exprIsDupable returns True of (f x) even if
138 f is very very expensive to call.
140 Its only purpose is to avoid fruitless let-binding
141 and then inlining of case join points
145 exprIsDupable (Type _) = True
146 exprIsDupable (Con con args) = conIsDupable con &&
147 all exprIsDupable args &&
148 valArgCount args <= dupAppSize
150 exprIsDupable (Note _ e) = exprIsDupable e
151 exprIsDupable expr = case collectArgs expr of
152 (Var f, args) -> all exprIsDupable args && valArgCount args <= dupAppSize
156 dupAppSize = 4 -- Size of application we are prepared to duplicate
159 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
160 it is obviously in weak head normal form, or is cheap to get to WHNF.
161 [Note that that's not the same as exprIsDupable; an expression might be
162 big, and hence not dupable, but still cheap.]
164 By ``cheap'' we mean a computation we're willing to:
165 push inside a lambda, or
166 inline at more than one place
167 That might mean it gets evaluated more than once, instead of being
168 shared. The main examples of things which aren't WHNF but are
174 where e, and all the ei are cheap; and
179 where e and b are cheap; and
183 where op is a cheap primitive operator
187 Notice that a variable is considered 'cheap': we can push it inside a lambda,
188 because sharing will make sure it is only evaluated once.
191 exprIsCheap :: CoreExpr -> Bool
192 exprIsCheap (Type _) = True
193 exprIsCheap (Var _) = True
194 exprIsCheap (Con con args) = conIsCheap con && all exprIsCheap args
195 exprIsCheap (Note _ e) = exprIsCheap e
196 exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
197 exprIsCheap other_expr -- look for manifest partial application
198 = case collectArgs other_expr of
199 (f, args) -> isPap f (valArgCount args) && all exprIsCheap args
203 isPap :: CoreExpr -- Function
204 -> Int -- Number of value args
206 isPap (Var f) n_val_args
207 = idAppIsBottom f n_val_args
208 -- Application of a function which
209 -- always gives bottom; we treat this as
210 -- a WHNF, because it certainly doesn't
211 -- need to be shared!
213 || n_val_args == 0 -- Just a type application of
214 -- a variable (f t1 t2 t3)
217 || n_val_args < arityLowerBound (getIdArity f)
219 isPap fun n_val_args = False
222 exprOkForSpeculation returns True of an expression that it is
224 * safe to evaluate even if normal order eval might not
225 evaluate the expression at all, or
227 * safe *not* to evaluate even if normal order would do so
231 the expression guarantees to terminate,
233 without raising an exception,
234 without causing a side effect (e.g. writing a mutable variable)
237 let x = case y# +# 1# of { r# -> I# r# }
240 case y# +# 1# of { r# ->
245 We can only do this if the (y+1) is ok for speculation: it has no
246 side effects, and can't diverge or raise an exception.
249 exprOkForSpeculation :: CoreExpr -> Bool
250 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
251 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
253 exprOkForSpeculation (Con con args)
254 = conOkForSpeculation con &&
255 and (zipWith ok (filter isValArg args) (fst (conStrictness con)))
257 ok arg demand | isLazy demand = True
258 | otherwise = exprOkForSpeculation arg
260 exprOkForSpeculation other = False -- Conservative
265 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
266 exprIsBottom e = go 0 e
268 -- n is the number of args
269 go n (Note _ e) = go n e
270 go n (Let _ e) = go n e
271 go n (Case e _ _) = go 0 e -- Just check the scrut
272 go n (App e _) = go (n+1) e
273 go n (Var v) = idAppIsBottom v n
274 go n (Con _ _) = False
275 go n (Lam _ _) = False
278 @exprIsValue@ returns true for expressions that are certainly *already*
279 evaluated to WHNF. This is used to decide wether it's ok to change
280 case x of _ -> e ===> e
282 and to decide whether it's safe to discard a `seq`
284 So, it does *not* treat variables as evaluated, unless they say they are
287 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
288 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
290 exprIsValue (Var v) = isEvaldUnfolding (getIdUnfolding v)
291 exprIsValue (Lam b e) = isId b || exprIsValue e
292 exprIsValue (Note _ e) = exprIsValue e
293 exprIsValue (Let _ e) = False
294 exprIsValue (Case _ _ _) = False
295 exprIsValue (Con con _) = isWHNFCon con
296 exprIsValue e@(App _ _) = case collectArgs e of
297 (Var v, args) -> fun_arity > valArgCount args
299 fun_arity = arityLowerBound (getIdArity v)
304 exprArity :: CoreExpr -> Int -- How many value lambdas are at the top
305 exprArity (Lam b e) | isTyVar b = exprArity e
306 | otherwise = 1 + exprArity e
308 exprArity (Note note e) | ok_note note = exprArity e
310 ok_note (Coerce _ _) = True
311 -- We *do* look through coerces when getting arities.
312 -- Reason: arities are to do with *representation* and
314 ok_note InlineMe = True
315 ok_note InlineCall = True
316 ok_note other = False
317 -- SCC and TermUsg might be over-conservative?
324 exprEtaExpandArity :: CoreExpr -> Int -- The number of args the thing can be applied to
325 -- without doing much work
326 -- This is used when eta expanding
327 -- e ==> \xy -> e x y
329 -- It returns 1 (or more) to:
330 -- case x of p -> \s -> ...
331 -- because for I/O ish things we really want to get that \s to the top.
332 -- We are prepared to evaluate x each time round the loop in order to get that
333 -- Hence "generous" arity
335 exprEtaExpandArity (Var v) = arityLowerBound (getIdArity v)
336 exprEtaExpandArity (Lam x e)
337 | isId x = 1 + exprEtaExpandArity e
338 | otherwise = exprEtaExpandArity e
339 exprEtaExpandArity (Let bind body)
340 | all exprIsCheap (rhssOfBind bind) = exprEtaExpandArity body
341 exprEtaExpandArity (Case scrut _ alts)
342 | exprIsCheap scrut = min_zero [exprEtaExpandArity rhs | (_,_,rhs) <- alts]
344 exprEtaExpandArity (Note note e)
345 | ok_note note = exprEtaExpandArity e
347 ok_note InlineCall = True
348 ok_note other = False
349 -- Notice that we do not look through __inline_me__
350 -- This one is a bit more surprising, but consider
351 -- f = _inline_me (\x -> e)
352 -- We DO NOT want to eta expand this to
353 -- f = \x -> (_inline_me (\x -> e)) x
354 -- because the _inline_me gets dropped now it is applied,
359 -- Notice also that we don't look through Coerce
360 -- This is simply because the etaExpand code in SimplUtils
361 -- isn't capable of making the alternating lambdas and coerces
362 -- that would be necessary to exploit it
364 exprEtaExpandArity other = 0 -- Could do better for applications
366 min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
367 min_zero (x:xs) = go x xs
369 go 0 xs = 0 -- Nothing beats zero
371 go min (x:xs) | x < min = go x xs
372 | otherwise = go min xs
377 %************************************************************************
379 \subsection{Equality}
381 %************************************************************************
383 @cheapEqExpr@ is a cheap equality test which bales out fast!
384 True => definitely equal
385 False => may or may not be equal
388 cheapEqExpr :: Expr b -> Expr b -> Bool
390 cheapEqExpr (Var v1) (Var v2) = v1==v2
391 cheapEqExpr (Con con1 args1) (Con con2 args2)
393 and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2)
395 cheapEqExpr (App f1 a1) (App f2 a2)
396 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
398 cheapEqExpr (Type t1) (Type t2) = t1 == t2
400 cheapEqExpr _ _ = False
402 exprIsBig :: Expr b -> Bool
403 -- Returns True of expressions that are too big to be compared by cheapEqExpr
404 exprIsBig (Var v) = False
405 exprIsBig (Type t) = False
406 exprIsBig (App f a) = exprIsBig f || exprIsBig a
407 exprIsBig (Con _ args) = any exprIsBig args
408 exprIsBig other = True
413 eqExpr :: CoreExpr -> CoreExpr -> Bool
414 -- Works ok at more general type, but only needed at CoreExpr
416 = eq emptyVarEnv e1 e2
418 -- The "env" maps variables in e1 to variables in ty2
419 -- So when comparing lambdas etc,
420 -- we in effect substitute v2 for v1 in e1 before continuing
421 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
422 Just v1' -> v1' == v2
425 eq env (Con c1 es1) (Con c2 es2) = c1 == c2 && eq_list env es1 es2
426 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
427 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
428 eq env (Let (NonRec v1 r1) e1)
429 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
430 eq env (Let (Rec ps1) e1)
431 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
432 and (zipWith eq_rhs ps1 ps2) &&
435 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
436 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
437 eq env (Case e1 v1 a1)
438 (Case e2 v2 a2) = eq env e1 e2 &&
439 length a1 == length a2 &&
440 and (zipWith (eq_alt env') a1 a2)
442 env' = extendVarEnv env v1 v2
444 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
445 eq env (Type t1) (Type t2) = t1 == t2
448 eq_list env [] [] = True
449 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
450 eq_list env es1 es2 = False
452 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
453 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
455 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
456 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
457 eq_note env InlineCall InlineCall = True
458 eq_note env other1 other2 = False
461 %************************************************************************
465 %************************************************************************
468 hashExpr :: CoreExpr -> Int
469 hashExpr e = abs (hash_expr e)
470 -- Negative numbers kill UniqFM
472 hash_expr (Note _ e) = hash_expr e
473 hash_expr (Let (NonRec b r) e) = hashId b
474 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
475 hash_expr (Case _ b _) = hashId b
476 hash_expr (App f e) = hash_expr f + fast_hash_expr e
477 hash_expr (Var v) = hashId v
478 hash_expr (Con con args) = foldr ((+) . fast_hash_expr) (hashCon con) args
479 hash_expr (Lam b _) = hashId b
480 hash_expr (Type t) = trace "hash_expr: type" 0 -- Shouldn't happen
482 fast_hash_expr (Var v) = hashId v
483 fast_hash_expr (Con con args) = fast_hash_args args con
484 fast_hash_expr (App f (Type _)) = fast_hash_expr f
485 fast_hash_expr (App f a) = fast_hash_expr a
486 fast_hash_expr (Lam b _) = hashId b
487 fast_hash_expr other = 0
489 fast_hash_args [] con = hashCon con
490 fast_hash_args (Type t : args) con = fast_hash_args args con
491 fast_hash_args (arg : args) con = fast_hash_expr arg
494 hashId id = hashName (idName id)