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, exprIsWHNF, exprIsCheap,
12 FormSummary(..), mkFormSummary, whnfOrBottom, exprArity,
13 cheapEqExpr, eqExpr, applyTypeToArgs
16 #include "HsVersions.h"
20 import PprCore ( pprCoreExpr )
21 import Var ( IdOrTyVar, isId, isTyVar )
24 import Name ( isLocallyDefined )
25 import Const ( Con, isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
26 conType, conOkForSpeculation, conStrictness
28 import Id ( Id, idType, setIdType, idUnique, idAppIsBottom,
30 getIdSpecialisation, setIdSpecialisation,
31 getInlinePragma, setInlinePragma,
32 getIdUnfolding, setIdUnfolding, idInfo
34 import IdInfo ( arityLowerBound, InlinePragInfo(..), lbvarInfo, LBVarInfo(..) )
35 import Type ( Type, mkFunTy, mkForAllTy,
36 splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
37 isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
38 tidyTyVar, applyTys, isUnLiftedType
40 import Demand ( isPrim, isLazy )
41 import Unique ( buildIdKey, augmentIdKey )
42 import Util ( zipWithEqual, mapAccumL )
44 import TysPrim ( alphaTy ) -- Debugging only
48 %************************************************************************
50 \subsection{Find the type of a Core atom/expression}
52 %************************************************************************
55 coreExprType :: CoreExpr -> Type
57 coreExprType (Var var) = idType var
58 coreExprType (Let _ body) = coreExprType body
59 coreExprType (Case _ _ alts) = coreAltsType alts
60 coreExprType (Note (Coerce ty _) e) = ty
61 coreExprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (coreExprType e))
62 coreExprType (Note other_note e) = coreExprType e
63 coreExprType e@(Con con args) = applyTypeToArgs e (conType con) args
65 coreExprType (Lam binder expr)
66 | isId binder = (case (lbvarInfo . idInfo) binder of
67 IsOneShotLambda -> mkUsgTy UsOnce
69 idType binder `mkFunTy` coreExprType expr
70 | isTyVar binder = mkForAllTy binder (coreExprType expr)
72 coreExprType e@(App _ _)
73 = case collectArgs e of
74 (fun, args) -> applyTypeToArgs e (coreExprType fun) args
76 coreExprType other = pprTrace "coreExprType" (pprCoreExpr other) alphaTy
78 coreAltsType :: [CoreAlt] -> Type
79 coreAltsType ((_,_,rhs) : _) = coreExprType rhs
83 -- The first argument is just for debugging
84 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
85 applyTypeToArgs e op_ty [] = op_ty
87 applyTypeToArgs e op_ty (Type ty : args)
88 = -- Accumulate type arguments so we can instantiate all at once
89 ASSERT2( all isNotUsgTy tys, ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+> ppr (Type ty : args) <+> text "i.e." <+> ppr tys )
90 applyTypeToArgs e (applyTys op_ty tys) rest_args
92 (tys, rest_args) = go [ty] args
93 go tys (Type ty : args) = go (ty:tys) args
94 go tys rest_args = (reverse tys, rest_args)
96 applyTypeToArgs e op_ty (other_arg : args)
97 = case (splitFunTy_maybe op_ty) of
98 Just (_, res_ty) -> applyTypeToArgs e res_ty args
99 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
103 %************************************************************************
105 \subsection{Figuring out things about expressions}
107 %************************************************************************
111 = VarForm -- Expression is a variable (or scc var, etc)
112 | ValueForm -- Expression is a value: i.e. a value-lambda,constructor, or literal
113 | BottomForm -- Expression is guaranteed to be bottom. We're more gung
114 -- ho about inlining such things, because it can't waste work
115 | OtherForm -- Anything else
117 instance Outputable FormSummary where
118 ppr VarForm = ptext SLIT("Var")
119 ppr ValueForm = ptext SLIT("Value")
120 ppr BottomForm = ptext SLIT("Bot")
121 ppr OtherForm = ptext SLIT("Other")
123 whnfOrBottom :: FormSummary -> Bool
124 whnfOrBottom VarForm = True
125 whnfOrBottom ValueForm = True
126 whnfOrBottom BottomForm = True
127 whnfOrBottom OtherForm = False
131 mkFormSummary :: CoreExpr -> FormSummary
133 = go (0::Int) expr -- The "n" is the number of *value* arguments so far
135 go n (Con con _) | isWHNFCon con = ValueForm
136 | otherwise = OtherForm
138 go n (Note _ e) = go n e
140 go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g)
141 -- should be treated as a value
142 go n (Let _ e) = OtherForm
143 go n (Case _ _ _) = OtherForm
145 go 0 (Lam x e) | isId x = ValueForm -- NB: \x.bottom /= bottom!
147 go n (Lam x e) | isId x = go (n-1) e -- Applied lambda
150 go n (App fun (Type _)) = go n fun -- Ignore type args
151 go n (App fun arg) = go (n+1) fun
153 go n (Var f) | idAppIsBottom f n = BottomForm
154 go 0 (Var f) = VarForm
155 go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm
156 | otherwise = OtherForm
159 @exprIsTrivial@ is true of expressions we are unconditionally
160 happy to duplicate; simple variables and constants,
161 and type applications.
163 @exprIsBottom@ is true of expressions that are guaranteed to diverge
167 exprIsTrivial (Type _) = True
168 exprIsTrivial (Var v) = True
169 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
170 exprIsTrivial (Note _ e) = exprIsTrivial e
171 exprIsTrivial (Con con args) = conIsTrivial con && all isTypeArg args
172 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
173 exprIsTrivial other = False
177 @exprIsDupable@ is true of expressions that can be duplicated at a modest
178 cost in space. This will only happen in different case
179 branches, so there's no issue about duplicating work.
180 Its only purpose is to avoid fruitless let-binding
181 and then inlining of case join points
185 exprIsDupable (Type _) = True
186 exprIsDupable (Con con args) = conIsDupable con &&
187 all exprIsDupable args &&
188 valArgCount args <= dupAppSize
190 exprIsDupable (Note _ e) = exprIsDupable e
191 exprIsDupable expr = case collectArgs expr of
192 (Var f, args) -> valArgCount args <= dupAppSize
196 dupAppSize = 4 -- Size of application we are prepared to duplicate
199 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
200 it is obviously in weak head normal form, or is cheap to get to WHNF.
201 [Note that that's not the same as exprIsDupable; an expression might be
202 big, and hence not dupable, but still cheap.]
203 By ``cheap'' we mean a computation we're willing to push inside a lambda
204 in order to bring a couple of lambdas together. That might mean it gets
205 evaluated more than once, instead of being shared. The main examples of things
206 which aren't WHNF but are ``cheap'' are:
211 where e, and all the ei are cheap; and
216 where e and b are cheap; and
220 where op is a cheap primitive operator
223 exprIsCheap :: CoreExpr -> Bool
224 exprIsCheap (Type _) = True
225 exprIsCheap (Var _) = True
226 exprIsCheap (Con con args) = conIsCheap con && all exprIsCheap args
227 exprIsCheap (Note _ e) = exprIsCheap e
228 exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
229 exprIsCheap (Let bind body) = all exprIsCheap (rhssOfBind bind) && exprIsCheap body
230 exprIsCheap (Case scrut _ alts) = exprIsCheap scrut &&
231 all (\(_,_,rhs) -> exprIsCheap rhs) alts
233 exprIsCheap other_expr -- look for manifest partial application
234 = case collectArgs other_expr of
235 (f, args) -> isPap f (valArgCount args) && all exprIsCheap args
239 isPap :: CoreExpr -- Function
240 -> Int -- Number of value args
242 isPap (Var f) n_val_args
243 = idAppIsBottom f n_val_args
244 -- Application of a function which
245 -- always gives bottom; we treat this as
246 -- a WHNF, because it certainly doesn't
247 -- need to be shared!
249 || n_val_args == 0 -- Just a type application of
250 -- a variable (f t1 t2 t3)
253 || n_val_args < arityLowerBound (getIdArity f)
255 isPap fun n_val_args = False
258 exprOkForSpeculation returns True of an UNLIFTED-TYPE expression that it is safe
259 to evaluate even if normal order eval might not evaluate the expression
261 let x = case y# +# 1# of { r# -> I# r# }
264 case y# +# 1# of { r# ->
269 We can only do this if the (y+1) is ok for speculation: it has no
270 side effects, and can't diverge or raise an exception.
273 exprOkForSpeculation :: CoreExpr -> Bool
274 exprOkForSpeculation (Var v) = True -- Unlifted type => already evaluated
276 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
277 exprOkForSpeculation (Let (NonRec b r) e) = isUnLiftedType (idType b) &&
278 exprOkForSpeculation r &&
279 exprOkForSpeculation e
280 exprOkForSpeculation (Let (Rec _) _) = False
281 exprOkForSpeculation (Case _ _ _) = False -- Conservative
282 exprOkForSpeculation (App _ _) = False
284 exprOkForSpeculation (Con con args)
285 = conOkForSpeculation con &&
286 and (zipWith ok (filter isValArg args) (fst (conStrictness con)))
288 ok arg demand | isLazy demand = True
289 | isPrim demand = exprOkForSpeculation arg
292 exprOkForSpeculation other = panic "exprOkForSpeculation"
298 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
299 exprIsBottom e = go 0 e
301 -- n is the number of args
302 go n (Note _ e) = go n e
303 go n (Let _ e) = go n e
304 go n (Case e _ _) = go 0 e -- Just check the scrut
305 go n (App e _) = go (n+1) e
306 go n (Var v) = idAppIsBottom v n
307 go n (Con _ _) = False
308 go n (Lam _ _) = False
311 exprIsWHNF reports True for head normal forms. Note that does not necessarily
312 mean *normal* forms; constructors might have non-trivial argument expressions, for
313 example. We use a let binding for WHNFs, rather than a case binding, even if it's
314 used strictly. We try to expose WHNFs by floating lets out of the RHS of lets.
316 We treat applications of buildId and augmentId as honorary WHNFs, because we
317 want them to get exposed
320 exprIsWHNF :: CoreExpr -> Bool -- True => Variable, value-lambda, constructor, PAP
321 exprIsWHNF (Type ty) = True -- Types are honorary WHNFs; we don't mind
323 exprIsWHNF (Var v) = True
324 exprIsWHNF (Lam b e) = isId b || exprIsWHNF e
325 exprIsWHNF (Note _ e) = exprIsWHNF e
326 exprIsWHNF (Let _ e) = False
327 exprIsWHNF (Case _ _ _) = False
328 exprIsWHNF (Con con _) = isWHNFCon con
329 exprIsWHNF e@(App _ _) = case collectArgs e of
330 (Var v, args) -> n_val_args == 0 ||
331 fun_arity > n_val_args ||
332 v_uniq == buildIdKey ||
333 v_uniq == augmentIdKey
335 n_val_args = valArgCount args
336 fun_arity = arityLowerBound (getIdArity v)
343 exprArity :: CoreExpr -> Int -- How many value lambdas are at the top
344 exprArity (Lam b e) | isTyVar b = exprArity e
345 | otherwise = 1 + exprArity e
350 %************************************************************************
352 \subsection{Equality}
354 %************************************************************************
356 @cheapEqExpr@ is a cheap equality test which bales out fast!
357 True => definitely equal
358 False => may or may not be equal
361 cheapEqExpr :: Expr b -> Expr b -> Bool
363 cheapEqExpr (Var v1) (Var v2) = v1==v2
364 cheapEqExpr (Con con1 args1) (Con con2 args2)
366 and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2)
368 cheapEqExpr (App f1 a1) (App f2 a2)
369 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
371 cheapEqExpr (Type t1) (Type t2) = t1 == t2
373 cheapEqExpr _ _ = False
378 eqExpr :: CoreExpr -> CoreExpr -> Bool
379 -- Works ok at more general type, but only needed at CoreExpr
381 = eq emptyVarEnv e1 e2
383 -- The "env" maps variables in e1 to variables in ty2
384 -- So when comparing lambdas etc,
385 -- we in effect substitute v2 for v1 in e1 before continuing
386 eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
387 Just v1' -> v1' == v2
390 eq env (Con c1 es1) (Con c2 es2) = c1 == c2 && eq_list env es1 es2
391 eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
392 eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
393 eq env (Let (NonRec v1 r1) e1)
394 (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
395 eq env (Let (Rec ps1) e1)
396 (Let (Rec ps2) e2) = length ps1 == length ps2 &&
397 and (zipWith eq_rhs ps1 ps2) &&
400 env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
401 eq_rhs (_,r1) (_,r2) = eq env' r1 r2
402 eq env (Case e1 v1 a1)
403 (Case e2 v2 a2) = eq env e1 e2 &&
404 length a1 == length a2 &&
405 and (zipWith (eq_alt env') a1 a2)
407 env' = extendVarEnv env v1 v2
409 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
410 eq env (Type t1) (Type t2) = t1 == t2
413 eq_list env [] [] = True
414 eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
415 eq_list env es1 es2 = False
417 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
418 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
420 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
421 eq_note env (Coerce f1 t1) (Coerce f2 t2) = f1==f2 && t1==t2
422 eq_note env InlineCall InlineCall = True
423 eq_note env other1 other2 = False