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)
108 %************************************************************************
110 \subsection{Figuring out things about expressions}
112 %************************************************************************
114 @exprIsTrivial@ is true of expressions we are unconditionally
115 happy to duplicate; simple variables and constants,
116 and type applications.
118 @exprIsBottom@ is true of expressions that are guaranteed to diverge
122 exprIsTrivial (Type _) = True
123 exprIsTrivial (Var v) = True
124 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
125 exprIsTrivial (Note _ e) = exprIsTrivial e
126 exprIsTrivial (Con con args) = conIsTrivial con && all isTypeArg args
127 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
128 exprIsTrivial other = False
132 @exprIsDupable@ is true of expressions that can be duplicated at a modest
133 cost in code size. This will only happen in different case
134 branches, so there's no issue about duplicating work.
136 That is, exprIsDupable returns True of (f x) even if
137 f is very very expensive to call.
139 Its only purpose is to avoid fruitless let-binding
140 and then inlining of case join points
144 exprIsDupable (Type _) = True
145 exprIsDupable (Con con args) = conIsDupable con &&
146 all exprIsDupable args &&
147 valArgCount args <= dupAppSize
149 exprIsDupable (Note _ e) = exprIsDupable e
150 exprIsDupable expr = case collectArgs expr of
151 (Var f, args) -> all exprIsDupable args && valArgCount args <= dupAppSize
155 dupAppSize = 4 -- Size of application we are prepared to duplicate
158 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
159 it is obviously in weak head normal form, or is cheap to get to WHNF.
160 [Note that that's not the same as exprIsDupable; an expression might be
161 big, and hence not dupable, but still cheap.]
163 By ``cheap'' we mean a computation we're willing to:
164 push inside a lambda, or
165 inline at more than one place
166 That might mean it gets evaluated more than once, instead of being
167 shared. The main examples of things which aren't WHNF but are
173 where e, and all the ei are cheap; and
178 where e and b are cheap; and
182 where op is a cheap primitive operator
186 Notice that a variable is considered 'cheap': we can push it inside a lambda,
187 because sharing will make sure it is only evaluated once.
190 exprIsCheap :: CoreExpr -> Bool
191 exprIsCheap (Type _) = True
192 exprIsCheap (Var _) = True
193 exprIsCheap (Con con args) = conIsCheap con && all exprIsCheap args
194 exprIsCheap (Note _ e) = exprIsCheap e
195 exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
196 exprIsCheap other_expr -- look for manifest partial application
197 = case collectArgs other_expr of
198 (f, args) -> isPap f (valArgCount args) && all exprIsCheap args
202 isPap :: CoreExpr -- Function
203 -> Int -- Number of value args
205 isPap (Var f) n_val_args
206 = idAppIsBottom f n_val_args
207 -- Application of a function which
208 -- always gives bottom; we treat this as
209 -- a WHNF, because it certainly doesn't
210 -- need to be shared!
212 || n_val_args == 0 -- Just a type application of
213 -- a variable (f t1 t2 t3)
216 || n_val_args < arityLowerBound (getIdArity f)
218 isPap fun n_val_args = False
221 exprOkForSpeculation returns True of an expression that it is
223 * safe to evaluate even if normal order eval might not
224 evaluate the expression at all, or
226 * safe *not* to evaluate even if normal order would do so
230 the expression guarantees to terminate,
232 without raising an exception,
233 without causing a side effect (e.g. writing a mutable variable)
236 let x = case y# +# 1# of { r# -> I# r# }
239 case y# +# 1# of { r# ->
244 We can only do this if the (y+1) is ok for speculation: it has no
245 side effects, and can't diverge or raise an exception.
248 exprOkForSpeculation :: CoreExpr -> Bool
249 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
250 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
252 exprOkForSpeculation (Con con args)
253 = conOkForSpeculation con &&
254 and (zipWith ok (filter isValArg args) (fst (conStrictness con)))
256 ok arg demand | isLazy demand = True
257 | otherwise = exprOkForSpeculation arg
259 exprOkForSpeculation other = False -- Conservative
264 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
265 exprIsBottom e = go 0 e
267 -- n is the number of args
268 go n (Note _ e) = go n e
269 go n (Let _ e) = go n e
270 go n (Case e _ _) = go 0 e -- Just check the scrut
271 go n (App e _) = go (n+1) e
272 go n (Var v) = idAppIsBottom v n
273 go n (Con _ _) = False
274 go n (Lam _ _) = False
277 @exprIsValue@ returns true for expressions that are certainly *already*
278 evaluated to WHNF. This is used to decide wether it's ok to change
279 case x of _ -> e ===> e
281 and to decide whether it's safe to discard a `seq`
283 So, it does *not* treat variables as evaluated, unless they say they are
286 exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
287 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
289 exprIsValue (Var v) = isEvaldUnfolding (getIdUnfolding v)
290 exprIsValue (Lam b e) = isId b || exprIsValue e
291 exprIsValue (Note _ e) = exprIsValue e
292 exprIsValue (Let _ e) = False
293 exprIsValue (Case _ _ _) = False
294 exprIsValue (Con con _) = isWHNFCon con
295 exprIsValue e@(App _ _) = case collectArgs e of
296 (Var v, args) -> fun_arity > valArgCount args
298 fun_arity = arityLowerBound (getIdArity v)
303 exprArity :: CoreExpr -> Int -- How many value lambdas are at the top
304 exprArity (Lam b e) | isTyVar b = exprArity e
305 | otherwise = 1 + exprArity e
307 exprArity (Note note e) | ok_note note = exprArity e
309 ok_note (Coerce _ _) = True
310 -- We *do* look through coerces when getting arities.
311 -- Reason: arities are to do with *representation* and
313 ok_note InlineMe = True
314 ok_note InlineCall = True
315 ok_note other = False
316 -- SCC and TermUsg might be over-conservative?
323 exprEtaExpandArity :: CoreExpr -> Int -- The number of args the thing can be applied to
324 -- without doing much work
325 -- This is used when eta expanding
326 -- e ==> \xy -> e x y
328 -- It returns 1 (or more) to:
329 -- case x of p -> \s -> ...
330 -- because for I/O ish things we really want to get that \s to the top.
331 -- We are prepared to evaluate x each time round the loop in order to get that
332 -- Hence "generous" arity
334 exprEtaExpandArity (Var v) = arityLowerBound (getIdArity v)
335 exprEtaExpandArity (Lam x e)
336 | isId x = 1 + exprEtaExpandArity e
337 | otherwise = exprEtaExpandArity e
338 exprEtaExpandArity (Let bind body)
339 | all exprIsCheap (rhssOfBind bind) = exprEtaExpandArity body
340 exprEtaExpandArity (Case scrut _ alts)
341 | exprIsCheap scrut = min_zero [exprEtaExpandArity rhs | (_,_,rhs) <- alts]
343 exprEtaExpandArity (Note note e)
344 | ok_note note = exprEtaExpandArity e
346 ok_note (Coerce _ _) = True
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 exprEtaExpandArity other = 0 -- Could do better for applications
361 min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
362 min_zero (x:xs) = go x xs
364 go 0 xs = 0 -- Nothing beats zero
366 go min (x:xs) | x < min = go x xs
367 | otherwise = go min xs
372 %************************************************************************
374 \subsection{Equality}
376 %************************************************************************
378 @cheapEqExpr@ is a cheap equality test which bales out fast!
379 True => definitely equal
380 False => may or may not be equal
383 cheapEqExpr :: Expr b -> Expr b -> Bool
385 cheapEqExpr (Var v1) (Var v2) = v1==v2
386 cheapEqExpr (Con con1 args1) (Con con2 args2)
388 and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2)
390 cheapEqExpr (App f1 a1) (App f2 a2)
391 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
393 cheapEqExpr (Type t1) (Type t2) = t1 == t2
395 cheapEqExpr _ _ = False
397 exprIsBig :: Expr b -> Bool
398 -- Returns True of expressions that are too big to be compared by cheapEqExpr
399 exprIsBig (Var v) = False
400 exprIsBig (Type t) = False
401 exprIsBig (App f a) = exprIsBig f || exprIsBig a
402 exprIsBig (Con _ args) = any exprIsBig args
403 exprIsBig other = True
408 eqExpr :: CoreExpr -> CoreExpr -> Bool
409 -- Works ok at more general type, but only needed at CoreExpr
411 = eq emptyVarEnv e1 e2
413 -- The "env" maps variables in e1 to variables in ty2
414 -- So when comparing lambdas etc,
415 -- we in effect substitute v2 for v1 in e1 before continuing
416 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
417 Just v1' -> v1' == v2
420 eq env (Con c1 es1) (Con c2 es2) = c1 == c2 && eq_list env es1 es2
421 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
422 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
423 eq env (Let (NonRec v1 r1) e1)
424 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
425 eq env (Let (Rec ps1) e1)
426 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
427 and (zipWith eq_rhs ps1 ps2) &&
430 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
431 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
432 eq env (Case e1 v1 a1)
433 (Case e2 v2 a2) = eq env e1 e2 &&
434 length a1 == length a2 &&
435 and (zipWith (eq_alt env') a1 a2)
437 env' = extendVarEnv env v1 v2
439 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
440 eq env (Type t1) (Type t2) = t1 == t2
443 eq_list env [] [] = True
444 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
445 eq_list env es1 es2 = False
447 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
448 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
450 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
451 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
452 eq_note env InlineCall InlineCall = True
453 eq_note env other1 other2 = False
456 %************************************************************************
460 %************************************************************************
463 hashExpr :: CoreExpr -> Int
464 hashExpr e = abs (hash_expr e)
465 -- Negative numbers kill UniqFM
467 hash_expr (Note _ e) = hash_expr e
468 hash_expr (Let (NonRec b r) e) = hashId b
469 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
470 hash_expr (Case _ b _) = hashId b
471 hash_expr (App f e) = hash_expr f + fast_hash_expr e
472 hash_expr (Var v) = hashId v
473 hash_expr (Con con args) = foldr ((+) . fast_hash_expr) (hashCon con) args
474 hash_expr (Lam b _) = hashId b
475 hash_expr (Type t) = trace "hash_expr: type" 0 -- Shouldn't happen
477 fast_hash_expr (Var v) = hashId v
478 fast_hash_expr (Con con args) = fast_hash_args args con
479 fast_hash_expr (App f (Type _)) = fast_hash_expr f
480 fast_hash_expr (App f a) = fast_hash_expr a
481 fast_hash_expr (Lam b _) = hashId b
482 fast_hash_expr other = 0
484 fast_hash_args [] con = hashCon con
485 fast_hash_args (Type t : args) con = fast_hash_args args con
486 fast_hash_args (arg : args) con = fast_hash_expr arg
489 hashId id = hashName (idName id)