2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section{Tidying up Core}
7 module TidyPgm( tidyCorePgm, tidyCoreExpr ) where
9 #include "HsVersions.h"
11 import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
13 import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
14 import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars )
15 import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules )
16 import PprCore ( pprIdRules )
17 import CoreLint ( showPass, endPass )
18 import CoreUtils ( exprArity )
21 import Var ( Id, Var )
22 import Id ( idType, idInfo, idName, idCoreRules,
23 isExportedId, mkVanillaGlobal, isLocalId,
26 import IdInfo {- loads of stuff -}
27 import NewDemand ( isBottomingSig, topSig )
28 import BasicTypes ( isNeverActive )
29 import Name ( getOccName, nameOccName, mkInternalName, mkExternalName,
30 localiseName, isExternalName, nameSrcLoc
32 import RnEnv ( lookupOrigNameCache, newExternalName )
33 import NameEnv ( filterNameEnv )
34 import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
35 import Type ( tidyTopType )
36 import Module ( Module, moduleName )
37 import HscTypes ( PersistentCompilerState( pcs_nc ),
38 NameCache( nsNames, nsUniqs ),
39 TypeEnv, extendTypeEnvList, typeEnvIds,
40 ModGuts(..), ModGuts, TyThing(..)
42 import FiniteMap ( lookupFM, addToFM )
43 import Maybes ( orElse )
44 import ErrUtils ( showPass, dumpIfSet_core )
45 import UniqFM ( mapUFM )
46 import UniqSupply ( splitUniqSupply, uniqFromSupply )
47 import List ( partition )
48 import Util ( mapAccumL )
49 import Maybe ( isJust )
55 %************************************************************************
57 \subsection{What goes on}
59 %************************************************************************
65 Step 1: Figure out external Ids
66 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
67 First we figure out which Ids are "external" Ids. An
68 "external" Id is one that is visible from outside the compilation
70 a) the user exported ones
71 b) ones mentioned in the unfoldings, workers,
72 or rules of externally-visible ones
73 This exercise takes a sweep of the bindings bottom to top. Actually,
74 in Step 2 we're also going to need to know which Ids should be
75 exported with their unfoldings, so we produce not an IdSet but an
79 Step 2: Tidy the program
80 ~~~~~~~~~~~~~~~~~~~~~~~~
81 Next we traverse the bindings top to bottom. For each *top-level*
84 1. Make it into a GlobalId
86 2. Give it a system-wide Unique.
87 [Even non-exported things need system-wide Uniques because the
88 byte-code generator builds a single Name->BCO symbol table.]
90 We use the NameCache kept in the PersistentCompilerState as the
91 source of such system-wide uniques.
93 For external Ids, use the original-name cache in the NameCache
94 to ensure that the unique assigned is the same as the Id had
95 in any previous compilation run.
97 3. If it's an external Id, make it have a global Name, otherwise
98 make it have a local Name.
99 This is used by the code generator to decide whether
100 to make the label externally visible
102 4. Give external Ids a "tidy" occurrence name. This means
103 we can print them in interface files without confusing
104 "x" (unique 5) with "x" (unique 10).
106 5. Give it its UTTERLY FINAL IdInfo; in ptic,
107 * Its IdDetails becomes VanillaGlobal, reflecting the fact that
108 from now on we regard it as a global, not local, Id
110 * its unfolding, if it should have one
112 * its arity, computed from the number of visible lambdas
114 * its CAF info, computed from what is free in its RHS
117 Finally, substitute these new top-level binders consistently
118 throughout, including in unfoldings. We also tidy binders in
119 RHSs, so that they print nicely in interfaces.
122 tidyCorePgm :: DynFlags
123 -> PersistentCompilerState
124 -> CgInfoEnv -- Information from the back end,
125 -- to be splatted into the IdInfo
127 -> IO (PersistentCompilerState, ModGuts)
129 tidyCorePgm dflags pcs cg_info_env
130 mod_impl@(ModGuts { mg_module = mod,
131 mg_types = env_tc, mg_insts = insts_tc,
132 mg_binds = binds_in, mg_rules = orphans_in })
133 = do { showPass dflags "Tidy Core"
135 ; let ext_ids = findExternalSet binds_in orphans_in
136 ; let ext_rules = findExternalRules binds_in orphans_in ext_ids
137 -- findExternalRules filters ext_rules to avoid binders that
138 -- aren't externally visible; but the externally-visible binders
139 -- are computed (by findExternalSet) assuming that all orphan
140 -- rules are exported. So in fact we may export more than we
141 -- need. (It's a sort of mutual recursion.)
143 -- We also make sure to avoid any exported binders. Consider
144 -- f{-u1-} = 1 -- Local decl
146 -- f{-u2-} = 2 -- Exported decl
148 -- The second exported decl must 'get' the name 'f', so we
149 -- have to put 'f' in the avoids list before we get to the first
150 -- decl. tidyTopId then does a no-op on exported binders.
151 ; let orig_ns = pcs_nc pcs
152 init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv)
153 avoids = [getOccName name | bndr <- typeEnvIds env_tc,
154 let name = idName bndr,
156 -- In computing our "avoids" list, we must include
158 -- all things with global names (assigned once and for
159 -- all by the renamer)
160 -- since their names are "taken".
161 -- The type environment is a convenient source of such things.
163 ; let ((orig_ns', occ_env, subst_env), tidy_binds)
164 = mapAccumL (tidyTopBind mod ext_ids cg_info_env)
165 init_tidy_env binds_in
167 ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
169 ; let pcs' = pcs { pcs_nc = orig_ns' }
171 ; let final_ids = [ id
173 , id <- bindersOf bind
174 , isExternalName (idName id)]
176 -- Dfuns are local Ids that might have
177 -- changed their unique during tidying
178 ; let lookup_dfun_id id = lookupVarEnv subst_env id `orElse`
179 pprPanic "lookup_dfun_id" (ppr id)
182 ; let tidy_type_env = mkFinalTypeEnv env_tc final_ids
183 tidy_dfun_ids = map lookup_dfun_id insts_tc
185 ; let tidy_result = mod_impl { mg_types = tidy_type_env,
186 mg_rules = tidy_rules,
187 mg_insts = tidy_dfun_ids,
188 mg_binds = tidy_binds }
190 ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
191 ; dumpIfSet_core dflags Opt_D_dump_simpl
193 (pprIdRules tidy_rules)
195 ; return (pcs', tidy_result)
198 tidyCoreExpr :: CoreExpr -> IO CoreExpr
199 tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr)
203 %************************************************************************
205 \subsection{Write a new interface file}
207 %************************************************************************
210 mkFinalTypeEnv :: TypeEnv -- From typechecker
214 mkFinalTypeEnv type_env final_ids
215 = extendTypeEnvList (filterNameEnv keep_it type_env)
218 -- The competed type environment is gotten from
219 -- a) keeping the types and classes
220 -- b) removing all Ids,
221 -- c) adding Ids with correct IdInfo, including unfoldings,
222 -- gotten from the bindings
223 -- From (c) we keep only those Ids with Global names;
224 -- the CoreTidy pass makes sure these are all and only
225 -- the externally-accessible ones
226 -- This truncates the type environment to include only the
227 -- exported Ids and things needed from them, which saves space
229 -- However, we do keep things like constructors, which should not appear
230 -- in interface files, because they are needed by importing modules when
231 -- using the compilation manager
233 -- We keep implicit Ids, because they won't appear
234 -- in the bindings from which final_ids are derived!
235 keep_it (AnId id) = isImplicitId id -- Remove all Ids except implicit ones
236 keep_it other = True -- Keep all TyCons and Classes
240 findExternalRules :: [CoreBind]
241 -> [IdCoreRule] -- Orphan rules
242 -> IdEnv a -- Ids that are exported, so we need their rules
244 -- The complete rules are gotten by combining
245 -- a) the orphan rules
246 -- b) rules embedded in the top-level Ids
247 findExternalRules binds orphan_rules ext_ids
248 | opt_OmitInterfacePragmas = []
250 = filter needed_rule (orphan_rules ++ local_rules)
253 | id <- bindersOfBinds binds,
254 id `elemVarEnv` ext_ids,
255 rule <- idCoreRules id
257 needed_rule (id, rule)
258 = not (isBuiltinRule rule)
259 -- We can't print builtin rules in interface files
260 -- Since they are built in, an importing module
261 -- will have access to them anyway
263 && not (any internal_id (varSetElems (ruleLhsFreeIds rule)))
264 -- Don't export a rule whose LHS mentions an Id that
265 -- is completely internal (i.e. not visible to an
268 internal_id id = isLocalId id && not (id `elemVarEnv` ext_ids)
271 %************************************************************************
273 \subsection{Step 1: finding externals}
275 %************************************************************************
278 findExternalSet :: [CoreBind] -> [IdCoreRule]
279 -> IdEnv Bool -- In domain => external
280 -- Range = True <=> show unfolding
281 -- Step 1 from the notes above
282 findExternalSet binds orphan_rules
283 = foldr find init_needed binds
285 orphan_rule_ids :: IdSet
286 orphan_rule_ids = unionVarSets [ ruleRhsFreeVars rule
287 | (_, rule) <- orphan_rules]
288 init_needed :: IdEnv Bool
289 init_needed = mapUFM (\_ -> False) orphan_rule_ids
290 -- The mapUFM is a bit cheesy. It is a cheap way
291 -- to turn the set of orphan_rule_ids, which we use to initialise
292 -- the sweep, into a mapping saying 'don't expose unfolding'
293 -- (When we come to the binding site we may change our mind, of course.)
295 find (NonRec id rhs) needed
296 | need_id needed id = addExternal (id,rhs) needed
298 find (Rec prs) needed = find_prs prs needed
300 -- For a recursive group we have to look for a fixed point
302 | null needed_prs = needed
303 | otherwise = find_prs other_prs new_needed
305 (needed_prs, other_prs) = partition (need_pr needed) prs
306 new_needed = foldr addExternal needed needed_prs
308 -- The 'needed' set contains the Ids that are needed by earlier
309 -- interface file emissions. If the Id isn't in this set, and isn't
310 -- exported, there's no need to emit anything
311 need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
312 need_pr needed_set (id,rhs) = need_id needed_set id
314 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
315 -- The Id is needed; extend the needed set
316 -- with it and its dependents (free vars etc)
317 addExternal (id,rhs) needed
318 = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
321 add_occ id needed = extendVarEnv needed id False
322 -- "False" because we don't know we need the Id's unfolding
323 -- We'll override it later when we find the binding site
325 new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
326 | otherwise = worker_ids `unionVarSet`
327 unfold_ids `unionVarSet`
331 dont_inline = isNeverActive (inlinePragInfo idinfo)
332 loop_breaker = isLoopBreaker (occInfo idinfo)
333 bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
334 spec_ids = rulesRhsFreeVars (specInfo idinfo)
335 worker_info = workerInfo idinfo
337 -- Stuff to do with the Id's unfolding
338 -- The simplifier has put an up-to-date unfolding
339 -- in the IdInfo, but the RHS will do just as well
340 unfolding = unfoldingInfo idinfo
341 rhs_is_small = not (neverUnfold unfolding)
343 -- We leave the unfolding there even if there is a worker
344 -- In GHCI the unfolding is used by importers
345 -- When writing an interface file, we omit the unfolding
346 -- if there is a worker
347 show_unfold = not bottoming_fn && -- Not necessary
350 rhs_is_small && -- Small enough
351 okToUnfoldInHiFile rhs -- No casms etc
353 unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
354 | otherwise = emptyVarSet
356 worker_ids = case worker_info of
357 HasWorker work_id _ -> unitVarSet work_id
358 otherwise -> emptyVarSet
362 %************************************************************************
364 \subsection{Step 2: top-level tidying}
366 %************************************************************************
370 type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var)
372 -- TopTidyEnv: when tidying we need to know
373 -- * ns: The NameCache, containing a unique supply and any pre-ordained Names.
374 -- These may have arisen because the
375 -- renamer read in an interface file mentioning M.$wf, say,
376 -- and assigned it unique r77. If, on this compilation, we've
377 -- invented an Id whose name is $wf (but with a different unique)
378 -- we want to rename it to have unique r77, so that we can do easy
379 -- comparisons with stuff from the interface file
381 -- * occ_env: The TidyOccEnv, which tells us which local occurrences
384 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
389 tidyTopBind :: Module
390 -> IdEnv Bool -- Domain = Ids that should be external
391 -- True <=> their unfolding is external too
393 -> TopTidyEnv -> CoreBind
394 -> (TopTidyEnv, CoreBind)
396 tidyTopBind mod ext_ids cg_info_env top_tidy_env (NonRec bndr rhs)
397 = ((orig,occ,subst) , NonRec bndr' rhs')
399 ((orig,occ,subst), bndr')
400 = tidyTopBinder mod ext_ids cg_info_env
401 rec_tidy_env rhs rhs' top_tidy_env bndr
402 rec_tidy_env = (occ,subst)
403 rhs' = tidyExpr rec_tidy_env rhs
405 tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs)
406 = (final_env, Rec prs')
408 (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
409 rec_tidy_env = (occ,subst)
411 do_one top_tidy_env (bndr,rhs)
412 = ((orig,occ,subst), (bndr',rhs'))
414 ((orig,occ,subst), bndr')
415 = tidyTopBinder mod ext_ids cg_info_env
416 rec_tidy_env rhs rhs' top_tidy_env bndr
418 rhs' = tidyExpr rec_tidy_env rhs
420 tidyTopBinder :: Module -> IdEnv Bool -> CgInfoEnv
421 -> TidyEnv -- The TidyEnv is used to tidy the IdInfo
422 -> CoreExpr -- RHS *before* tidying
423 -> CoreExpr -- RHS *after* tidying
424 -- The TidyEnv and the after-tidying RHS are
425 -- both are knot-tied: don't look at them!
426 -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
427 -- NB: tidyTopBinder doesn't affect the unique supply
429 tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs tidy_rhs
430 env@(ns2, occ_env2, subst_env2) id
431 -- This function is the heart of Step 2
432 -- The rec_tidy_env is the one to use for the IdInfo
433 -- It's necessary because when we are dealing with a recursive
434 -- group, a variable late in the group might be mentioned
435 -- in the IdInfo of one early in the group
437 -- The rhs is already tidied
439 = ((orig_env', occ_env', subst_env'), id')
441 (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2
444 ty' = tidyTopType (idType id)
445 idinfo = tidyTopIdInfo rec_tidy_env is_external
446 (idInfo id) unfold_info arity
447 (lookupCgInfo cg_info_env name')
449 id' = mkVanillaGlobal name' ty' idinfo
451 subst_env' = extendVarEnv subst_env2 id id'
453 maybe_external = lookupVarEnv ext_ids id
454 is_external = isJust maybe_external
456 -- Expose an unfolding if ext_ids tells us to
457 -- Remember that ext_ids maps an Id to a Bool:
458 -- True to show the unfolding, False to hide it
459 show_unfold = maybe_external `orElse` False
460 unfold_info | show_unfold = mkTopUnfolding tidy_rhs
461 | otherwise = noUnfolding
463 -- Usually the Id will have an accurate arity on it, because
464 -- the simplifier has just run, but not always.
465 -- One case I found was when the last thing the simplifier
466 -- did was to let-bind a non-atomic argument and then float
467 -- it to the top level. So it seems more robust just to
469 arity = exprArity rhs
473 -- tidyTopIdInfo creates the final IdInfo for top-level
474 -- binders. There are two delicate pieces:
476 -- * Arity. After CoreTidy, this arity must not change any more.
477 -- Indeed, CorePrep must eta expand where necessary to make
478 -- the manifest arity equal to the claimed arity.
480 -- * CAF info, which comes from the CoreToStg pass via a knot.
481 -- The CAF info will not be looked at by the downstream stuff:
482 -- it *generates* it, and knot-ties it back. It will only be
483 -- looked at by (a) MkIface when generating an interface file
484 -- (b) In GHCi, importing modules
485 -- Nevertheless, we add the info here so that it propagates to all
486 -- occurrences of the binders in RHSs, and hence to occurrences in
487 -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
489 -- An alterative would be to do a second pass over the unfoldings
490 -- of Ids, and rules, right at the top, but that would be a pain.
492 tidyTopIdInfo tidy_env is_external idinfo unfold_info arity cg_info
493 | opt_OmitInterfacePragmas -- If the interface file has no pragma info
494 = hasCafIdInfo -- then discard all info right here
495 -- This is not so important for *this* module, but it's
496 -- vital for ghc --make:
497 -- subsequent compilations must not see (e.g.) the arity if
498 -- the interface file does not contain arity
499 -- If they do, they'll exploit the arity; then the arity might
500 -- change, but the iface file doesn't change => recompilation
501 -- does not happen => disaster
503 -- This IdInfo will live long-term in the Id => need to make
504 -- conservative assumption about Caf-hood
506 | not is_external -- For internal Ids (not externally visible)
507 = vanillaIdInfo -- we only need enough info for code generation
508 -- Arity and strictness info are enough;
509 -- c.f. CoreTidy.tidyLetBndr
510 -- Use vanillaIdInfo (whose CafInfo is a panic) because we
511 -- should not need the CafInfo
513 `setAllStrictnessInfo` newStrictnessInfo idinfo
515 | otherwise -- Externally-visible Ids get the whole lot
519 `setAllStrictnessInfo` newStrictnessInfo idinfo
520 `setInlinePragInfo` inlinePragInfo idinfo
521 `setUnfoldingInfo` unfold_info
522 `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo)
523 -- NB: we throw away the Rules
524 -- They have already been extracted by findExternalRules
526 -- This is where we set names to local/global based on whether they really are
527 -- externally visible (see comment at the top of this module). If the name
528 -- was previously local, we have to give it a unique occurrence name if
529 -- we intend to externalise it.
530 tidyTopName mod ns occ_env external name
531 | global && internal = (ns, occ_env, localiseName name)
533 | global && external = (ns, occ_env, name)
534 -- Global names are assumed to have been allocated by the renamer,
535 -- so they already have the "right" unique
536 -- And it's a system-wide unique too
538 | local && internal = (ns_w_local, occ_env', new_local_name)
539 -- Even local, internal names must get a unique occurrence, because
540 -- if we do -split-objs we externalise the name later, in the code generator
542 -- Similarly, we must make sure it has a system-wide Unique, because
543 -- the byte-code generator builds a system-wide Name->BCO symbol table
545 | local && external = case lookupOrigNameCache ns_names mod occ' of
546 Just orig -> (ns, occ_env', orig)
547 Nothing -> (ns_w_global, occ_env', new_external_name)
548 -- If we want to externalise a currently-local name, check
549 -- whether we have already assigned a unique for it.
550 -- If so, use it; if not, extend the table (ns_w_global).
551 -- This is needed when *re*-compiling a module in GHCi; we want to
552 -- use the same name for externally-visible things as we did before.
555 global = isExternalName name
557 internal = not external
558 loc = nameSrcLoc name
560 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
562 ns_names = nsNames ns
563 (us1, us2) = splitUniqSupply (nsUniqs ns)
564 uniq = uniqFromSupply us1
565 new_local_name = mkInternalName uniq occ' loc
566 ns_w_local = ns { nsUniqs = us2 }
568 (ns_w_global, new_external_name) = newExternalName ns mod occ' loc
571 ------------ Worker --------------
572 tidyWorker tidy_env (HasWorker work_id wrap_arity)
573 = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
574 tidyWorker tidy_env other