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, exprGenerousArity,
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) -> 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 exceptoin
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
306 exprArity (Note note e) | ok_note note = exprArity e
312 exprGenerousArity :: CoreExpr -> Int -- The number of args the thing can be applied to
313 -- without doing much work
314 -- This is used when eta expanding
315 -- e ==> \xy -> e x y
317 -- It returns 1 (or more) to:
318 -- case x of p -> \s -> ...
319 -- because for I/O ish things we really want to get that \s to the top.
320 -- We are prepared to evaluate x each time round the loop in order to get that
321 -- Hence "generous" arity
323 exprGenerousArity (Var v) = arityLowerBound (getIdArity v)
324 exprGenerousArity (Note note e)
325 | ok_note note = exprGenerousArity e
326 exprGenerousArity (Lam x e)
327 | isId x = 1 + exprGenerousArity e
328 | otherwise = exprGenerousArity e
329 exprGenerousArity (Let bind body)
330 | all exprIsCheap (rhssOfBind bind) = exprGenerousArity body
331 exprGenerousArity (Case scrut _ alts)
332 | exprIsCheap scrut = min_zero [exprGenerousArity rhs | (_,_,rhs) <- alts]
333 exprGenerousArity other = 0 -- Could do better for applications
335 min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
336 min_zero (x:xs) = go x xs
338 go 0 xs = 0 -- Nothing beats zero
340 go min (x:xs) | x < min = go x xs
341 | otherwise = go min xs
343 ok_note (SCC _) = False -- (Over?) conservative
344 ok_note (TermUsg _) = False -- Doesn't matter much
346 ok_note (Coerce _ _) = True
347 -- We *do* look through coerces when getting arities.
348 -- Reason: arities are to do with *representation* and
351 ok_note InlineCall = True
352 ok_note InlineMe = False
353 -- This one is a bit more surprising, but consider
354 -- f = _inline_me (\x -> e)
355 -- We DO NOT want to eta expand this to
356 -- f = \x -> (_inline_me (\x -> e)) x
357 -- because the _inline_me gets dropped now it is applied,
364 %************************************************************************
366 \subsection{Equality}
368 %************************************************************************
370 @cheapEqExpr@ is a cheap equality test which bales out fast!
371 True => definitely equal
372 False => may or may not be equal
375 cheapEqExpr :: Expr b -> Expr b -> Bool
377 cheapEqExpr (Var v1) (Var v2) = v1==v2
378 cheapEqExpr (Con con1 args1) (Con con2 args2)
380 and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2)
382 cheapEqExpr (App f1 a1) (App f2 a2)
383 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
385 cheapEqExpr (Type t1) (Type t2) = t1 == t2
387 cheapEqExpr _ _ = False
389 exprIsBig :: Expr b -> Bool
390 -- Returns True of expressions that are too big to be compared by cheapEqExpr
391 exprIsBig (Var v) = False
392 exprIsBig (Type t) = False
393 exprIsBig (App f a) = exprIsBig f || exprIsBig a
394 exprIsBig (Con _ args) = any exprIsBig args
395 exprIsBig other = True
400 eqExpr :: CoreExpr -> CoreExpr -> Bool
401 -- Works ok at more general type, but only needed at CoreExpr
403 = eq emptyVarEnv e1 e2
405 -- The "env" maps variables in e1 to variables in ty2
406 -- So when comparing lambdas etc,
407 -- we in effect substitute v2 for v1 in e1 before continuing
408 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
409 Just v1' -> v1' == v2
412 eq env (Con c1 es1) (Con c2 es2) = c1 == c2 && eq_list env es1 es2
413 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
414 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
415 eq env (Let (NonRec v1 r1) e1)
416 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
417 eq env (Let (Rec ps1) e1)
418 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
419 and (zipWith eq_rhs ps1 ps2) &&
422 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
423 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
424 eq env (Case e1 v1 a1)
425 (Case e2 v2 a2) = eq env e1 e2 &&
426 length a1 == length a2 &&
427 and (zipWith (eq_alt env') a1 a2)
429 env' = extendVarEnv env v1 v2
431 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
432 eq env (Type t1) (Type t2) = t1 == t2
435 eq_list env [] [] = True
436 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
437 eq_list env es1 es2 = False
439 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
440 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
442 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
443 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
444 eq_note env InlineCall InlineCall = True
445 eq_note env other1 other2 = False
448 %************************************************************************
452 %************************************************************************
455 hashExpr :: CoreExpr -> Int
456 hashExpr e = abs (hash_expr e)
457 -- Negative numbers kill UniqFM
459 hash_expr (Note _ e) = hash_expr e
460 hash_expr (Let (NonRec b r) e) = hashId b
461 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
462 hash_expr (Case _ b _) = hashId b
463 hash_expr (App f e) = hash_expr f + fast_hash_expr e
464 hash_expr (Var v) = hashId v
465 hash_expr (Con con args) = foldr ((+) . fast_hash_expr) (hashCon con) args
466 hash_expr (Lam b _) = hashId b
467 hash_expr (Type t) = trace "hash_expr: type" 0 -- Shouldn't happen
469 fast_hash_expr (Var v) = hashId v
470 fast_hash_expr (Con con args) = fast_hash_args args con
471 fast_hash_expr (App f (Type _)) = fast_hash_expr f
472 fast_hash_expr (App f a) = fast_hash_expr a
473 fast_hash_expr (Lam b _) = hashId b
474 fast_hash_expr other = 0
476 fast_hash_args [] con = hashCon con
477 fast_hash_args (Type t : args) con = fast_hash_args args con
478 fast_hash_args (arg : args) con = fast_hash_expr arg
481 hashId id = hashName (idName id)