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, mustHaveLocalBinding )
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 IdInfo ( IdInfo, isFragileOccInfo,
49 specInfo, setSpecInfo,
50 WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
52 import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
53 import Var ( Var, Id, TyVar, isTyVar )
55 import PprCore () -- Instances
56 import Util ( mapAccumL, foldl2, seqList, ($!) )
59 %************************************************************************
61 \subsection{Substitutions}
63 %************************************************************************
66 type InScopeSet = VarEnv Var
68 data Subst = Subst InScopeSet -- In scope
69 SubstEnv -- Substitution itself
70 -- INVARIANT 1: The (domain of the) in-scope set is a superset
71 -- of the free vars of the range of the substitution
72 -- that might possibly clash with locally-bound variables
73 -- in the thing being substituted in.
74 -- This is what lets us deal with name capture properly
75 -- It's a hard invariant to check...
76 -- There are various ways of causing it to happen:
77 -- - arrange that the in-scope set really is all the things in scope
78 -- - arrange that it's the free vars of the range of the substitution
79 -- - make it empty because all the free vars of the subst are fresh,
80 -- and hence can't possibly clash.a
82 -- INVARIANT 2: No variable is both in scope and in the domain of the substitution
83 -- Equivalently, the substitution is idempotent
89 The general plan about the substitution and in-scope set for Ids is as follows
91 * substId always adds new_id to the in-scope set.
92 new_id has a correctly-substituted type, but all its fragile IdInfo has been zapped.
93 That is added back in later. So new_id is the minimal thing it's
94 correct to substitute.
96 * substId adds a binding (DoneVar new_id occ) to the substitution if
97 EITHER the Id's unique has changed
98 OR the Id has interesting occurrence information
99 So in effect you can only get to interesting occurrence information
100 by looking up the *old* Id; it's not really attached to the new id
103 Note, though that the substitution isn't necessarily extended
104 if the type changes. Why not? Because of the next point:
106 * We *always, always* finish by looking up in the in-scope set
107 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
108 Reason: so that we never finish up with a "old" Id in the result.
109 An old Id might point to an old unfolding and so on... which gives a space leak.
111 [The DoneEx and DoneVar hits map to "new" stuff.]
113 * It follows that substExpr must not do a no-op if the substitution is empty.
114 substType is free to do so, however.
116 * When we come to a let-binding (say) we generate new IdInfo, including an
117 unfolding, attach it to the binder, and add this newly adorned binder to
118 the in-scope set. So all subsequent occurrences of the binder will get mapped
119 to the full-adorned binder, which is also the one put in the binding site.
121 * The in-scope "set" usually maps x->x; we use it simply for its domain.
122 But sometimes we have two in-scope Ids that are synomyms, and should
123 map to the same target: x->x, y->x. Notably:
125 That's why the "set" is actually a VarEnv Var
128 emptyInScopeSet :: InScopeSet
129 emptyInScopeSet = emptyVarSet
131 add_in_scope :: InScopeSet -> Var -> InScopeSet
132 add_in_scope in_scope v = extendVarEnv in_scope v v
138 isEmptySubst :: Subst -> Bool
139 isEmptySubst (Subst _ env) = isEmptySubstEnv env
142 emptySubst = Subst emptyInScopeSet emptySubstEnv
144 mkSubst :: InScopeSet -> SubstEnv -> Subst
145 mkSubst in_scope env = Subst in_scope env
147 substEnv :: Subst -> SubstEnv
148 substEnv (Subst _ env) = env
150 substInScope :: Subst -> InScopeSet
151 substInScope (Subst in_scope _) = in_scope
153 zapSubstEnv :: Subst -> Subst
154 zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
156 extendSubst :: Subst -> Var -> SubstResult -> Subst
157 extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
159 extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
160 extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r)
162 lookupSubst :: Subst -> Var -> Maybe SubstResult
163 lookupSubst (Subst _ env) v = lookupSubstEnv env v
165 lookupIdSubst :: Subst -> Id -> SubstResult
166 -- Does the lookup in the in-scope set too
167 lookupIdSubst (Subst in_scope env) v
168 = case lookupSubstEnv env v of
169 Just (DoneId v' occ) -> DoneId (lookupInScope in_scope v') occ
171 Nothing -> DoneId v' (idOccInfo v')
172 -- We don't use DoneId for LoopBreakers, so the idOccInfo is
173 -- very important! If isFragileOccInfo returned True for
174 -- loop breakers we could avoid this call, but at the expense
175 -- of adding more to the substitution, and building new Ids
176 -- in substId a bit more often than really necessary
178 v' = lookupInScope in_scope v
180 lookupInScope :: InScopeSet -> Var -> Var
181 -- It's important to look for a fixed point
182 -- When we see (case x of y { I# v -> ... })
183 -- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
184 -- When we lookup up an occurrence of x, we map to y, but then
185 -- we want to look up y in case it has acquired more evaluation information by now.
186 lookupInScope in_scope v
187 = case lookupVarEnv in_scope v of
188 Just v' | v == v' -> v' -- Reached a fixed point
189 | otherwise -> lookupInScope in_scope v'
190 Nothing -> WARN( mustHaveLocalBinding v, ppr v )
193 isInScope :: Var -> Subst -> Bool
194 isInScope v (Subst in_scope _) = v `elemVarEnv` in_scope
196 extendInScope :: Subst -> Var -> Subst
197 extendInScope (Subst in_scope env) v = Subst (in_scope `add_in_scope` v) env
199 modifyInScope :: Subst -> Var -> Var -> Subst
200 modifyInScope (Subst in_scope env) old_v new_v = Subst (extendVarEnv in_scope old_v new_v) env
201 -- make old_v map to new_v
203 extendInScopes :: Subst -> [Var] -> Subst
204 extendInScopes (Subst in_scope env) vs = Subst (foldl add_in_scope in_scope vs) env
206 -------------------------------
207 bindSubst :: Subst -> Var -> Var -> Subst
208 -- Extend with a substitution, v1 -> Var v2
209 -- and extend the in-scopes with v2
210 bindSubst (Subst in_scope env) old_bndr new_bndr
211 = Subst (in_scope `add_in_scope` new_bndr)
212 (extendSubstEnv env old_bndr subst_result)
214 subst_result | isId old_bndr = DoneEx (Var new_bndr)
215 | otherwise = DoneTy (TyVarTy new_bndr)
217 unBindSubst :: Subst -> Var -> Var -> Subst
218 -- Reverse the effect of bindSubst
219 -- If old_bndr was already in the substitution, this doesn't quite work
220 unBindSubst (Subst in_scope env) old_bndr new_bndr
221 = Subst (in_scope `delVarEnv` new_bndr) (delSubstEnv env old_bndr)
223 -- And the "List" forms
224 bindSubstList :: Subst -> [Var] -> [Var] -> Subst
225 bindSubstList subst old_bndrs new_bndrs
226 = foldl2 bindSubst subst old_bndrs new_bndrs
228 unBindSubstList :: Subst -> [Var] -> [Var] -> Subst
229 unBindSubstList subst old_bndrs new_bndrs
230 = foldl2 unBindSubst subst old_bndrs new_bndrs
233 -------------------------------
234 setInScope :: Subst -- Take env part from here
237 setInScope (Subst in_scope1 env1) in_scope2
238 = Subst in_scope2 env1
240 setSubstEnv :: Subst -- Take in-scope part from here
241 -> SubstEnv -- ... and env part from here
243 setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
247 %************************************************************************
249 \subsection{Type substitution}
251 %************************************************************************
254 type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
255 -- (We could have a variant of Subst, but it doesn't seem worth it.)
257 -- mkTyVarSubst generates the in-scope set from
258 -- the types given; but it's just a thunk so with a bit of luck
259 -- it'll never be evaluated
260 mkTyVarSubst :: [TyVar] -> [Type] -> Subst
261 mkTyVarSubst tyvars tys = Subst (tyVarsOfTypes tys) (zip_ty_env tyvars tys emptySubstEnv)
263 -- mkTopTyVarSubst is called when doing top-level substitutions.
264 -- Here we expect that the free vars of the range of the
265 -- substitution will be empty.
266 mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
267 mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
269 zip_ty_env [] [] env = env
270 zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
273 substTy works with general Substs, so that it can be called from substExpr too.
276 substTy :: Subst -> Type -> Type
277 substTy subst ty | isEmptySubst subst = ty
278 | otherwise = subst_ty subst ty
280 substClasses :: TyVarSubst -> ClassContext -> ClassContext
281 substClasses subst theta
282 | isEmptySubst subst = theta
283 | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta]
285 substTheta :: TyVarSubst -> ThetaType -> ThetaType
286 substTheta subst theta
287 | isEmptySubst subst = theta
288 | otherwise = map (substPred subst) theta
290 substPred :: TyVarSubst -> PredType -> PredType
291 substPred subst (Class clas tys) = Class clas (map (subst_ty subst) tys)
292 substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
297 go (TyConApp tc tys) = let args = map go tys
298 in args `seqList` TyConApp tc args
299 go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
300 go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
301 go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
302 go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr
303 go (NoteTy (IPNote nm) ty2) = (NoteTy $! IPNote nm) $! go ty2 -- Keep ip note
305 go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
306 go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
307 go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
309 Just (DoneTy ty') -> ty'
311 go (ForAllTy tv ty) = case substTyVar subst tv of
312 (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
315 Here is where we invent a new binder if necessary.
318 substTyVar :: Subst -> TyVar -> (Subst, TyVar)
319 substTyVar subst@(Subst in_scope env) old_var
320 | old_var == new_var -- No need to clone
321 -- But we *must* zap any current substitution for the variable.
323 -- (\x.e) with id_subst = [x |-> e']
324 -- Here we must simply zap the substitution for x
326 -- The new_id isn't cloned, but it may have a different type
327 -- etc, so we must return it, not the old id
328 = (Subst (in_scope `add_in_scope` new_var)
329 (delSubstEnv env old_var),
332 | otherwise -- The new binder is in scope so
333 -- we'd better rename it away from the in-scope variables
334 -- Extending the substitution to do this renaming also
335 -- has the (correct) effect of discarding any existing
336 -- substitution for that variable
337 = (Subst (in_scope `add_in_scope` new_var)
338 (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
341 new_var = uniqAway in_scope old_var
342 -- The uniqAway part makes sure the new variable is not already in scope
346 %************************************************************************
348 \section{Expression substitution}
350 %************************************************************************
352 This expression substituter deals correctly with name capture.
354 BUT NOTE that substExpr silently discards the
357 IdInfo attached to any binders in the expression. It's quite
358 tricky to do them 'right' in the case of mutually recursive bindings,
359 and so far has proved unnecessary.
362 substExpr :: Subst -> CoreExpr -> CoreExpr
364 -- NB: we do not do a no-op when the substitution is empty,
365 -- because we always want to substitute the variables in the
366 -- in-scope set for their occurrences. Why?
367 -- (a) because they may contain more information
368 -- (b) because leaving an un-substituted Id might cause
369 -- a space leak (its unfolding might point to an old version
370 -- of its right hand side).
374 go (Var v) = -- See the notes at the top, with the Subst data type declaration
375 case lookupIdSubst subst v of
377 ContEx env' e' -> substExpr (setSubstEnv subst env') e'
381 go (Type ty) = Type (go_ty ty)
382 go (Lit lit) = Lit lit
383 go (App fun arg) = App (go fun) (go arg)
384 go (Note note e) = Note (go_note note) (go e)
386 go (Lam bndr body) = Lam bndr' (substExpr subst' body)
388 (subst', bndr') = substBndr subst bndr
390 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
392 (subst', bndr') = substBndr subst bndr
394 go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
396 (subst', bndrs') = substBndrs subst (map fst pairs)
397 pairs' = bndrs' `zip` rhss'
398 rhss' = map (substExpr subst' . snd) pairs
400 go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts)
402 (subst', bndr') = substBndr subst bndr
404 go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
406 (subst', bndrs') = substBndrs subst bndrs
408 go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
411 go_ty ty = substTy subst ty
415 Substituting in binders is a rather tricky part of the whole compiler.
417 When we hit a binder we may need to
418 (a) apply the the type envt (if non-empty) to its type
419 (c) give it a new unique to avoid name clashes
422 substBndr :: Subst -> Var -> (Subst, Var)
424 | isTyVar bndr = substTyVar subst bndr
425 | otherwise = substId subst bndr
427 substBndrs :: Subst -> [Var] -> (Subst, [Var])
428 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
431 substIds :: Subst -> [Id] -> (Subst, [Id])
432 substIds subst bndrs = mapAccumL substId subst bndrs
434 substId :: Subst -> Id -> (Subst, Id)
435 -- Returns an Id with empty IdInfo
436 -- See the notes with the Subst data type decl at the
437 -- top of this module
439 substId subst@(Subst in_scope env) old_id
440 = (Subst (in_scope `add_in_scope` new_id) new_env, new_id)
442 id_ty = idType old_id
443 occ_info = idOccInfo old_id
445 -- id1 has its type zapped
446 id1 | noTypeSubst env
447 || isEmptyVarSet (tyVarsOfType id_ty) = old_id
448 -- The tyVarsOfType is cheaper than it looks
449 -- because we cache the free tyvars of the type
450 -- in a Note in the id's type itself
451 | otherwise = setIdType old_id (substTy subst id_ty)
453 -- id2 has its IdInfo zapped
454 id2 = zapFragileIdInfo id1
456 -- new_id is cloned if necessary
457 new_id = uniqAway in_scope id2
459 -- Extend the substitution if the unique has changed,
460 -- or there's some useful occurrence information
461 -- See the notes with substTyVar for the delSubstEnv
462 new_env | new_id /= old_id || isFragileOccInfo occ_info
463 = extendSubstEnv env old_id (DoneId new_id occ_info)
465 = delSubstEnv env old_id
468 Now a variant that unconditionally allocates a new unique.
471 substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, UniqSupply, [Id])
472 substAndCloneIds subst us [] = (subst, us, [])
473 substAndCloneIds subst us (b:bs) = case substAndCloneId subst us b of { (subst1, us1, b') ->
474 case substAndCloneIds subst1 us1 bs of { (subst2, us2, bs') ->
475 (subst2, us2, (b':bs')) }}
477 substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, UniqSupply, Id)
478 substAndCloneId subst@(Subst in_scope env) us old_id
479 = (Subst (in_scope `add_in_scope` new_id)
480 (extendSubstEnv env old_id (DoneEx (Var new_id))),
484 id_ty = idType old_id
485 id1 | noTypeSubst env || isEmptyVarSet (tyVarsOfType id_ty) = old_id
486 | otherwise = setIdType old_id (substTy subst id_ty)
488 id2 = zapFragileIdInfo id1
489 new_id = setVarUnique id2 (uniqFromSupply us1)
490 (us1,new_us) = splitUniqSupply us
494 %************************************************************************
496 \section{IdInfo substitution}
498 %************************************************************************
502 -> IdInfo -- Get un-substituted ones from here
503 -> IdInfo -- Substitute it and add it to here
504 -> IdInfo -- To give this
505 -- Seq'ing on the returned IdInfo is enough to cause all the
506 -- substitutions to happen completely
508 substIdInfo subst old_info new_info
511 info1 | isEmptyCoreRules old_rules = new_info
512 | otherwise = new_info `setSpecInfo` new_rules
513 -- setSpecInfo does a seq
515 new_rules = substRules subst old_rules
517 info2 | not (workerExists old_wrkr) = info1
518 | otherwise = info1 `setWorkerInfo` new_wrkr
519 -- setWorkerInfo does a seq
521 new_wrkr = substWorker subst old_wrkr
523 old_rules = specInfo old_info
524 old_wrkr = workerInfo old_info
526 substWorker :: Subst -> WorkerInfo -> WorkerInfo
527 -- Seq'ing on the returned WorkerInfo is enough to cause all the
528 -- substitutions to happen completely
530 substWorker subst NoWorker
532 substWorker subst (HasWorker w a)
533 = case lookupIdSubst subst w of
534 (DoneId w1 _) -> HasWorker w1 a
535 (DoneEx (Var w1)) -> HasWorker w1 a
536 (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
537 NoWorker -- Worker has got substituted away altogether
538 (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
541 substRules :: Subst -> CoreRules -> CoreRules
542 -- Seq'ing on the returned CoreRules is enough to cause all the
543 -- substitutions to happen completely
545 substRules subst rules
546 | isEmptySubst subst = rules
548 substRules subst (Rules rules rhs_fvs)
549 = seqRules new_rules `seq` new_rules
551 new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
553 do_subst rule@(BuiltinRule _) = rule
554 do_subst (Rule name tpl_vars lhs_args rhs)
555 = Rule name tpl_vars'
556 (map (substExpr subst') lhs_args)
557 (substExpr subst' rhs)
559 (subst', tpl_vars') = substBndrs subst tpl_vars
561 substVarSet subst fvs
562 = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
564 subst_fv subst fv = case lookupIdSubst subst fv of
565 DoneId fv' _ -> unitVarSet fv'
566 DoneEx expr -> exprFreeVars expr
567 DoneTy ty -> tyVarsOfType ty
568 ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)