2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[SimplVar]{Simplifier stuff related to variables}
9 simplBinder, simplBinders, simplTyBinder, simplTyBinders
12 #include "HsVersions.h"
14 import {-# SOURCE #-} Simplify ( simplExpr )
16 import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) )
18 import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
19 FormSummary, whnfOrBottom, okToInline,
21 import CoreUtils ( coreExprCc )
22 import BinderInfo ( BinderInfo, noBinderInfo )
24 import CostCentre ( CostCentre, noCostCentreAttached, isCurrentCostCentre )
25 import Id ( idType, getIdUnfolding,
26 getIdSpecialisation, setIdSpecialisation,
27 idMustBeINLINEd, idHasNoFreeTyVars,
28 mkIdWithNewUniq, mkIdWithNewType,
29 IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv
31 import SpecEnv ( lookupSpecEnv, substSpecEnv, isEmptySpecEnv )
32 import OccurAnal ( occurAnalyseGlobalExpr )
33 import Literal ( isNoRepLit )
34 import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
37 import Type ( instantiateTy, mkTyVarTy )
38 import TyCon ( tyConFamilySize )
39 import TyVar ( TyVar, cloneTyVar,
40 isEmptyTyVarEnv, addToTyVarEnv, delFromTyVarEnv,
41 addOneToTyVarSet, elementOfTyVarSet
43 import Maybes ( maybeToBool )
47 %************************************************************************
49 \subsection[Simplify-var]{Completing variables}
51 %************************************************************************
53 This where all the heavy-duty unfolding stuff comes into its own.
56 completeVar env inline_call var args result_ty
58 | maybeToBool maybe_magic_result
59 = tick MagicUnfold `thenSmpl_`
62 -- Look for existing specialisations before
64 | maybeToBool maybe_specialisation
65 = tick SpecialisationDone `thenSmpl_`
66 simplExpr (bindTyVars env spec_bindings)
67 (occurAnalyseGlobalExpr spec_template)
72 -- Look for an unfolding. There's a binding for the
73 -- thing, but perhaps we want to inline it anyway
75 && (idMustBeINLINEd var ||
76 (not essential_unfoldings_only
77 -- If "essential_unfoldings_only" is true we do no inlinings at all,
78 -- EXCEPT for things that absolutely have to be done
79 -- (see comments with idMustBeINLINEd)
80 && (inline_call || ok_to_inline)
81 && costCentreOk (getEnclosingCC env) (coreExprCc unf_template)))
84 pprTrace "Unfolding" (ppr var) $
85 simplCount `thenSmpl` \ n ->
87 pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var])
92 returnSmpl (mkGenApp (Var var) args)
95 tickUnfold var `thenSmpl_`
96 simplExpr unf_env unf_template args result_ty
98 | inline_call -- There was an InlineCall note, but we didn't inline!
99 = returnSmpl (mkGenApp (Note InlineCall (Var var')) args)
102 = returnSmpl (mkGenApp (Var var') args)
105 (var', occ_info, unfolding) = case lookupOutIdEnv env var of
107 Nothing -> (var, noBinderInfo, getIdUnfolding var)
109 ---------- Magic unfolding stuff
110 maybe_magic_result = case unfolding of
111 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
114 Just magic_result = maybe_magic_result
116 ---------- Unfolding stuff
117 has_unfolding = case unfolding of
118 CoreUnfolding _ _ _ -> True
121 CoreUnfolding form guidance unf_template = unfolding
122 unf_env = zapSubstEnvs env
123 -- The template is already simplified, so don't re-substitute.
124 -- This is VITAL. Consider
126 -- let y = \z -> ...x... in
128 -- We'll clone the inner \x, adding x->x' in the id_subst
129 -- Then when we inline y, we must *not* replace x by x' in
130 -- the inlined copy!!
132 ---------- Specialisation stuff
133 (ty_args, remaining_args) = initialTyArgs args
134 maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
135 Just (spec_bindings, spec_template) = maybe_specialisation
139 sw_chkr = getSwitchChecker env
140 essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
141 is_case_scrutinee = switchIsOn sw_chkr SimplCaseScrutinee
142 ok_to_inline = okToInline var (whnfOrBottom form) small_enough occ_info
143 small_enough = smallEnoughToInline var arg_evals is_case_scrutinee guidance
144 arg_evals = [is_evald arg | arg <- args, isValArg arg]
146 is_evald (VarArg v) = isEvaluated (lookupUnfolding env v)
147 is_evald (LitArg l) = True
152 -- costCentreOk checks that it's ok to inline this thing
153 -- The time it *isn't* is this:
155 -- f x = let y = E in
156 -- scc "foo" (...y...)
158 -- Here y has a "current cost centre", and we can't inline it inside "foo",
159 -- regardless of whether E is a WHNF or not.
161 costCentreOk cc_encl cc_rhs
162 = isCurrentCostCentre cc_encl || not (noCostCentreAttached cc_rhs)
166 %************************************************************************
168 \section{Dealing with a single binder}
170 %************************************************************************
172 When we hit a binder we may need to
173 (a) apply the the type envt (if non-empty) to its type
174 (b) apply the type envt and id envt to its SpecEnv (if it has one)
175 (c) give it a new unique to avoid name clashes
178 simplBinder :: SimplEnv -> InBinder -> SmplM (SimplEnv, OutId)
179 simplBinder env (id, occ_info)
180 | not_in_scope -- Not in scope, so no need to clone
181 && empty_ty_subst -- No type substitution to do inside the Id
182 && isNullIdEnv id_subst -- No id substitution to do inside the Id
184 env' = setIdEnv env (new_in_scope_ids id, id_subst)
186 returnSmpl (env', id)
191 -- I reckon the empty-env thing should catch
192 -- most no-free-tyvars things, so this test should be redundant
193 -- (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x))
196 -- id1 has its type zapped
197 id1 | empty_ty_subst = id
198 | otherwise = mkIdWithNewType id ty'
200 -- id2 has its SpecEnv zapped
201 id2 | isEmptySpecEnv spec_env = id1
202 | otherwise = setIdSpecialisation id1 spec_env'
205 -- No need to clone, but we *must* zap any current substitution
206 -- for the variable. For example:
207 -- (\x.e) with id_subst = [x |-> e']
208 -- Here we must simply zap the substitution for x
210 env' = setIdEnv env (new_in_scope_ids id2,
211 delOneFromIdEnv id_subst id)
213 returnSmpl (env', id2)
216 getUniqueSmpl `thenSmpl` \ uniq ->
218 id3 = mkIdWithNewUniq id2 uniq
219 env' = setIdEnv env (new_in_scope_ids id3,
220 addOneToIdEnv id_subst id (SubstVar id3))
222 returnSmpl (env', id3)
225 ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
227 empty_ty_subst = isEmptyTyVarEnv ty_subst
228 not_in_scope = not (id `elemIdEnv` in_scope_ids)
230 new_in_scope_ids id' = addOneToIdEnv in_scope_ids id' (id', occ_info, NoUnfolding)
233 ty' = instantiateTy ty_subst ty
235 spec_env = getIdSpecialisation id
236 spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
238 simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId])
239 simplBinders env binders = mapAccumLSmpl simplBinder env binders
243 simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar)
244 simplTyBinder env tyvar
245 | not (tyvar `elementOfTyVarSet` tyvars)
246 = -- No need to clone; but must zap any binding for tyvar
247 -- see comments with simplBinder above
249 env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar,
250 delFromTyVarEnv ty_subst tyvar)
252 returnSmpl (env', tyvar)
254 | otherwise -- Need to clone
255 = getUniqueSmpl `thenSmpl` \ uniq ->
257 tyvar' = cloneTyVar tyvar uniq
258 env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar',
259 addToTyVarEnv ty_subst tyvar (mkTyVarTy tyvar'))
261 returnSmpl (env', tyvar')
263 ((tyvars, ty_subst), (ids, id_subst)) = getEnvs env
265 simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
266 simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
270 substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
271 It exploits the known structure of a SpecEnv's RHS to have fewer
275 substSpecEnvRhs te ve rhs
278 go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
279 go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
280 Just (SubstVar v') -> VarArg v'
281 Just (SubstLit l) -> LitArg l
283 go te ve (Var v) = case lookupIdEnv ve v of
284 Just (SubstVar v') -> Var v'
285 Just (SubstLit l) -> Lit l
288 -- These equations are a bit half baked, because
289 -- they don't deal properly wih capture.
290 -- But I'm sure it'll never matter... sigh.
291 go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
293 te' = delFromTyVarEnv te tyvar
295 go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
297 ve' = delOneFromIdEnv ve v