2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section{Tidying up Core}
12 #include "HsVersions.h"
14 import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas, dopt )
16 import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
17 import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars )
18 import CoreLint ( showPass, endPass )
21 import Var ( Id, Var )
22 import Id ( idType, idInfo, idName, isExportedId,
23 mkVanillaId, mkId, isLocalId, omitIfaceSigForId,
24 setIdStrictness, setIdDemandInfo,
26 import IdInfo ( mkIdInfo,
27 IdFlavour(..), flavourInfo, ppFlavourInfo,
28 specInfo, setSpecInfo,
30 inlinePragInfo, setInlinePragInfo, isNeverInlinePrag,
31 strictnessInfo, setStrictnessInfo, isBottomingStrictness,
32 unfoldingInfo, setUnfoldingInfo,
34 occInfo, isLoopBreaker,
35 workerInfo, setWorkerInfo, WorkerInfo(..)
37 import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
38 localiseName, mkLocalName, isGlobalName
40 import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
41 import Type ( tidyTopType, tidyType, tidyTyVar )
42 import Module ( Module, moduleName )
43 import HscTypes ( PersistentCompilerState( pcs_PRS ), PersistentRenamerState( prsOrig ),
44 OrigNameEnv( origNames ), OrigNameNameEnv
46 import Unique ( Uniquable(..) )
47 import FiniteMap ( lookupFM, addToFM )
48 import Maybes ( maybeToBool, orElse )
49 import ErrUtils ( showPass )
50 import SrcLoc ( noSrcLoc )
51 import UniqFM ( mapUFM )
53 import List ( partition )
54 import Util ( mapAccumL )
59 %************************************************************************
61 \subsection{What goes on}
63 %************************************************************************
69 Step 1: Figure out external Ids
70 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
71 First we figure out which Ids are "external" Ids. An
72 "external" Id is one that is visible from outside the compilation
74 a) the user exported ones
75 b) ones mentioned in the unfoldings, workers,
76 or rules of externally-visible ones
77 This exercise takes a sweep of the bindings bottom to top. Actually,
78 in Step 2 we're also going to need to know which Ids should be
79 exported with their unfoldings, so we produce not an IdSet but an
84 Step 2: Tidy the program
85 ~~~~~~~~~~~~~~~~~~~~~~~~
86 Next we traverse the bindings top to bottom. For each top-level
89 - Make all external Ids have Global names and vice versa
90 This is used by the code generator to decide whether
91 to make the label externally visible
93 - Give external ids a "tidy" occurrence name. This means
94 we can print them in interface files without confusing
95 "x" (unique 5) with "x" (unique 10).
97 - Give external Ids the same Unique as they had before
98 if the name is in the renamer's name cache
100 - Give the Id its final IdInfo; in ptic,
101 * Its flavour becomes ConstantId, reflecting the fact that
102 from now on we regard it as a constant, not local, Id
103 * its unfolding, if it should have one
105 Finally, substitute these new top-level binders consistently
106 throughout, including in unfoldings. We also tidy binders in
107 RHSs, so that they print nicely in interfaces.
110 tidyCorePgm :: DynFlags -> Module
111 -> PersistentCompilerState
112 -> [CoreBind] -> [IdCoreRule]
113 -> IO (PersistentCompilerState, [CoreBind], [IdCoreRule])
114 tidyCorePgm dflags mod pcs binds_in orphans_in
115 = do { showPass dflags "Tidy Core"
117 ; let ext_ids = findExternalSet binds_in orphans_in
119 ; let ((orig_env', occ_env, subst_env), binds_out)
120 = mapAccumL (tidyTopBind mod ext_ids) init_tidy_env binds_in
122 ; let orphans_out = tidyIdRules (occ_env,subst_env) orphans_in
124 ; let pcs' = pcs { pcs_PRS = prs { prsOrig = orig { origNames = orig_env' }}}
126 ; endPass dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags ||
127 dopt Opt_D_verbose_core2core dflags)
130 ; return (pcs', binds_out, orphans_out)
133 -- We also make sure to avoid any exported binders. Consider
134 -- f{-u1-} = 1 -- Local decl
136 -- f{-u2-} = 2 -- Exported decl
138 -- The second exported decl must 'get' the name 'f', so we
139 -- have to put 'f' in the avoids list before we get to the first
140 -- decl. tidyTopId then does a no-op on exported binders.
143 orig_env = origNames orig
145 init_tidy_env = (orig_env, initTidyOccEnv avoids, emptyVarEnv)
146 avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
147 isGlobalName (idName bndr)]
151 %************************************************************************
153 \subsection{Step 1: finding externals}
155 %************************************************************************
158 findExternalSet :: [CoreBind] -> [IdCoreRule]
159 -> IdEnv Bool -- True <=> show unfolding
160 -- Step 1 from the notes above
161 findExternalSet binds orphan_rules
162 = foldr find init_needed binds
164 orphan_rule_ids :: IdSet
165 orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isIdAndLocal rule
166 | (_, rule) <- orphan_rules]
167 init_needed :: IdEnv Bool
168 init_needed = mapUFM (\_ -> False) orphan_rule_ids
169 -- The mapUFM is a bit cheesy. It is a cheap way
170 -- to turn the set of orphan_rule_ids, which we use to initialise
171 -- the sweep, into a mapping saying 'don't expose unfolding'
172 -- (When we come to the binding site we may change our mind, of course.)
174 find (NonRec id rhs) needed
175 | need_id needed id = addExternal (id,rhs) needed
177 find (Rec prs) needed = find_prs prs needed
179 -- For a recursive group we have to look for a fixed point
181 | null needed_prs = needed
182 | otherwise = find_prs other_prs new_needed
184 (needed_prs, other_prs) = partition (need_pr needed) prs
185 new_needed = foldr addExternal needed needed_prs
187 -- The 'needed' set contains the Ids that are needed by earlier
188 -- interface file emissions. If the Id isn't in this set, and isn't
189 -- exported, there's no need to emit anything
190 need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
191 need_pr needed_set (id,rhs) = need_id needed_set id
193 isIdAndLocal id = isId id && isLocalId id
195 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
196 -- The Id is needed; extend the needed set
197 -- with it and its dependents (free vars etc)
198 addExternal (id,rhs) needed
199 = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
202 add_occ id needed = extendVarEnv needed id False
203 -- "False" because we don't know we need the Id's unfolding
204 -- We'll override it later when we find the binding site
206 new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
207 | otherwise = worker_ids `unionVarSet`
208 unfold_ids `unionVarSet`
212 dont_inline = isNeverInlinePrag (inlinePragInfo idinfo)
213 loop_breaker = isLoopBreaker (occInfo idinfo)
214 bottoming_fn = isBottomingStrictness (strictnessInfo idinfo)
215 spec_ids = rulesRhsFreeVars (specInfo idinfo)
216 worker_info = workerInfo idinfo
218 -- Stuff to do with the Id's unfolding
219 -- The simplifier has put an up-to-date unfolding
220 -- in the IdInfo, but the RHS will do just as well
221 unfolding = unfoldingInfo idinfo
222 rhs_is_small = not (neverUnfold unfolding)
224 -- We leave the unfolding there even if there is a worker
225 -- In GHCI the unfolding is used by importers
226 -- When writing an interface file, we omit the unfolding
227 -- if there is a worker
228 show_unfold = not bottoming_fn && -- Not necessary
231 rhs_is_small && -- Small enough
232 okToUnfoldInHiFile rhs -- No casms etc
234 unfold_ids | show_unfold = exprSomeFreeVars isIdAndLocal rhs
235 | otherwise = emptyVarSet
237 worker_ids = case worker_info of
238 HasWorker work_id _ -> unitVarSet work_id
239 otherwise -> emptyVarSet
243 %************************************************************************
245 \subsection{Step 2: top-level tidying}
247 %************************************************************************
251 type TopTidyEnv = (OrigNameNameEnv, TidyOccEnv, VarEnv Var)
253 -- TopTidyEnv: when tidying we need to know
254 -- * orig_env: Any pre-ordained Names. These may have arisen because the
255 -- renamer read in an interface file mentioning M.$wf, say,
256 -- and assigned it unique r77. If, on this compilation, we've
257 -- invented an Id whose name is $wf (but with a different unique)
258 -- we want to rename it to have unique r77, so that we can do easy
259 -- comparisons with stuff from the interface file
261 -- * occ_env: The TidyOccEnv, which tells us which local occurrences are 'used'
263 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
268 tidyTopBind :: Module
269 -> IdEnv Bool -- Domain = Ids that should be exernal
270 -- True <=> their unfolding is external too
271 -> TopTidyEnv -> CoreBind
272 -> (TopTidyEnv, CoreBind)
274 tidyTopBind mod ext_ids env (NonRec bndr rhs)
275 = (env', NonRec bndr' rhs')
277 rhs' = tidyTopRhs env rhs
278 (env', bndr') = tidyTopBinder mod ext_ids env rhs' env bndr
280 tidyTopBind mod ext_ids env (Rec prs)
281 = (final_env, Rec prs')
283 (final_env, prs') = mapAccumL do_one env prs
284 do_one env (bndr,rhs) = (env', (bndr', rhs'))
286 rhs' = tidyTopRhs final_env rhs
287 (env', bndr') = tidyTopBinder mod ext_ids final_env
290 tidyTopRhs :: TopTidyEnv -> CoreExpr -> CoreExpr
291 -- Just an impedence matcher
292 tidyTopRhs (_, occ_env, subst_env) rhs = tidyExpr (occ_env, subst_env) rhs
294 tidyTopBinder :: Module -> IdEnv Bool
295 -> TopTidyEnv -> CoreExpr
296 -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
297 tidyTopBinder mod ext_ids env_idinfo rhs env@(orig_env, occ_env, subst_env) id
298 | omitIfaceSigForId id -- Don't mess with constructors,
299 = (env, id) -- record selectors, and the like
302 -- This function is the heart of Step 2
303 -- The second env is the one to use for the IdInfo
304 -- It's necessary because when we are dealing with a recursive
305 -- group, a variable late in the group might be mentioned
306 -- in the IdInfo of one early in the group
308 -- The rhs is already tidied
310 = ((orig_env', occ_env', subst_env'), id')
312 (orig_env', occ_env', name') = tidyTopName mod orig_env occ_env
315 ty' = tidyTopType (idType id)
316 idinfo' = tidyIdInfo env_idinfo is_external unfold_info id
317 id' = mkId name' ty' idinfo'
318 subst_env' = extendVarEnv subst_env id id'
320 maybe_external = lookupVarEnv ext_ids id
321 is_external = maybeToBool maybe_external
323 -- Expose an unfolding if ext_ids tells us to
324 show_unfold = maybe_external `orElse` False
325 unfold_info | show_unfold = mkTopUnfolding rhs
326 | otherwise = noUnfolding
328 tidyIdInfo (_, occ_env, subst_env) is_external unfold_info id
329 | opt_OmitInterfacePragmas || not is_external
330 -- No IdInfo if the Id isn't external, or if we don't have -O
331 = mkIdInfo new_flavour
332 `setStrictnessInfo` strictnessInfo core_idinfo
333 -- Keep strictness info; it's used by the code generator
336 = mkIdInfo new_flavour
337 `setCprInfo` cprInfo core_idinfo
338 `setStrictnessInfo` strictnessInfo core_idinfo
339 `setInlinePragInfo` inlinePragInfo core_idinfo
340 `setUnfoldingInfo` unfold_info
341 `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo)
342 `setSpecInfo` tidyRules tidy_env (specInfo core_idinfo)
344 tidy_env = (occ_env, subst_env)
345 core_idinfo = idInfo id
347 -- A DFunId must stay a DFunId, so that we can gather the
348 -- DFunIds up later. Other local things become ConstantIds.
349 new_flavour = case flavourInfo core_idinfo of
350 VanillaId -> ConstantId
351 ExportedId -> ConstantId
352 DictFunId -> DictFunId
353 flavour -> pprTrace "tidyIdInfo" (ppr id <+> ppFlavourInfo flavour)
356 tidyTopName mod orig_env occ_env external name
357 | global && internal = (orig_env, occ_env, localiseName name)
358 | local && internal = (orig_env, occ_env', setNameOcc name occ')
359 | global && external = (orig_env, occ_env, name)
360 | local && external = globalise
362 -- If we want to globalise a currently-local name, check
363 -- whether we have already assigned a unique for it.
364 -- If so, use it; if not, extend the table
365 globalise = case lookupFM orig_env key of
366 Just orig -> (orig_env, occ_env', orig)
367 Nothing -> (addToFM orig_env key global_name, occ_env', global_name)
369 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
370 key = (moduleName mod, occ')
371 global_name = globaliseName (setNameOcc name occ') mod
372 global = isGlobalName name
374 internal = not external
376 tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
377 tidyIdRules env rules
378 = [ (tidyVarOcc env fn, tidyRule env rule) | (fn,rule) <- rules ]
381 tidyWorker tidy_env (HasWorker work_id wrap_arity)
382 = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
383 tidyWorker tidy_env NoWorker
386 tidyRules :: TidyEnv -> CoreRules -> CoreRules
387 tidyRules env (Rules rules fvs)
388 = Rules (map (tidyRule env) rules)
389 (foldVarSet tidy_set_elem emptyVarSet fvs)
391 tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
393 tidyRule :: TidyEnv -> CoreRule -> CoreRule
394 tidyRule env rule@(BuiltinRule _) = rule
395 tidyRule env (Rule name vars tpl_args rhs)
396 = (Rule name vars' (map (tidyExpr env') tpl_args) (tidyExpr env' rhs))
398 (env', vars') = tidyBndrs env vars
402 %************************************************************************
404 \subsection{Step 2: inner tidying
406 %************************************************************************
411 -> (TidyEnv, CoreBind)
412 tidyBind env (NonRec bndr rhs)
414 (env', bndr') = tidyBndr env bndr
415 rhs' = tidyExpr env' rhs
416 -- We use env' when tidying the RHS even though it's not
417 -- strictly necessary; it makes the tidied code pretty
418 -- hard to read if we don't!
420 (env', NonRec bndr' rhs')
422 tidyBind env (Rec prs)
423 = (final_env, Rec prs')
425 (final_env, prs') = mapAccumL do_one env prs
426 do_one env (bndr,rhs) = (env', (bndr', rhs'))
428 (env', bndr') = tidyBndr env bndr
429 rhs' = tidyExpr final_env rhs
431 tidyExpr env (Type ty) = Type (tidyType env ty)
432 tidyExpr env (Lit lit) = Lit lit
433 tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
434 tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
436 tidyExpr env (Let b e) = Let b' (tidyExpr env' e)
438 (env', b') = tidyBind env b
440 tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
442 (env', b') = tidyBndr env b
444 tidyExpr env (Var v) = Var (tidyVarOcc env v)
446 tidyExpr env (Lam b e) = Lam b' (tidyExpr env' e)
448 (env', b') = tidyBndr env b
450 tidyAlt env (con, vs, rhs) = (con, vs', tidyExpr env' rhs)
452 (env', vs') = tidyBndrs env vs
454 tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
456 tidyNote env note = note
460 %************************************************************************
462 \subsection{Tidying up non-top-level binders}
464 %************************************************************************
467 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
471 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
472 tidyBndr env var | isTyVar var = tidyTyVar env var
473 | otherwise = tidyId env var
475 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
476 tidyBndrs env vars = mapAccumL tidyBndr env vars
478 tidyId :: TidyEnv -> Id -> (TidyEnv, Id)
479 tidyId env@(tidy_env, var_env) id
480 = -- Non-top-level variables
482 -- Give the Id a fresh print-name, *and* rename its type
483 -- The SrcLoc isn't important now, though we could extract it from the Id
484 name' = mkLocalName (getUnique id) occ' noSrcLoc
485 (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
486 ty' = tidyType env (idType id)
488 id' = mkVanillaId name' ty'
489 `setIdStrictness` strictnessInfo idinfo
490 `setIdDemandInfo` demandInfo idinfo
491 -- NB: This throws away the IdInfo of the Id, which we
492 -- no longer need. That means we don't need to
493 -- run over it with env, nor renumber it.
495 -- The exception is strictness and demand info, which
496 -- is used to decide whether to use let or case for
497 -- function arguments and let bindings
499 var_env' = extendVarEnv var_env id id'
501 ((tidy_env', var_env'), id')