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(..), dopt )
13 import CoreUnfold ( noUnfolding, mkTopUnfolding )
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, rhsIsStatic )
21 import Var ( Id, Var )
22 import Id ( idType, idInfo, idName, idCoreRules,
23 isExportedId, mkVanillaGlobal, isLocalId,
24 isImplicitId, idArity, setIdInfo, idCafInfo
26 import IdInfo {- loads of stuff -}
27 import NewDemand ( isBottomingSig, topSig )
28 import BasicTypes ( Arity, isNeverActive )
29 import Name ( getOccName, nameOccName, mkInternalName,
30 localiseName, isExternalName, nameSrcLoc
32 import RnEnv ( lookupOrigNameCache, newExternalName )
33 import NameEnv ( lookupNameEnv, filterNameEnv )
34 import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
35 import Type ( tidyTopType )
36 import Module ( Module )
37 import HscTypes ( PersistentCompilerState( pcs_nc ),
38 NameCache( nsNames, nsUniqs ),
39 TypeEnv, extendTypeEnvList, typeEnvIds,
40 ModGuts(..), ModGuts, TyThing(..)
42 import Maybes ( orElse )
43 import ErrUtils ( showPass, dumpIfSet_core )
44 import UniqFM ( mapUFM )
45 import UniqSupply ( splitUniqSupply, uniqFromSupply )
46 import List ( partition )
47 import Util ( mapAccumL )
48 import Maybe ( isJust )
50 import FastTypes hiding ( fastOr )
54 %************************************************************************
56 \subsection{What goes on}
58 %************************************************************************
64 Step 1: Figure out external Ids
65 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
66 First we figure out which Ids are "external" Ids. An
67 "external" Id is one that is visible from outside the compilation
69 a) the user exported ones
70 b) ones mentioned in the unfoldings, workers,
71 or rules of externally-visible ones
72 This exercise takes a sweep of the bindings bottom to top. Actually,
73 in Step 2 we're also going to need to know which Ids should be
74 exported with their unfoldings, so we produce not an IdSet but an
78 Step 2: Tidy the program
79 ~~~~~~~~~~~~~~~~~~~~~~~~
80 Next we traverse the bindings top to bottom. For each *top-level*
83 1. Make it into a GlobalId
85 2. Give it a system-wide Unique.
86 [Even non-exported things need system-wide Uniques because the
87 byte-code generator builds a single Name->BCO symbol table.]
89 We use the NameCache kept in the PersistentCompilerState as the
90 source of such system-wide uniques.
92 For external Ids, use the original-name cache in the NameCache
93 to ensure that the unique assigned is the same as the Id had
94 in any previous compilation run.
96 3. If it's an external Id, make it have a global Name, otherwise
97 make it have a local Name.
98 This is used by the code generator to decide whether
99 to make the label externally visible
101 4. Give external Ids a "tidy" occurrence name. This means
102 we can print them in interface files without confusing
103 "x" (unique 5) with "x" (unique 10).
105 5. Give it its UTTERLY FINAL IdInfo; in ptic,
106 * Its IdDetails becomes VanillaGlobal, reflecting the fact that
107 from now on we regard it as a global, not local, Id
109 * its unfolding, if it should have one
111 * its arity, computed from the number of visible lambdas
113 * its CAF info, computed from what is free in its RHS
116 Finally, substitute these new top-level binders consistently
117 throughout, including in unfoldings. We also tidy binders in
118 RHSs, so that they print nicely in interfaces.
121 tidyCorePgm :: DynFlags
122 -> PersistentCompilerState
124 -> IO (PersistentCompilerState, ModGuts)
126 tidyCorePgm dflags pcs
127 mod_impl@(ModGuts { mg_module = mod,
128 mg_types = env_tc, mg_insts = insts_tc,
129 mg_binds = binds_in, mg_rules = orphans_in })
130 = do { showPass dflags "Tidy Core"
132 ; let omit_iface_prags = dopt Opt_OmitInterfacePragmas dflags
133 ; let ext_ids = findExternalSet omit_iface_prags binds_in orphans_in
134 ; let ext_rules = findExternalRules omit_iface_prags binds_in orphans_in ext_ids
135 -- findExternalRules filters ext_rules to avoid binders that
136 -- aren't externally visible; but the externally-visible binders
137 -- are computed (by findExternalSet) assuming that all orphan
138 -- rules are exported. So in fact we may export more than we
139 -- need. (It's a sort of mutual recursion.)
141 -- We also make sure to avoid any exported binders. Consider
142 -- f{-u1-} = 1 -- Local decl
144 -- f{-u2-} = 2 -- Exported decl
146 -- The second exported decl must 'get' the name 'f', so we
147 -- have to put 'f' in the avoids list before we get to the first
148 -- decl. tidyTopId then does a no-op on exported binders.
149 ; let orig_ns = pcs_nc pcs
150 init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv)
151 avoids = [getOccName name | bndr <- typeEnvIds env_tc,
152 let name = idName bndr,
154 -- In computing our "avoids" list, we must include
156 -- all things with global names (assigned once and for
157 -- all by the renamer)
158 -- since their names are "taken".
159 -- The type environment is a convenient source of such things.
161 ; let ((orig_ns', occ_env, subst_env), tidy_binds)
162 = mapAccumL (tidyTopBind mod ext_ids)
163 init_tidy_env binds_in
165 ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
167 ; let pcs' = pcs { pcs_nc = orig_ns' }
169 ; let tidy_type_env = mkFinalTypeEnv omit_iface_prags env_tc tidy_binds
171 -- Dfuns are local Ids that might have
172 -- changed their unique during tidying. Remember
173 -- to lookup the id in the TypeEnv too, because
174 -- those Ids have had their IdInfo stripped if
176 ; let lookup_dfun_id id =
177 case lookupVarEnv subst_env id of
178 Nothing -> dfun_panic
180 case lookupNameEnv tidy_type_env (idName id) of
184 dfun_panic = pprPanic "lookup_dfun_id" (ppr id)
186 tidy_dfun_ids = map lookup_dfun_id insts_tc
188 ; let tidy_result = mod_impl { mg_types = tidy_type_env,
189 mg_rules = tidy_rules,
190 mg_insts = tidy_dfun_ids,
191 mg_binds = tidy_binds }
193 ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
194 ; dumpIfSet_core dflags Opt_D_dump_simpl
196 (pprIdRules tidy_rules)
198 ; return (pcs', tidy_result)
201 tidyCoreExpr :: CoreExpr -> IO CoreExpr
202 tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr)
206 %************************************************************************
208 \subsection{Write a new interface file}
210 %************************************************************************
213 mkFinalTypeEnv :: Bool -- Omit interface pragmas
214 -> TypeEnv -- From typechecker
215 -> [CoreBind] -- Final Ids
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 mkFinalTypeEnv omit_iface_prags type_env tidy_binds
234 = extendTypeEnvList (filterNameEnv keep_it type_env) final_ids
236 final_ids = [ AnId (strip_id_info id)
237 | bind <- tidy_binds,
238 id <- bindersOf bind,
239 isExternalName (idName id)]
242 | omit_iface_prags = id `setIdInfo` vanillaIdInfo
244 -- If the interface file has no pragma info then discard all
247 -- This is not so important for *this* module, but it's
248 -- vital for ghc --make:
249 -- subsequent compilations must not see (e.g.) the arity if
250 -- the interface file does not contain arity
251 -- If they do, they'll exploit the arity; then the arity might
252 -- change, but the iface file doesn't change => recompilation
253 -- does not happen => disaster
255 -- This IdInfo will live long-term in the Id => vanillaIdInfo makes
256 -- a conservative assumption about Caf-hood
258 -- We're not worried about occurrences of these Ids in unfoldings,
259 -- because in OmitInterfacePragmas mode we're stripping all the
260 -- unfoldings anyway.
262 -- We keep implicit Ids, because they won't appear
263 -- in the bindings from which final_ids are derived!
264 keep_it (AnId id) = isImplicitId id -- Remove all Ids except implicit ones
265 keep_it other = True -- Keep all TyCons and Classes
269 findExternalRules :: Bool -- Omit interface pragmas
271 -> [IdCoreRule] -- Orphan rules
272 -> IdEnv a -- Ids that are exported, so we need their rules
274 -- The complete rules are gotten by combining
275 -- a) the orphan rules
276 -- b) rules embedded in the top-level Ids
277 findExternalRules omit_iface_prags binds orphan_rules ext_ids
278 | omit_iface_prags = []
280 = filter needed_rule (orphan_rules ++ local_rules)
283 | id <- bindersOfBinds binds,
284 id `elemVarEnv` ext_ids,
285 rule <- idCoreRules id
287 needed_rule (id, rule)
288 = not (isBuiltinRule rule)
289 -- We can't print builtin rules in interface files
290 -- Since they are built in, an importing module
291 -- will have access to them anyway
293 && not (any internal_id (varSetElems (ruleLhsFreeIds rule)))
294 -- Don't export a rule whose LHS mentions an Id that
295 -- is completely internal (i.e. not visible to an
298 internal_id id = isLocalId id && not (id `elemVarEnv` ext_ids)
301 %************************************************************************
303 \subsection{Step 1: finding externals}
305 %************************************************************************
308 findExternalSet :: Bool -- omit interface pragmas
309 -> [CoreBind] -> [IdCoreRule]
310 -> IdEnv Bool -- In domain => external
311 -- Range = True <=> show unfolding
312 -- Step 1 from the notes above
313 findExternalSet omit_iface_prags binds orphan_rules
314 = foldr find init_needed binds
316 orphan_rule_ids :: IdSet
317 orphan_rule_ids = unionVarSets [ ruleRhsFreeVars rule
318 | (_, rule) <- orphan_rules]
319 init_needed :: IdEnv Bool
320 init_needed = mapUFM (\_ -> False) orphan_rule_ids
321 -- The mapUFM is a bit cheesy. It is a cheap way
322 -- to turn the set of orphan_rule_ids, which we use to initialise
323 -- the sweep, into a mapping saying 'don't expose unfolding'
324 -- (When we come to the binding site we may change our mind, of course.)
326 find (NonRec id rhs) needed
327 | need_id needed id = addExternal omit_iface_prags (id,rhs) needed
329 find (Rec prs) needed = find_prs prs needed
331 -- For a recursive group we have to look for a fixed point
333 | null needed_prs = needed
334 | otherwise = find_prs other_prs new_needed
336 (needed_prs, other_prs) = partition (need_pr needed) prs
337 new_needed = foldr (addExternal omit_iface_prags) needed needed_prs
339 -- The 'needed' set contains the Ids that are needed by earlier
340 -- interface file emissions. If the Id isn't in this set, and isn't
341 -- exported, there's no need to emit anything
342 need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
343 need_pr needed_set (id,rhs) = need_id needed_set id
345 addExternal :: Bool -> (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
346 -- The Id is needed; extend the needed set
347 -- with it and its dependents (free vars etc)
348 addExternal omit_iface_prags (id,rhs) needed
349 = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
352 add_occ id needed = extendVarEnv needed id False
353 -- "False" because we don't know we need the Id's unfolding
354 -- We'll override it later when we find the binding site
356 new_needed_ids | omit_iface_prags = emptyVarSet
357 | otherwise = worker_ids `unionVarSet`
358 unfold_ids `unionVarSet`
362 dont_inline = isNeverActive (inlinePragInfo idinfo)
363 loop_breaker = isLoopBreaker (occInfo idinfo)
364 bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
365 spec_ids = rulesRhsFreeVars (specInfo idinfo)
366 worker_info = workerInfo idinfo
368 -- Stuff to do with the Id's unfolding
369 -- The simplifier has put an up-to-date unfolding
370 -- in the IdInfo, but the RHS will do just as well
371 unfolding = unfoldingInfo idinfo
372 rhs_is_small = not (neverUnfold unfolding)
374 -- We leave the unfolding there even if there is a worker
375 -- In GHCI the unfolding is used by importers
376 -- When writing an interface file, we omit the unfolding
377 -- if there is a worker
378 show_unfold = not bottoming_fn && -- Not necessary
381 rhs_is_small -- Small enough
383 unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
384 | otherwise = emptyVarSet
386 worker_ids = case worker_info of
387 HasWorker work_id _ -> unitVarSet work_id
388 otherwise -> emptyVarSet
392 %************************************************************************
394 \subsection{Step 2: top-level tidying}
396 %************************************************************************
400 type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var)
402 -- TopTidyEnv: when tidying we need to know
403 -- * ns: The NameCache, containing a unique supply and any pre-ordained Names.
404 -- These may have arisen because the
405 -- renamer read in an interface file mentioning M.$wf, say,
406 -- and assigned it unique r77. If, on this compilation, we've
407 -- invented an Id whose name is $wf (but with a different unique)
408 -- we want to rename it to have unique r77, so that we can do easy
409 -- comparisons with stuff from the interface file
411 -- * occ_env: The TidyOccEnv, which tells us which local occurrences
414 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
419 tidyTopBind :: Module
420 -> IdEnv Bool -- Domain = Ids that should be external
421 -- True <=> their unfolding is external too
422 -> TopTidyEnv -> CoreBind
423 -> (TopTidyEnv, CoreBind)
425 tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (NonRec bndr rhs)
426 = ((orig,occ,subst) , NonRec bndr' rhs')
428 ((orig,occ,subst), bndr')
429 = tidyTopBinder mod ext_ids caf_info
430 rec_tidy_env rhs rhs' top_tidy_env bndr
431 rec_tidy_env = (occ,subst)
432 rhs' = tidyExpr rec_tidy_env rhs
433 caf_info = hasCafRefs subst1 (idArity bndr') rhs'
435 tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (Rec prs)
436 = (final_env, Rec prs')
438 (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
439 rec_tidy_env = (occ,subst)
441 do_one top_tidy_env (bndr,rhs)
442 = ((orig,occ,subst), (bndr',rhs'))
444 ((orig,occ,subst), bndr')
445 = tidyTopBinder mod ext_ids caf_info
446 rec_tidy_env rhs rhs' top_tidy_env bndr
448 rhs' = tidyExpr rec_tidy_env rhs
450 -- the CafInfo for a recursive group says whether *any* rhs in
451 -- the group may refer indirectly to a CAF (because then, they all do).
453 | or [ mayHaveCafRefs (hasCafRefs subst1 (idArity bndr) rhs)
454 | (bndr,rhs) <- prs ] = MayHaveCafRefs
455 | otherwise = NoCafRefs
457 tidyTopBinder :: Module -> IdEnv Bool -> CafInfo
458 -> TidyEnv -- The TidyEnv is used to tidy the IdInfo
459 -> CoreExpr -- RHS *before* tidying
460 -> CoreExpr -- RHS *after* tidying
461 -- The TidyEnv and the after-tidying RHS are
462 -- both are knot-tied: don't look at them!
463 -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
464 -- NB: tidyTopBinder doesn't affect the unique supply
466 tidyTopBinder mod ext_ids caf_info rec_tidy_env rhs tidy_rhs
467 env@(ns2, occ_env2, subst_env2) id
468 -- This function is the heart of Step 2
469 -- The rec_tidy_env is the one to use for the IdInfo
470 -- It's necessary because when we are dealing with a recursive
471 -- group, a variable late in the group might be mentioned
472 -- in the IdInfo of one early in the group
474 -- The rhs is already tidied
476 = ASSERT(isLocalId id) -- "all Ids defined in this module are local
477 -- until the CoreTidy phase" --GHC comentary
478 ((orig_env', occ_env', subst_env'), id')
480 (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2
483 ty' = tidyTopType (idType id)
484 idinfo = tidyTopIdInfo rec_tidy_env is_external
485 (idInfo id) unfold_info arity
488 id' = mkVanillaGlobal name' ty' idinfo
490 subst_env' = extendVarEnv subst_env2 id id'
492 maybe_external = lookupVarEnv ext_ids id
493 is_external = isJust maybe_external
495 -- Expose an unfolding if ext_ids tells us to
496 -- Remember that ext_ids maps an Id to a Bool:
497 -- True to show the unfolding, False to hide it
498 show_unfold = maybe_external `orElse` False
499 unfold_info | show_unfold = mkTopUnfolding tidy_rhs
500 | otherwise = noUnfolding
502 -- Usually the Id will have an accurate arity on it, because
503 -- the simplifier has just run, but not always.
504 -- One case I found was when the last thing the simplifier
505 -- did was to let-bind a non-atomic argument and then float
506 -- it to the top level. So it seems more robust just to
508 arity = exprArity rhs
511 -- tidyTopIdInfo creates the final IdInfo for top-level
512 -- binders. There are two delicate pieces:
514 -- * Arity. After CoreTidy, this arity must not change any more.
515 -- Indeed, CorePrep must eta expand where necessary to make
516 -- the manifest arity equal to the claimed arity.
518 -- * CAF info. This must also remain valid through to code generation.
519 -- We add the info here so that it propagates to all
520 -- occurrences of the binders in RHSs, and hence to occurrences in
521 -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
522 -- CoreToStg makes use of this when constructing SRTs.
524 tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info
525 | not is_external -- For internal Ids (not externally visible)
526 = vanillaIdInfo -- we only need enough info for code generation
527 -- Arity and strictness info are enough;
528 -- c.f. CoreTidy.tidyLetBndr
529 `setCafInfo` caf_info
531 `setAllStrictnessInfo` newStrictnessInfo idinfo
533 | otherwise -- Externally-visible Ids get the whole lot
535 `setCafInfo` caf_info
537 `setAllStrictnessInfo` newStrictnessInfo idinfo
538 `setInlinePragInfo` inlinePragInfo idinfo
539 `setUnfoldingInfo` unfold_info
540 `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo)
541 -- NB: we throw away the Rules
542 -- They have already been extracted by findExternalRules
545 -- This is where we set names to local/global based on whether they really are
546 -- externally visible (see comment at the top of this module). If the name
547 -- was previously local, we have to give it a unique occurrence name if
548 -- we intend to externalise it.
549 tidyTopName mod ns occ_env external name
550 | global && internal = (ns, occ_env, localiseName name)
552 | global && external = (ns, occ_env, name)
553 -- Global names are assumed to have been allocated by the renamer,
554 -- so they already have the "right" unique
555 -- And it's a system-wide unique too
557 | local && internal = (ns_w_local, occ_env', new_local_name)
558 -- Even local, internal names must get a unique occurrence, because
559 -- if we do -split-objs we externalise the name later, in the code generator
561 -- Similarly, we must make sure it has a system-wide Unique, because
562 -- the byte-code generator builds a system-wide Name->BCO symbol table
564 | local && external = case lookupOrigNameCache ns_names mod occ' of
565 Just orig -> (ns, occ_env', orig)
566 Nothing -> (ns_w_global, occ_env', new_external_name)
567 -- If we want to externalise a currently-local name, check
568 -- whether we have already assigned a unique for it.
569 -- If so, use it; if not, extend the table (ns_w_global).
570 -- This is needed when *re*-compiling a module in GHCi; we want to
571 -- use the same name for externally-visible things as we did before.
574 global = isExternalName name
576 internal = not external
577 loc = nameSrcLoc name
579 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
581 ns_names = nsNames ns
582 (us1, us2) = splitUniqSupply (nsUniqs ns)
583 uniq = uniqFromSupply us1
584 new_local_name = mkInternalName uniq occ' loc
585 ns_w_local = ns { nsUniqs = us2 }
587 (ns_w_global, new_external_name) = newExternalName ns mod occ' loc
590 ------------ Worker --------------
591 tidyWorker tidy_env (HasWorker work_id wrap_arity)
592 = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
593 tidyWorker tidy_env other
597 %************************************************************************
599 \subsection{Figuring out CafInfo for an expression}
601 %************************************************************************
603 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
604 We mark such things as `MayHaveCafRefs' because this information is
605 used to decide whether a particular closure needs to be referenced
608 There are two reasons for setting MayHaveCafRefs:
609 a) The RHS is a CAF: a top-level updatable thunk.
610 b) The RHS refers to something that MayHaveCafRefs
612 Possible improvement: In an effort to keep the number of CAFs (and
613 hence the size of the SRTs) down, we could also look at the expression and
614 decide whether it requires a small bounded amount of heap, so we can ignore
615 it as a CAF. In these cases however, we would need to use an additional
616 CAF list to keep track of non-collectable CAFs.
619 hasCafRefs :: VarEnv Var -> Arity -> CoreExpr -> CafInfo
620 hasCafRefs p arity expr
621 | is_caf || mentions_cafs = MayHaveCafRefs
622 | otherwise = NoCafRefs
624 mentions_cafs = isFastTrue (cafRefs p expr)
625 is_caf = not (arity > 0 || rhsIsStatic expr)
626 -- NB. we pass in the arity of the expression, which is expected
627 -- to be calculated by exprArity. This is because exprArity
628 -- knows how much eta expansion is going to be done by
629 -- CorePrep later on, and we don't want to duplicate that
630 -- knowledge in rhsIsStatic below.
633 -- imported Ids first:
634 | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id))
635 -- now Ids local to this module:
637 case lookupVarEnv p id of
638 Just id' -> fastBool (mayHaveCafRefs (idCafInfo id'))
639 Nothing -> fastBool False
641 cafRefs p (Lit l) = fastBool False
642 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
643 cafRefs p (Lam x e) = cafRefs p e
644 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
645 cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
646 cafRefs p (Note n e) = cafRefs p e
647 cafRefs p (Type t) = fastBool False
649 cafRefss p [] = fastBool False
650 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
652 -- hack for lazy-or over FastBool.
653 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))