2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
8 IdSubst, SubstCoreExpr(..),
10 coreExprType, coreAltsType, exprFreeVars, exprSomeFreeVars,
12 exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap,
13 FormSummary(..), mkFormSummary, whnfOrBottom,
16 substExpr, substId, substIds,
17 idSpecVars, idFreeVars,
19 squashableDictishCcExpr
22 #include "HsVersions.h"
24 import {-# SOURCE #-} CoreUnfold ( noUnfolding, hasUnfolding )
27 import PprCore () -- Instances only
28 import Var ( IdOrTyVar, isId, isTyVar )
31 import Name ( isLocallyDefined )
32 import Const ( Con(..), isWHNFCon, conIsTrivial, conIsCheap )
33 import Id ( Id, idType, setIdType, idUnique, idAppIsBottom,
34 getIdArity, idFreeTyVars,
35 getIdSpecialisation, setIdSpecialisation,
36 getInlinePragma, setInlinePragma,
37 getIdUnfolding, setIdUnfolding
39 import IdInfo ( arityLowerBound, InlinePragInfo(..) )
40 import SpecEnv ( emptySpecEnv, specEnvToList, isEmptySpecEnv )
41 import CostCentre ( isDictCC, CostCentre )
42 import Const ( Con, conType )
43 import Type ( Type, TyVarSubst, mkFunTy, mkForAllTy,
44 splitFunTy_maybe, applyTys, tyVarsOfType, tyVarsOfTypes,
45 fullSubstTy, substTyVar )
46 import Unique ( buildIdKey, augmentIdKey )
47 import Util ( zipWithEqual, mapAccumL )
49 import TysPrim ( alphaTy ) -- Debgging only
53 %************************************************************************
55 \subsection{Substitutions}
57 %************************************************************************
60 type IdSubst = IdEnv SubstCoreExpr -- Maps Ids to SubstCoreExpr
63 = Done CoreExpr -- No more substitution needed
64 | SubstMe CoreExpr TyVarSubst IdSubst -- A suspended substitution
67 %************************************************************************
69 \subsection{Find the type of a Core atom/expression}
71 %************************************************************************
74 coreExprType :: CoreExpr -> Type
76 coreExprType (Var var) = idType var
77 coreExprType (Let _ body) = coreExprType body
78 coreExprType (Case _ _ alts) = coreAltsType alts
79 coreExprType (Note (Coerce ty _) e) = ty
80 coreExprType (Note other_note e) = coreExprType e
81 coreExprType e@(Con con args) = applyTypeToArgs e (conType con) args
83 coreExprType (Lam binder expr)
84 | isId binder = idType binder `mkFunTy` coreExprType expr
85 | isTyVar binder = mkForAllTy binder (coreExprType expr)
87 coreExprType e@(App _ _)
88 = case collectArgs e of
89 (fun, args) -> applyTypeToArgs e (coreExprType fun) args
91 coreExprType other = pprTrace "coreExprType" (ppr other) alphaTy
93 coreAltsType :: [CoreAlt] -> Type
94 coreAltsType ((_,_,rhs) : _) = coreExprType rhs
98 -- The "e" argument is just for debugging
100 applyTypeToArgs e op_ty [] = op_ty
102 applyTypeToArgs e op_ty (Type ty : args)
103 = -- Accumulate type arguments so we can instantiate all at once
104 applyTypeToArgs e (applyTys op_ty tys) rest_args
106 (tys, rest_args) = go [ty] args
107 go tys (Type ty : args) = go (ty:tys) args
108 go tys rest_args = (reverse tys, rest_args)
110 applyTypeToArgs e op_ty (other_arg : args)
111 = case (splitFunTy_maybe op_ty) of
112 Just (_, res_ty) -> applyTypeToArgs e res_ty args
113 Nothing -> pprPanic "applyTypeToArgs" (ppr e)
117 %************************************************************************
119 \subsection{Figuring out things about expressions}
121 %************************************************************************
125 = VarForm -- Expression is a variable (or scc var, etc)
126 | ValueForm -- Expression is a value: i.e. a value-lambda,constructor, or literal
127 | BottomForm -- Expression is guaranteed to be bottom. We're more gung
128 -- ho about inlining such things, because it can't waste work
129 | OtherForm -- Anything else
131 instance Outputable FormSummary where
132 ppr VarForm = ptext SLIT("Var")
133 ppr ValueForm = ptext SLIT("Value")
134 ppr BottomForm = ptext SLIT("Bot")
135 ppr OtherForm = ptext SLIT("Other")
137 whnfOrBottom :: FormSummary -> Bool
138 whnfOrBottom VarForm = True
139 whnfOrBottom ValueForm = True
140 whnfOrBottom BottomForm = True
141 whnfOrBottom OtherForm = False
145 mkFormSummary :: CoreExpr -> FormSummary
147 = go (0::Int) expr -- The "n" is the number of *value* arguments so far
149 go n (Con con _) | isWHNFCon con = ValueForm
150 | otherwise = OtherForm
152 go n (Note _ e) = go n e
154 go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g)
155 -- should be treated as a value
156 go n (Let _ e) = OtherForm
157 go n (Case _ _ _) = OtherForm
159 go 0 (Lam x e) | isId x = ValueForm -- NB: \x.bottom /= bottom!
161 go n (Lam x e) | isId x = go (n-1) e -- Applied lambda
164 go n (App fun (Type _)) = go n fun -- Ignore type args
165 go n (App fun arg) = go (n+1) fun
167 go n (Var f) | idAppIsBottom f n = BottomForm
168 go 0 (Var f) = VarForm
169 go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm
170 | otherwise = OtherForm
173 @exprIsTrivial@ is true of expressions we are unconditionally
174 happy to duplicate; simple variables and constants,
175 and type applications.
177 @exprIsDupable@ is true of expressions that can be duplicated at a modest
178 cost in space, but without duplicating any work.
181 @exprIsBottom@ is true of expressions that are guaranteed to diverge
185 exprIsTrivial (Type _) = True
186 exprIsTrivial (Var v) = True
187 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
188 exprIsTrivial (Note _ e) = exprIsTrivial e
189 exprIsTrivial (Con con args) = conIsTrivial con && all isTypeArg args
190 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
191 exprIsTrivial other = False
196 exprIsDupable (Type _) = True
197 exprIsDupable (Con con args) = conIsCheap con &&
198 all exprIsDupable args &&
199 valArgCount args <= dupAppSize
201 exprIsDupable (Note _ e) = exprIsDupable e
202 exprIsDupable expr = case collectArgs expr of
203 (Var v, args) -> n_val_args == 0 ||
204 (n_val_args < fun_arity &&
205 all exprIsDupable args &&
206 n_val_args <= dupAppSize)
208 n_val_args = valArgCount args
209 fun_arity = arityLowerBound (getIdArity v)
214 dupAppSize = 4 -- Size of application we are prepared to duplicate
217 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
218 it is obviously in weak head normal form, or is cheap to get to WHNF.
219 [Note that that's not the same as exprIsDupable; an expression might be
220 big, and hence not dupable, but still cheap.]
221 By ``cheap'' we mean a computation we're willing to push inside a lambda
222 in order to bring a couple of lambdas together. That might mean it gets
223 evaluated more than once, instead of being shared. The main examples of things
224 which aren't WHNF but are ``cheap'' are:
229 where e, and all the ei are cheap; and
234 where e and b are cheap; and
238 where op is a cheap primitive operator
241 exprIsCheap :: CoreExpr -> Bool
242 exprIsCheap (Type _) = True
243 exprIsCheap (Var _) = True
244 exprIsCheap (Con con args) = conIsCheap con && all exprIsCheap args
245 exprIsCheap (Note _ e) = exprIsCheap e
246 exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
247 exprIsCheap (Let bind body) = all exprIsCheap (rhssOfBind bind) && exprIsCheap body
248 exprIsCheap (Case scrut _ alts) = exprIsCheap scrut &&
249 all (\(_,_,rhs) -> exprIsCheap rhs) alts
251 exprIsCheap other_expr -- look for manifest partial application
252 = case collectArgs other_expr of
254 (Var f, args) | idAppIsBottom f (length args)
255 -> True -- Application of a function which
256 -- always gives bottom; we treat this as
257 -- a WHNF, because it certainly doesn't
258 -- need to be shared!
262 num_val_args = valArgCount args
264 num_val_args == 0 || -- Just a type application of
265 -- a variable (f t1 t2 t3)
267 num_val_args < arityLowerBound (getIdArity f)
274 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
275 exprIsBottom e = go 0 e
277 -- n is the number of args
278 go n (Note _ e) = go n e
279 go n (Let _ e) = go n e
280 go n (Case e _ _) = go 0 e -- Just check the scrut
281 go n (App e _) = go (n+1) e
282 go n (Var v) = idAppIsBottom v n
283 go n (Con _ _) = False
284 go n (Lam _ _) = False
287 exprIsWHNF reports True for head normal forms. Note that does not necessarily
288 mean *normal* forms; constructors might have non-trivial argument expressions, for
289 example. We use a let binding for WHNFs, rather than a case binding, even if it's
290 used strictly. We try to expose WHNFs by floating lets out of the RHS of lets.
292 We treat applications of buildId and augmentId as honorary WHNFs, because we
293 want them to get exposed
296 exprIsWHNF :: CoreExpr -> Bool -- True => Variable, value-lambda, constructor, PAP
297 exprIsWHNF (Type ty) = True -- Types are honorary WHNFs; we don't mind
299 exprIsWHNF (Var v) = True
300 exprIsWHNF (Lam b e) = isId b || exprIsWHNF e
301 exprIsWHNF (Note _ e) = exprIsWHNF e
302 exprIsWHNF (Let _ e) = False
303 exprIsWHNF (Case _ _ _) = False
304 exprIsWHNF (Con con _) = isWHNFCon con
305 exprIsWHNF e@(App _ _) = case collectArgs e of
306 (Var v, args) -> n_val_args == 0 ||
307 fun_arity > n_val_args ||
308 v_uniq == buildIdKey ||
309 v_uniq == augmentIdKey
311 n_val_args = valArgCount args
312 fun_arity = arityLowerBound (getIdArity v)
318 I don't like this function but I'n not confidnt enough to change it.
321 squashableDictishCcExpr :: CostCentre -> Expr b -> Bool
322 squashableDictishCcExpr cc expr
323 | isDictCC cc = False -- that was easy...
324 | otherwise = squashable expr
326 squashable (Var _) = True
327 squashable (Con _ _) = True -- I think so... WDP 94/09
329 | isTypeArg a = squashable f
330 squashable other = False
334 @cheapEqExpr@ is a cheap equality test which bales out fast!
335 True => definitely equal
336 False => may or may not be equal
339 cheapEqExpr :: Expr b -> Expr b -> Bool
341 cheapEqExpr (Var v1) (Var v2) = v1==v2
342 cheapEqExpr (Con con1 args1) (Con con2 args2)
344 and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2)
346 cheapEqExpr (App f1 a1) (App f2 a2)
347 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
349 cheapEqExpr (Type t1) (Type t2) = t1 == t2
351 cheapEqExpr _ _ = False
355 %************************************************************************
357 \section{Finding the free variables of an expression}
359 %************************************************************************
361 This function simply finds the free variables of an expression.
362 So far as type variables are concerned, it only finds tyvars that are
364 * free in type arguments,
365 * free in the type of a binder,
367 but not those that are free in the type of variable occurrence.
370 exprFreeVars :: CoreExpr -> IdOrTyVarSet -- Find all locally-defined free Ids or tyvars
371 exprFreeVars = exprSomeFreeVars isLocallyDefined
373 exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
376 exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
378 type InterestingVarFun = IdOrTyVar -> Bool -- True <=> interesting
383 type FV = InterestingVarFun
384 -> IdOrTyVarSet -- In scope
385 -> IdOrTyVarSet -- Free vars
387 union :: FV -> FV -> FV
388 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
391 noVars fv_cand in_scope = emptyVarSet
393 oneVar :: IdOrTyVar -> FV
394 oneVar var fv_cand in_scope
395 | keep_it fv_cand in_scope var = unitVarSet var
396 | otherwise = emptyVarSet
398 someVars :: IdOrTyVarSet -> FV
399 someVars vars fv_cand in_scope
400 = filterVarSet (keep_it fv_cand in_scope) vars
402 keep_it fv_cand in_scope var
403 | var `elemVarSet` in_scope = False
408 addBndr :: CoreBndr -> FV -> FV
409 addBndr bndr fv fv_cand in_scope
410 | isId bndr = inside_fvs `unionVarSet` someVars (idFreeVars bndr) fv_cand in_scope
411 | otherwise = inside_fvs
413 inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
415 addBndrs :: [CoreBndr] -> FV -> FV
416 addBndrs bndrs fv = foldr addBndr fv bndrs
421 expr_fvs :: CoreExpr -> FV
423 expr_fvs (Type ty) = someVars (tyVarsOfType ty)
424 expr_fvs (Var var) = oneVar var
425 expr_fvs (Con con args) = foldr (union . expr_fvs) noVars args
426 expr_fvs (Note _ expr) = expr_fvs expr
427 expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
428 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
430 expr_fvs (Case scrut bndr alts)
431 = expr_fvs scrut `union` addBndr bndr (foldr (union. alt_fvs) noVars alts)
433 alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
435 expr_fvs (Let (NonRec bndr rhs) body)
436 = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
438 expr_fvs (Let (Rec pairs) body)
439 = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
441 (bndrs,rhss) = unzip pairs
445 Given an Id, idSpecVars returns all its specialisations.
446 We extract these from its SpecEnv.
447 This is used by the occurrence analyser and free-var finder;
448 we regard an Id's specialisations as free in the Id's definition.
451 idSpecVars :: Id -> IdOrTyVarSet
453 = foldr (unionVarSet . spec_item_fvs)
455 (specEnvToList (getIdSpecialisation id))
457 spec_item_fvs (tyvars, tys, rhs) = foldl delVarSet
458 (tyVarsOfTypes tys `unionVarSet` exprFreeVars rhs)
461 idFreeVars :: Id -> IdOrTyVarSet
462 idFreeVars id = idSpecVars id `unionVarSet` idFreeTyVars id
466 %************************************************************************
468 \section{Substitution}
470 %************************************************************************
472 This expression substituter deals correctly with name capture, much
475 BUT NOTE that substExpr silently discards the
478 IdInfo attached to any binders in the expression. It's quite
479 tricky to do them 'right' in the case of mutually recursive bindings,
480 and so far has proved unnecessary.
483 substExpr :: TyVarSubst -> IdSubst -- Substitution
484 -> IdOrTyVarSet -- Superset of in-scope
488 substExpr te ve in_scope expr = subst_expr (te, ve, in_scope) expr
490 subst_expr env@(te, ve, in_scope) expr
493 go (Var v) = case lookupVarEnv ve v of
497 Just (SubstMe e' te' ve')
498 -> subst_expr (te', ve', in_scope) e'
500 Nothing -> case lookupVarSet in_scope v of
503 -- NB: we look up in the in_scope set because the variable
504 -- there may have more info. In particular, when substExpr
505 -- is called from the simplifier, the type inside the *occurrences*
506 -- of a variable may not be right; we should replace it with the
507 -- binder, from the in_scope set.
509 go (Type ty) = Type (go_ty ty)
510 go (Con con args) = Con con (map go args)
511 go (App fun arg) = App (go fun) (go arg)
512 go (Note note e) = Note (go_note note) (go e)
514 go (Lam bndr body) = Lam bndr' (subst_expr env' body)
516 (env', bndr') = go_bndr env bndr
518 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (subst_expr env' body)
520 (env', bndr') = go_bndr env bndr
522 go (Let (Rec pairs) body) = Let (Rec pairs') (subst_expr env' body)
524 (ve', in_scope', _, bndrs')
525 = substIds clone_fn te ve in_scope undefined (map fst pairs)
526 env' = (te, ve', in_scope')
527 pairs' = bndrs' `zip` rhss'
528 rhss' = map (subst_expr env' . snd) pairs
530 go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt env') alts)
532 (env', bndr') = go_bndr env bndr
534 go_alt env (con, bndrs, rhs) = (con, bndrs', subst_expr env' rhs)
536 (env', bndrs') = mapAccumL go_bndr env bndrs
538 go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
541 go_ty ty = fullSubstTy te in_scope ty
543 go_bndr (te, ve, in_scope) bndr
545 = case substTyVar te in_scope bndr of
546 (te', in_scope', bndr') -> ((te', ve, in_scope'), bndr')
549 = case substId clone_fn te ve in_scope undefined bndr of
550 (ve', in_scope', _, bndr') -> ((te, ve', in_scope'), bndr')
553 clone_fn in_scope _ bndr
554 | bndr `elemVarSet` in_scope = Just (uniqAway in_scope bndr, undefined)
555 | otherwise = Nothing
559 Substituting in binders is a rather tricky part of the whole compiler.
562 substIds :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner
563 -> TyVarSubst -> IdSubst -> IdOrTyVarSet -- Usual stuff
564 -> us -- Unique supply
566 -> (IdSubst, IdOrTyVarSet, -- New id_subst, in_scope
567 us, -- New unique supply
570 substIds clone_fn ty_subst id_subst in_scope us []
571 = (id_subst, in_scope, us, [])
573 substIds clone_fn ty_subst id_subst in_scope us (id:ids)
574 = case (substId clone_fn ty_subst id_subst in_scope us id) of {
575 (id_subst', in_scope', us', id') ->
577 case (substIds clone_fn ty_subst id_subst' in_scope' us' ids) of {
578 (id_subst'', in_scope'', us'', ids') ->
580 (id_subst'', in_scope'', us'', id':ids')
584 substId :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner
585 -> TyVarSubst -> IdSubst -> IdOrTyVarSet -- Usual stuff
586 -> us -- Unique supply
588 -> (IdSubst, IdOrTyVarSet, -- New id_subst, in_scope
589 us, -- New unique supply
592 -- Returns an Id with empty unfolding and spec-env.
593 -- It's up to the caller to sort these out.
596 ty_subst id_subst in_scope
599 -- No need to clone, but we *must* zap any current substitution
600 -- for the variable. For example:
601 -- (\x.e) with id_subst = [x |-> e']
602 -- Here we must simply zap the substitution for x
603 = (delVarEnv id_subst id, extendVarSet in_scope id, us, id)
606 = (extendVarEnv id_subst id (Done (Var new_id)),
607 extendVarSet in_scope new_id,
612 old_id_will_do = old1 && old2 && old3 && {-old4 && -}not cloned
614 -- id1 has its type zapped
615 (id1,old1) | isEmptyVarEnv ty_subst
616 || isEmptyVarSet (tyVarsOfType id_ty) = (id, True)
617 | otherwise = (setIdType id ty', False)
619 ty' = fullSubstTy ty_subst in_scope id_ty
621 -- id2 has its SpecEnv zapped
622 -- It's filled in later by Simplify.simplPrags
623 (id2,old2) | isEmptySpecEnv spec_env = (id1, True)
624 | otherwise = (setIdSpecialisation id1 emptySpecEnv, False)
625 spec_env = getIdSpecialisation id
627 -- id3 has its Unfolding zapped
628 -- This is very important; occasionally a let-bound binder is used
629 -- as a binder in some lambda, in which case its unfolding is utterly
630 -- bogus. Also the unfolding uses old binders so if we left it we'd
631 -- have to substitute it. Much better simply to give the Id a new
632 -- unfolding each time, which is what the simplifier does.
633 (id3,old3) | hasUnfolding (getIdUnfolding id) = (id2 `setIdUnfolding` noUnfolding, False)
634 | otherwise = (id2, True)
636 -- new_id is cloned if necessary
637 (new_us, new_id, cloned) = case clone_fn in_scope us id3 of
638 Nothing -> (us, id3, False)
639 Just (us', id') -> (us', id', True)
641 -- new_id_bndr has its Inline info neutered. We must forget about whether it
642 -- was marked safe-to-inline, because that isn't necessarily true in
643 -- the simplified expression. We do this for the *binder* which will
644 -- be used at the binding site, but we *dont* do it for new_id, which
645 -- is put into the in_scope env. Why not? Because the in_scope env
646 -- carries down the occurrence information to usage sites!
648 -- Net result: post-simplification, occurrences may have over-optimistic
649 -- occurrence info, but binders won't.
650 {- (new_id_bndr, old4)
651 = case getInlinePragma id of
652 ICanSafelyBeINLINEd _ _ -> (setInlinePragma new_id NoInlinePragInfo, False)
653 other -> (new_id, True)