2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 InScopeSet, emptyInScopeSet, mkInScopeSet,
10 extendInScopeSet, extendInScopeSetList,
11 lookupInScope, elemInScopeSet, uniqAway,
15 Subst, TyVarSubst, IdSubst,
16 emptySubst, mkSubst, substEnv, substInScope,
17 lookupSubst, lookupIdSubst, isEmptySubst, extendSubst, extendSubstList,
18 zapSubstEnv, setSubstEnv,
20 extendInScope, extendInScopeList, extendNewInScope, extendNewInScopeList,
21 isInScope, modifyInScope,
23 bindSubst, unBindSubst, bindSubstList, unBindSubstList,
26 substBndr, substBndrs, substTyVar, substId, substIds,
27 substAndCloneId, substAndCloneIds,
30 mkTyVarSubst, mkTopTyVarSubst,
31 substTy, substClasses, substTheta,
34 substExpr, substIdInfo
37 #include "HsVersions.h"
39 import CmdLineOpts ( opt_PprStyle_Debug )
40 import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
41 CoreRules(..), CoreRule(..),
42 emptyCoreRules, isEmptyCoreRules, seqRules
44 import CoreFVs ( exprFreeVars, mustHaveLocalBinding )
45 import TypeRep ( Type(..), TyNote(..),
47 import Type ( ThetaType, PredType(..), ClassContext,
48 tyVarsOfType, tyVarsOfTypes, mkAppTy
52 import Var ( setVarUnique, isId )
53 import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo )
54 import IdInfo ( IdInfo, isFragileOccInfo,
55 specInfo, setSpecInfo,
56 WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
58 import Unique ( Uniquable(..), deriveUnique )
59 import UniqSet ( elemUniqSet_Directly )
60 import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
61 import Var ( Var, Id, TyVar, isTyVar )
63 import PprCore () -- Instances
64 import Util ( mapAccumL, foldl2, seqList, ($!) )
68 %************************************************************************
70 \subsection{The in-scope set}
72 %************************************************************************
75 data InScopeSet = InScope (VarEnv Var) Int#
76 -- The Int# is a kind of hash-value used by uniqAway
77 -- For example, it might be the size of the set
79 emptyInScopeSet :: InScopeSet
80 emptyInScopeSet = InScope emptyVarSet 0#
82 mkInScopeSet :: VarEnv Var -> InScopeSet
83 mkInScopeSet in_scope = InScope in_scope 0#
85 extendInScopeSet :: InScopeSet -> Var -> InScopeSet
86 extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
88 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
89 extendInScopeSetList (InScope in_scope n) vs = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
90 (case length vs of { I# l -> n +# l })
92 modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
93 -- Exploit the fact that the in-scope "set" is really a map
94 -- Make old_v map to new_v
95 modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
97 delInScopeSet :: InScopeSet -> Var -> InScopeSet
98 delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
100 elemInScopeSet :: Var -> InScopeSet -> Bool
101 elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
103 lookupInScope :: InScopeSet -> Var -> Var
104 -- It's important to look for a fixed point
105 -- When we see (case x of y { I# v -> ... })
106 -- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
107 -- When we lookup up an occurrence of x, we map to y, but then
108 -- we want to look up y in case it has acquired more evaluation information by now.
109 lookupInScope (InScope in_scope n) v
112 go v = case lookupVarEnv in_scope v of
113 Just v' | v == v' -> v' -- Reached a fixed point
115 Nothing -> WARN( mustHaveLocalBinding v, ppr v )
120 uniqAway :: InScopeSet -> Var -> Var
121 -- (uniqAway in_scope v) finds a unique that is not used in the
122 -- in-scope set, and gives that to v. It starts with v's current unique, of course,
123 -- in the hope that it won't have to change it, nad thereafter uses a combination
124 -- of that and the hash-code found in the in-scope set
125 uniqAway (InScope set n) var
126 | not (var `elemVarSet` set) = var -- Nothing to do
129 orig_unique = getUnique var
130 try k | uniq `elemUniqSet_Directly` set = try (k +# 1#)
132 | opt_PprStyle_Debug && k ># 3#
133 = pprTrace "uniqAway:" (ppr (I# k) <+> text "tries" <+> ppr var <+> int (I# n))
134 setVarUnique var uniq
136 | otherwise = setVarUnique var uniq
138 uniq = deriveUnique orig_unique (I# (n *# k))
142 %************************************************************************
144 \subsection{Substitutions}
146 %************************************************************************
149 data Subst = Subst InScopeSet -- In scope
150 SubstEnv -- Substitution itself
151 -- INVARIANT 1: The (domain of the) in-scope set is a superset
152 -- of the free vars of the range of the substitution
153 -- that might possibly clash with locally-bound variables
154 -- in the thing being substituted in.
155 -- This is what lets us deal with name capture properly
156 -- It's a hard invariant to check...
157 -- There are various ways of causing it to happen:
158 -- - arrange that the in-scope set really is all the things in scope
159 -- - arrange that it's the free vars of the range of the substitution
160 -- - make it empty because all the free vars of the subst are fresh,
161 -- and hence can't possibly clash.a
163 -- INVARIANT 2: No variable is both in scope and in the domain of the substitution
164 -- Equivalently, the substitution is idempotent
170 The general plan about the substitution and in-scope set for Ids is as follows
172 * substId always adds new_id to the in-scope set.
173 new_id has a correctly-substituted type, but all its fragile IdInfo has been zapped.
174 That is added back in later. So new_id is the minimal thing it's
175 correct to substitute.
177 * substId adds a binding (DoneVar new_id occ) to the substitution if
178 EITHER the Id's unique has changed
179 OR the Id has interesting occurrence information
180 So in effect you can only get to interesting occurrence information
181 by looking up the *old* Id; it's not really attached to the new id
184 Note, though that the substitution isn't necessarily extended
185 if the type changes. Why not? Because of the next point:
187 * We *always, always* finish by looking up in the in-scope set
188 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
189 Reason: so that we never finish up with a "old" Id in the result.
190 An old Id might point to an old unfolding and so on... which gives a space leak.
192 [The DoneEx and DoneVar hits map to "new" stuff.]
194 * It follows that substExpr must not do a no-op if the substitution is empty.
195 substType is free to do so, however.
197 * When we come to a let-binding (say) we generate new IdInfo, including an
198 unfolding, attach it to the binder, and add this newly adorned binder to
199 the in-scope set. So all subsequent occurrences of the binder will get mapped
200 to the full-adorned binder, which is also the one put in the binding site.
202 * The in-scope "set" usually maps x->x; we use it simply for its domain.
203 But sometimes we have two in-scope Ids that are synomyms, and should
204 map to the same target: x->x, y->x. Notably:
206 That's why the "set" is actually a VarEnv Var
210 isEmptySubst :: Subst -> Bool
211 isEmptySubst (Subst _ env) = isEmptySubstEnv env
214 emptySubst = Subst emptyInScopeSet emptySubstEnv
216 mkSubst :: InScopeSet -> SubstEnv -> Subst
217 mkSubst in_scope env = Subst in_scope env
219 substEnv :: Subst -> SubstEnv
220 substEnv (Subst _ env) = env
222 substInScope :: Subst -> InScopeSet
223 substInScope (Subst in_scope _) = in_scope
225 zapSubstEnv :: Subst -> Subst
226 zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
228 extendSubst :: Subst -> Var -> SubstResult -> Subst
229 extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
231 extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
232 extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r)
234 lookupSubst :: Subst -> Var -> Maybe SubstResult
235 lookupSubst (Subst _ env) v = lookupSubstEnv env v
237 lookupIdSubst :: Subst -> Id -> SubstResult
238 -- Does the lookup in the in-scope set too
239 lookupIdSubst (Subst in_scope env) v
240 = case lookupSubstEnv env v of
241 Just (DoneId v' occ) -> DoneId (lookupInScope in_scope v') occ
243 Nothing -> DoneId v' (idOccInfo v')
244 -- We don't use DoneId for LoopBreakers, so the idOccInfo is
245 -- very important! If isFragileOccInfo returned True for
246 -- loop breakers we could avoid this call, but at the expense
247 -- of adding more to the substitution, and building new Ids
248 -- in substId a bit more often than really necessary
250 v' = lookupInScope in_scope v
252 isInScope :: Var -> Subst -> Bool
253 isInScope v (Subst in_scope _) = v `elemInScopeSet` in_scope
255 modifyInScope :: Subst -> Var -> Var -> Subst
256 modifyInScope (Subst in_scope env) old_v new_v = Subst (modifyInScopeSet in_scope old_v new_v) env
257 -- make old_v map to new_v
259 extendInScope :: Subst -> Var -> Subst
260 -- Add a new variable as in-scope
261 -- Remember to delete any existing binding in the substitution!
262 extendInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v)
263 (env `delSubstEnv` v)
265 extendInScopeList :: Subst -> [Var] -> Subst
266 extendInScopeList (Subst in_scope env) vs = Subst (extendInScopeSetList in_scope vs)
267 (delSubstEnvList env vs)
269 -- The "New" variants are guaranteed to be adding freshly-allocated variables
270 -- It's not clear that the gain (not needing to delete it from the substitution)
271 -- is worth the extra proof obligation
272 extendNewInScope :: Subst -> Var -> Subst
273 extendNewInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v) env
275 extendNewInScopeList :: Subst -> [Var] -> Subst
276 extendNewInScopeList (Subst in_scope env) vs = Subst (in_scope `extendInScopeSetList` vs) env
278 -------------------------------
279 bindSubst :: Subst -> Var -> Var -> Subst
280 -- Extend with a substitution, v1 -> Var v2
281 -- and extend the in-scopes with v2
282 bindSubst (Subst in_scope env) old_bndr new_bndr
283 = Subst (in_scope `extendInScopeSet` new_bndr)
284 (extendSubstEnv env old_bndr subst_result)
286 subst_result | isId old_bndr = DoneEx (Var new_bndr)
287 | otherwise = DoneTy (TyVarTy new_bndr)
289 unBindSubst :: Subst -> Var -> Var -> Subst
290 -- Reverse the effect of bindSubst
291 -- If old_bndr was already in the substitution, this doesn't quite work
292 unBindSubst (Subst in_scope env) old_bndr new_bndr
293 = Subst (in_scope `delInScopeSet` new_bndr) (delSubstEnv env old_bndr)
295 -- And the "List" forms
296 bindSubstList :: Subst -> [Var] -> [Var] -> Subst
297 bindSubstList subst old_bndrs new_bndrs
298 = foldl2 bindSubst subst old_bndrs new_bndrs
300 unBindSubstList :: Subst -> [Var] -> [Var] -> Subst
301 unBindSubstList subst old_bndrs new_bndrs
302 = foldl2 unBindSubst subst old_bndrs new_bndrs
305 -------------------------------
306 setInScope :: Subst -- Take env part from here
309 setInScope (Subst in_scope1 env1) in_scope2
310 = Subst in_scope2 env1
312 setSubstEnv :: Subst -- Take in-scope part from here
313 -> SubstEnv -- ... and env part from here
315 setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
319 %************************************************************************
321 \subsection{Type substitution}
323 %************************************************************************
326 type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
327 -- (We could have a variant of Subst, but it doesn't seem worth it.)
329 -- mkTyVarSubst generates the in-scope set from
330 -- the types given; but it's just a thunk so with a bit of luck
331 -- it'll never be evaluated
332 mkTyVarSubst :: [TyVar] -> [Type] -> Subst
333 mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys)) (zip_ty_env tyvars tys emptySubstEnv)
335 -- mkTopTyVarSubst is called when doing top-level substitutions.
336 -- Here we expect that the free vars of the range of the
337 -- substitution will be empty.
338 mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
339 mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
341 zip_ty_env [] [] env = env
342 zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
345 substTy works with general Substs, so that it can be called from substExpr too.
348 substTy :: Subst -> Type -> Type
349 substTy subst ty | isEmptySubst subst = ty
350 | otherwise = subst_ty subst ty
352 substClasses :: TyVarSubst -> ClassContext -> ClassContext
353 substClasses subst theta
354 | isEmptySubst subst = theta
355 | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta]
357 substTheta :: TyVarSubst -> ThetaType -> ThetaType
358 substTheta subst theta
359 | isEmptySubst subst = theta
360 | otherwise = map (substPred subst) theta
362 substPred :: TyVarSubst -> PredType -> PredType
363 substPred subst (Class clas tys) = Class clas (map (subst_ty subst) tys)
364 substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
369 go (TyConApp tc tys) = let args = map go tys
370 in args `seqList` TyConApp tc args
371 go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
372 go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
373 go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
374 go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr
375 go (NoteTy (IPNote nm) ty2) = (NoteTy $! IPNote nm) $! go ty2 -- Keep ip note
377 go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
378 go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
379 go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
381 Just (DoneTy ty') -> ty'
383 go (ForAllTy tv ty) = case substTyVar subst tv of
384 (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
387 Here is where we invent a new binder if necessary.
390 substTyVar :: Subst -> TyVar -> (Subst, TyVar)
391 substTyVar subst@(Subst in_scope env) old_var
392 | old_var == new_var -- No need to clone
393 -- But we *must* zap any current substitution for the variable.
395 -- (\x.e) with id_subst = [x |-> e']
396 -- Here we must simply zap the substitution for x
398 -- The new_id isn't cloned, but it may have a different type
399 -- etc, so we must return it, not the old id
400 = (Subst (in_scope `extendInScopeSet` new_var)
401 (delSubstEnv env old_var),
404 | otherwise -- The new binder is in scope so
405 -- we'd better rename it away from the in-scope variables
406 -- Extending the substitution to do this renaming also
407 -- has the (correct) effect of discarding any existing
408 -- substitution for that variable
409 = (Subst (in_scope `extendInScopeSet` new_var)
410 (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
413 new_var = uniqAway in_scope old_var
414 -- The uniqAway part makes sure the new variable is not already in scope
418 %************************************************************************
420 \section{Expression substitution}
422 %************************************************************************
424 This expression substituter deals correctly with name capture.
426 BUT NOTE that substExpr silently discards the
429 IdInfo attached to any binders in the expression. It's quite
430 tricky to do them 'right' in the case of mutually recursive bindings,
431 and so far has proved unnecessary.
434 substExpr :: Subst -> CoreExpr -> CoreExpr
436 -- NB: we do not do a no-op when the substitution is empty,
437 -- because we always want to substitute the variables in the
438 -- in-scope set for their occurrences. Why?
439 -- (a) because they may contain more information
440 -- (b) because leaving an un-substituted Id might cause
441 -- a space leak (its unfolding might point to an old version
442 -- of its right hand side).
446 go (Var v) = -- See the notes at the top, with the Subst data type declaration
447 case lookupIdSubst subst v of
449 ContEx env' e' -> substExpr (setSubstEnv subst env') e'
453 go (Type ty) = Type (go_ty ty)
454 go (Lit lit) = Lit lit
455 go (App fun arg) = App (go fun) (go arg)
456 go (Note note e) = Note (go_note note) (go e)
458 go (Lam bndr body) = Lam bndr' (substExpr subst' body)
460 (subst', bndr') = substBndr subst bndr
462 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
464 (subst', bndr') = substBndr subst bndr
466 go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
468 (subst', bndrs') = substBndrs subst (map fst pairs)
469 pairs' = bndrs' `zip` rhss'
470 rhss' = map (substExpr subst' . snd) pairs
472 go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts)
474 (subst', bndr') = substBndr subst bndr
476 go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
478 (subst', bndrs') = substBndrs subst bndrs
480 go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
483 go_ty ty = substTy subst ty
487 Substituting in binders is a rather tricky part of the whole compiler.
489 When we hit a binder we may need to
490 (a) apply the the type envt (if non-empty) to its type
491 (c) give it a new unique to avoid name clashes
494 substBndr :: Subst -> Var -> (Subst, Var)
496 | isTyVar bndr = substTyVar subst bndr
497 | otherwise = substId subst bndr
499 substBndrs :: Subst -> [Var] -> (Subst, [Var])
500 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
503 substIds :: Subst -> [Id] -> (Subst, [Id])
504 substIds subst bndrs = mapAccumL substId subst bndrs
506 substId :: Subst -> Id -> (Subst, Id)
507 -- Returns an Id with empty IdInfo
508 -- See the notes with the Subst data type decl at the
509 -- top of this module
511 substId subst@(Subst in_scope env) old_id
512 = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
514 id_ty = idType old_id
515 occ_info = idOccInfo old_id
517 -- id1 has its type zapped
518 id1 | noTypeSubst env
519 || isEmptyVarSet (tyVarsOfType id_ty) = old_id
520 -- The tyVarsOfType is cheaper than it looks
521 -- because we cache the free tyvars of the type
522 -- in a Note in the id's type itself
523 | otherwise = setIdType old_id (substTy subst id_ty)
525 -- id2 has its IdInfo zapped
526 id2 = zapFragileIdInfo id1
528 -- new_id is cloned if necessary
529 new_id = uniqAway in_scope id2
531 -- Extend the substitution if the unique has changed,
532 -- or there's some useful occurrence information
533 -- See the notes with substTyVar for the delSubstEnv
534 new_env | new_id /= old_id || isFragileOccInfo occ_info
535 = extendSubstEnv env old_id (DoneId new_id occ_info)
537 = delSubstEnv env old_id
540 Now a variant that unconditionally allocates a new unique.
543 substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, UniqSupply, [Id])
544 substAndCloneIds subst us [] = (subst, us, [])
545 substAndCloneIds subst us (b:bs) = case substAndCloneId subst us b of { (subst1, us1, b') ->
546 case substAndCloneIds subst1 us1 bs of { (subst2, us2, bs') ->
547 (subst2, us2, (b':bs')) }}
549 substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, UniqSupply, Id)
550 substAndCloneId subst@(Subst in_scope env) us old_id
551 = (Subst (in_scope `extendInScopeSet` new_id)
552 (extendSubstEnv env old_id (DoneEx (Var new_id))),
556 id_ty = idType old_id
557 id1 | noTypeSubst env || isEmptyVarSet (tyVarsOfType id_ty) = old_id
558 | otherwise = setIdType old_id (substTy subst id_ty)
560 id2 = zapFragileIdInfo id1
561 new_id = setVarUnique id2 (uniqFromSupply us1)
562 (us1,new_us) = splitUniqSupply us
566 %************************************************************************
568 \section{IdInfo substitution}
570 %************************************************************************
574 -> IdInfo -- Get un-substituted ones from here
575 -> IdInfo -- Substitute it and add it to here
576 -> IdInfo -- To give this
577 -- Seq'ing on the returned IdInfo is enough to cause all the
578 -- substitutions to happen completely
580 substIdInfo subst old_info new_info
583 info1 | isEmptyCoreRules old_rules = new_info
584 | otherwise = new_info `setSpecInfo` new_rules
585 -- setSpecInfo does a seq
587 new_rules = substRules subst old_rules
589 info2 | not (workerExists old_wrkr) = info1
590 | otherwise = info1 `setWorkerInfo` new_wrkr
591 -- setWorkerInfo does a seq
593 new_wrkr = substWorker subst old_wrkr
595 old_rules = specInfo old_info
596 old_wrkr = workerInfo old_info
598 substWorker :: Subst -> WorkerInfo -> WorkerInfo
599 -- Seq'ing on the returned WorkerInfo is enough to cause all the
600 -- substitutions to happen completely
602 substWorker subst NoWorker
604 substWorker subst (HasWorker w a)
605 = case lookupIdSubst subst w of
606 (DoneId w1 _) -> HasWorker w1 a
607 (DoneEx (Var w1)) -> HasWorker w1 a
608 (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
609 NoWorker -- Worker has got substituted away altogether
610 (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
613 substRules :: Subst -> CoreRules -> CoreRules
614 -- Seq'ing on the returned CoreRules is enough to cause all the
615 -- substitutions to happen completely
617 substRules subst rules
618 | isEmptySubst subst = rules
620 substRules subst (Rules rules rhs_fvs)
621 = seqRules new_rules `seq` new_rules
623 new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
625 do_subst rule@(BuiltinRule _) = rule
626 do_subst (Rule name tpl_vars lhs_args rhs)
627 = Rule name tpl_vars'
628 (map (substExpr subst') lhs_args)
629 (substExpr subst' rhs)
631 (subst', tpl_vars') = substBndrs subst tpl_vars
633 substVarSet subst fvs
634 = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
636 subst_fv subst fv = case lookupIdSubst subst fv of
637 DoneId fv' _ -> unitVarSet fv'
638 DoneEx expr -> exprFreeVars expr
639 DoneTy ty -> tyVarsOfType ty
640 ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)