2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 InScopeSet, emptyInScopeSet,
10 lookupInScope, setInScope, extendInScope, extendInScopes, isInScope, modifyInScope,
13 Subst, TyVarSubst, IdSubst,
14 emptySubst, mkSubst, substEnv, substInScope,
15 lookupSubst, lookupIdSubst, isEmptySubst, extendSubst, extendSubstList,
16 zapSubstEnv, setSubstEnv,
18 bindSubst, unBindSubst, bindSubstList, unBindSubstList,
21 substBndr, substBndrs, substTyVar, substId, substIds,
22 substAndCloneId, substAndCloneIds,
25 mkTyVarSubst, mkTopTyVarSubst,
26 substTy, substClasses, substTheta,
29 substExpr, substIdInfo
32 #include "HsVersions.h"
34 import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
35 CoreRules(..), CoreRule(..),
36 emptyCoreRules, isEmptyCoreRules, seqRules
38 import CoreFVs ( exprFreeVars )
39 import TypeRep ( Type(..), TyNote(..),
41 import Type ( ThetaType, PredType(..), ClassContext,
42 tyVarsOfType, tyVarsOfTypes, mkAppTy
46 import Var ( setVarUnique, isId )
47 import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo )
48 import Name ( isLocallyDefined )
49 import IdInfo ( IdInfo, isFragileOccInfo,
50 specInfo, setSpecInfo,
51 WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
53 import BasicTypes ( OccInfo(..) )
54 import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
55 import Var ( Var, Id, TyVar, isTyVar )
57 import PprCore () -- Instances
58 import Util ( mapAccumL, foldl2, seqList, ($!) )
61 %************************************************************************
63 \subsection{Substitutions}
65 %************************************************************************
68 type InScopeSet = VarEnv Var
70 data Subst = Subst InScopeSet -- In scope
71 SubstEnv -- Substitution itself
72 -- INVARIANT 1: The (domain of the) in-scope set is a superset
73 -- of the free vars of the range of the substitution
74 -- that might possibly clash with locally-bound variables
75 -- in the thing being substituted in.
76 -- This is what lets us deal with name capture properly
77 -- It's a hard invariant to check...
78 -- There are various ways of causing it to happen:
79 -- - arrange that the in-scope set really is all the things in scope
80 -- - arrange that it's the free vars of the range of the substitution
81 -- - make it empty because all the free vars of the subst are fresh,
82 -- and hence can't possibly clash.a
84 -- INVARIANT 2: No variable is both in scope and in the domain of the substitution
85 -- Equivalently, the substitution is idempotent
91 The general plan about the substitution and in-scope set for Ids is as follows
93 * substId always adds new_id to the in-scope set.
94 new_id has a correctly-substituted type, but all its fragile IdInfo has been zapped.
95 That is added back in later. So new_id is the minimal thing it's
96 correct to substitute.
98 * substId adds a binding (DoneVar new_id occ) to the substitution if
99 EITHER the Id's unique has changed
100 OR the Id has interesting occurrence information
101 So in effect you can only get to interesting occurrence information
102 by looking up the *old* Id; it's not really attached to the new id
105 Note, though that the substitution isn't necessarily extended
106 if the type changes. Why not? Because of the next point:
108 * We *always, always* finish by looking up in the in-scope set
109 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
110 Reason: so that we never finish up with a "old" Id in the result.
111 An old Id might point to an old unfolding and so on... which gives a space leak.
113 [The DoneEx and DoneVar hits map to "new" stuff.]
115 * It follows that substExpr must not do a no-op if the substitution is empty.
116 substType is free to do so, however.
118 * When we come to a let-binding (say) we generate new IdInfo, including an
119 unfolding, attach it to the binder, and add this newly adorned binder to
120 the in-scope set. So all subsequent occurrences of the binder will get mapped
121 to the full-adorned binder, which is also the one put in the binding site.
123 * The in-scope "set" usually maps x->x; we use it simply for its domain.
124 But sometimes we have two in-scope Ids that are synomyms, and should
125 map to the same target: x->x, y->x. Notably:
127 That's why the "set" is actually a VarEnv Var
130 emptyInScopeSet :: InScopeSet
131 emptyInScopeSet = emptyVarSet
133 add_in_scope :: InScopeSet -> Var -> InScopeSet
134 add_in_scope in_scope v = extendVarEnv in_scope v v
140 isEmptySubst :: Subst -> Bool
141 isEmptySubst (Subst _ env) = isEmptySubstEnv env
144 emptySubst = Subst emptyInScopeSet emptySubstEnv
146 mkSubst :: InScopeSet -> SubstEnv -> Subst
147 mkSubst in_scope env = Subst in_scope env
149 substEnv :: Subst -> SubstEnv
150 substEnv (Subst _ env) = env
152 substInScope :: Subst -> InScopeSet
153 substInScope (Subst in_scope _) = in_scope
155 zapSubstEnv :: Subst -> Subst
156 zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
158 extendSubst :: Subst -> Var -> SubstResult -> Subst
159 extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
161 extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
162 extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r)
164 lookupSubst :: Subst -> Var -> Maybe SubstResult
165 lookupSubst (Subst _ env) v = lookupSubstEnv env v
167 lookupIdSubst :: Subst -> Id -> SubstResult
168 -- Does the lookup in the in-scope set too
169 lookupIdSubst (Subst in_scope env) v
170 = case lookupSubstEnv env v of
171 Just (DoneId v' occ) -> DoneId (lookupInScope in_scope v') occ
173 Nothing -> DoneId v' (idOccInfo v')
174 -- We don't use DoneId for LoopBreakers, so the idOccInfo is
175 -- very important! If isFragileOccInfo returned True for
176 -- loop breakers we could avoid this call, but at the expense
177 -- of adding more to the substitution, and building new Ids
178 -- in substId a bit more often than really necessary
180 v' = lookupInScope in_scope v
182 lookupInScope :: InScopeSet -> Var -> Var
183 -- It's important to look for a fixed point
184 -- When we see (case x of y { I# v -> ... })
185 -- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
186 -- When we lookup up an occurrence of x, we map to y, but then
187 -- we want to look up y in case it has acquired more evaluation information by now.
188 lookupInScope in_scope v
189 = case lookupVarEnv in_scope v of
190 Just v' | v == v' -> v' -- Reached a fixed point
191 | otherwise -> lookupInScope in_scope v'
194 isInScope :: Var -> Subst -> Bool
195 isInScope v (Subst in_scope _) = v `elemVarEnv` in_scope
197 extendInScope :: Subst -> Var -> Subst
198 extendInScope (Subst in_scope env) v = Subst (in_scope `add_in_scope` v) env
200 modifyInScope :: Subst -> Var -> Var -> Subst
201 modifyInScope (Subst in_scope env) old_v new_v = Subst (extendVarEnv in_scope old_v new_v) env
202 -- make old_v map to new_v
204 extendInScopes :: Subst -> [Var] -> Subst
205 extendInScopes (Subst in_scope env) vs = Subst (foldl add_in_scope in_scope vs) env
207 -------------------------------
208 bindSubst :: Subst -> Var -> Var -> Subst
209 -- Extend with a substitution, v1 -> Var v2
210 -- and extend the in-scopes with v2
211 bindSubst (Subst in_scope env) old_bndr new_bndr
212 = Subst (in_scope `add_in_scope` new_bndr)
213 (extendSubstEnv env old_bndr subst_result)
215 subst_result | isId old_bndr = DoneEx (Var new_bndr)
216 | otherwise = DoneTy (TyVarTy new_bndr)
218 unBindSubst :: Subst -> Var -> Var -> Subst
219 -- Reverse the effect of bindSubst
220 -- If old_bndr was already in the substitution, this doesn't quite work
221 unBindSubst (Subst in_scope env) old_bndr new_bndr
222 = Subst (in_scope `delVarEnv` new_bndr) (delSubstEnv env old_bndr)
224 -- And the "List" forms
225 bindSubstList :: Subst -> [Var] -> [Var] -> Subst
226 bindSubstList subst old_bndrs new_bndrs
227 = foldl2 bindSubst subst old_bndrs new_bndrs
229 unBindSubstList :: Subst -> [Var] -> [Var] -> Subst
230 unBindSubstList subst old_bndrs new_bndrs
231 = foldl2 unBindSubst subst old_bndrs new_bndrs
234 -------------------------------
235 setInScope :: Subst -- Take env part from here
238 setInScope (Subst in_scope1 env1) in_scope2
239 = Subst in_scope2 env1
241 setSubstEnv :: Subst -- Take in-scope part from here
242 -> SubstEnv -- ... and env part from here
244 setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
248 %************************************************************************
250 \subsection{Type substitution}
252 %************************************************************************
255 type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
256 -- (We could have a variant of Subst, but it doesn't seem worth it.)
258 -- mkTyVarSubst generates the in-scope set from
259 -- the types given; but it's just a thunk so with a bit of luck
260 -- it'll never be evaluated
261 mkTyVarSubst :: [TyVar] -> [Type] -> Subst
262 mkTyVarSubst tyvars tys = Subst (tyVarsOfTypes tys) (zip_ty_env tyvars tys emptySubstEnv)
264 -- mkTopTyVarSubst is called when doing top-level substitutions.
265 -- Here we expect that the free vars of the range of the
266 -- substitution will be empty.
267 mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
268 mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
270 zip_ty_env [] [] env = env
271 zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
274 substTy works with general Substs, so that it can be called from substExpr too.
277 substTy :: Subst -> Type -> Type
278 substTy subst ty | isEmptySubst subst = ty
279 | otherwise = subst_ty subst ty
281 substClasses :: TyVarSubst -> ClassContext -> ClassContext
282 substClasses subst theta
283 | isEmptySubst subst = theta
284 | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta]
286 substTheta :: TyVarSubst -> ThetaType -> ThetaType
287 substTheta subst theta
288 | isEmptySubst subst = theta
289 | otherwise = map (substPred subst) theta
291 substPred :: TyVarSubst -> PredType -> PredType
292 substPred subst (Class clas tys) = Class clas (map (subst_ty subst) tys)
293 substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
298 go (TyConApp tc tys) = let args = map go tys
299 in args `seqList` TyConApp tc args
300 go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
301 go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
302 go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
303 go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr
304 go (NoteTy (IPNote nm) ty2) = (NoteTy $! IPNote nm) $! go ty2 -- Keep ip note
306 go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
307 go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
308 go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
310 Just (DoneTy ty') -> ty'
312 go (ForAllTy tv ty) = case substTyVar subst tv of
313 (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
316 Here is where we invent a new binder if necessary.
319 substTyVar :: Subst -> TyVar -> (Subst, TyVar)
320 substTyVar subst@(Subst in_scope env) old_var
321 | old_var == new_var -- No need to clone
322 -- But we *must* zap any current substitution for the variable.
324 -- (\x.e) with id_subst = [x |-> e']
325 -- Here we must simply zap the substitution for x
327 -- The new_id isn't cloned, but it may have a different type
328 -- etc, so we must return it, not the old id
329 = (Subst (in_scope `add_in_scope` new_var)
330 (delSubstEnv env old_var),
333 | otherwise -- The new binder is in scope so
334 -- we'd better rename it away from the in-scope variables
335 -- Extending the substitution to do this renaming also
336 -- has the (correct) effect of discarding any existing
337 -- substitution for that variable
338 = (Subst (in_scope `add_in_scope` new_var)
339 (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
342 new_var = uniqAway in_scope old_var
343 -- The uniqAway part makes sure the new variable is not already in scope
347 %************************************************************************
349 \section{Expression substitution}
351 %************************************************************************
353 This expression substituter deals correctly with name capture.
355 BUT NOTE that substExpr silently discards the
358 IdInfo attached to any binders in the expression. It's quite
359 tricky to do them 'right' in the case of mutually recursive bindings,
360 and so far has proved unnecessary.
363 substExpr :: Subst -> CoreExpr -> CoreExpr
365 -- NB: we do not do a no-op when the substitution is empty,
366 -- because we always want to substitute the variables in the
367 -- in-scope set for their occurrences. Why?
368 -- (a) because they may contain more information
369 -- (b) because leaving an un-substituted Id might cause
370 -- a space leak (its unfolding might point to an old version
371 -- of its right hand side).
375 go (Var v) = -- See the notes at the top, with the Subst data type declaration
376 case lookupIdSubst subst v of
378 ContEx env' e' -> substExpr (setSubstEnv subst env') e'
382 go (Type ty) = Type (go_ty ty)
383 go (Lit lit) = Lit lit
384 go (App fun arg) = App (go fun) (go arg)
385 go (Note note e) = Note (go_note note) (go e)
387 go (Lam bndr body) = Lam bndr' (substExpr subst' body)
389 (subst', bndr') = substBndr subst bndr
391 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
393 (subst', bndr') = substBndr subst bndr
395 go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
397 (subst', bndrs') = substBndrs subst (map fst pairs)
398 pairs' = bndrs' `zip` rhss'
399 rhss' = map (substExpr subst' . snd) pairs
401 go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts)
403 (subst', bndr') = substBndr subst bndr
405 go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
407 (subst', bndrs') = substBndrs subst bndrs
409 go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
412 go_ty ty = substTy subst ty
416 Substituting in binders is a rather tricky part of the whole compiler.
418 When we hit a binder we may need to
419 (a) apply the the type envt (if non-empty) to its type
420 (c) give it a new unique to avoid name clashes
423 substBndr :: Subst -> Var -> (Subst, Var)
425 | isTyVar bndr = substTyVar subst bndr
426 | otherwise = substId subst bndr
428 substBndrs :: Subst -> [Var] -> (Subst, [Var])
429 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
432 substIds :: Subst -> [Id] -> (Subst, [Id])
433 substIds subst bndrs = mapAccumL substId subst bndrs
435 substId :: Subst -> Id -> (Subst, Id)
436 -- Returns an Id with empty IdInfo
437 -- See the notes with the Subst data type decl at the
438 -- top of this module
440 substId subst@(Subst in_scope env) old_id
441 = (Subst (in_scope `add_in_scope` new_id) new_env, new_id)
443 id_ty = idType old_id
444 occ_info = idOccInfo old_id
446 -- id1 has its type zapped
447 id1 | noTypeSubst env
448 || isEmptyVarSet (tyVarsOfType id_ty) = old_id
449 -- The tyVarsOfType is cheaper than it looks
450 -- because we cache the free tyvars of the type
451 -- in a Note in the id's type itself
452 | otherwise = setIdType old_id (substTy subst id_ty)
454 -- id2 has its IdInfo zapped
455 id2 = zapFragileIdInfo id1
457 -- new_id is cloned if necessary
458 new_id = uniqAway in_scope id2
460 -- Extend the substitution if the unique has changed,
461 -- or there's some useful occurrence information
462 -- See the notes with substTyVar for the delSubstEnv
463 new_env | new_id /= old_id || isFragileOccInfo occ_info
464 = extendSubstEnv env old_id (DoneId new_id occ_info)
466 = delSubstEnv env old_id
469 Now a variant that unconditionally allocates a new unique.
472 substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, UniqSupply, [Id])
473 substAndCloneIds subst us [] = (subst, us, [])
474 substAndCloneIds subst us (b:bs) = case substAndCloneId subst us b of { (subst1, us1, b') ->
475 case substAndCloneIds subst1 us1 bs of { (subst2, us2, bs') ->
476 (subst2, us2, (b':bs')) }}
478 substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, UniqSupply, Id)
479 substAndCloneId subst@(Subst in_scope env) us old_id
480 = (Subst (in_scope `add_in_scope` new_id)
481 (extendSubstEnv env old_id (DoneEx (Var new_id))),
485 id_ty = idType old_id
486 id1 | noTypeSubst env || isEmptyVarSet (tyVarsOfType id_ty) = old_id
487 | otherwise = setIdType old_id (substTy subst id_ty)
489 id2 = zapFragileIdInfo id1
490 new_id = setVarUnique id2 (uniqFromSupply us1)
491 (us1,new_us) = splitUniqSupply us
495 %************************************************************************
497 \section{IdInfo substitution}
499 %************************************************************************
503 -> IdInfo -- Get un-substituted ones from here
504 -> IdInfo -- Substitute it and add it to here
505 -> IdInfo -- To give this
506 -- Seq'ing on the returned IdInfo is enough to cause all the
507 -- substitutions to happen completely
509 substIdInfo subst old_info new_info
512 info1 | isEmptyCoreRules old_rules = new_info
513 | otherwise = new_info `setSpecInfo` new_rules
514 -- setSpecInfo does a seq
516 new_rules = substRules subst old_rules
518 info2 | not (workerExists old_wrkr) = info1
519 | otherwise = info1 `setWorkerInfo` new_wrkr
520 -- setWorkerInfo does a seq
522 new_wrkr = substWorker subst old_wrkr
524 old_rules = specInfo old_info
525 old_wrkr = workerInfo old_info
527 substWorker :: Subst -> WorkerInfo -> WorkerInfo
528 -- Seq'ing on the returned WorkerInfo is enough to cause all the
529 -- substitutions to happen completely
531 substWorker subst NoWorker
533 substWorker subst (HasWorker w a)
534 = case lookupIdSubst subst w of
535 (DoneId w1 _) -> HasWorker w1 a
536 (DoneEx (Var w1)) -> HasWorker w1 a
537 (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
538 NoWorker -- Worker has got substituted away altogether
539 (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
542 substRules :: Subst -> CoreRules -> CoreRules
543 -- Seq'ing on the returned CoreRules is enough to cause all the
544 -- substitutions to happen completely
546 substRules subst rules
547 | isEmptySubst subst = rules
549 substRules subst (Rules rules rhs_fvs)
550 = seqRules new_rules `seq` new_rules
552 new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
554 do_subst rule@(BuiltinRule _) = rule
555 do_subst (Rule name tpl_vars lhs_args rhs)
556 = Rule name tpl_vars'
557 (map (substExpr subst') lhs_args)
558 (substExpr subst' rhs)
560 (subst', tpl_vars') = substBndrs subst tpl_vars
562 substVarSet subst fvs
563 = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
565 subst_fv subst fv = case lookupIdSubst subst fv of
566 DoneId fv' _ -> unitVarSet fv'
567 DoneEx expr -> exprFreeVars expr
568 DoneTy ty -> tyVarsOfType ty
569 ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)