prettyprint 'hinted' things in a more readable way
[ghc-hetmet.git] / compiler / main / TidyPgm.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section{Tidying up Core}
5
6 \begin{code}
7 {-# OPTIONS -w #-}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12 -- for details
13
14 module TidyPgm( mkBootModDetails, tidyProgram ) where
15
16 #include "HsVersions.h"
17
18 import DynFlags         ( DynFlag(..), DynFlags(..), dopt )
19 import CoreSyn
20 import CoreUnfold       ( noUnfolding, mkTopUnfolding )
21 import CoreFVs          ( ruleLhsFreeIds, exprSomeFreeVars )
22 import CoreTidy         ( tidyExpr, tidyVarOcc, tidyRules )
23 import PprCore          ( pprRules )
24 import CoreLint         ( showPass, endPass )
25 import CoreUtils        ( exprArity, rhsIsStatic )
26 import VarEnv
27 import VarSet
28 import Var              ( Id, Var )
29 import Id               ( idType, idInfo, idName, idCoreRules, isGlobalId,
30                           isExportedId, mkVanillaGlobal, isLocalId, isNaughtyRecordSelector,
31                           idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo,
32                           isTickBoxOp
33                         ) 
34 import IdInfo           {- loads of stuff -}
35 import InstEnv          ( Instance, DFunId, instanceDFunId, setInstanceDFunId )
36 import NewDemand        ( isBottomingSig, topSig )
37 import BasicTypes       ( Arity, isNeverActive, isNonRuleLoopBreaker )
38 import Name
39 import NameSet          ( NameSet, elemNameSet )
40 import IfaceEnv         ( allocateGlobalBinder )
41 import NameEnv          ( filterNameEnv, mapNameEnv )
42 import OccName          ( TidyOccEnv, initTidyOccEnv, tidyOccName )
43 import Type             ( tidyTopType )
44 import TcType           ( isFFITy )
45 import DataCon          ( dataConName, dataConFieldLabels, dataConWrapId_maybe )
46 import TyCon            ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, 
47                           newTyConRep, tyConSelIds, isAlgTyCon,
48                           isEnumerationTyCon, isOpenTyCon )
49 import Class            ( classSelIds )
50 import Module           ( Module )
51 import HscTypes
52 import Maybes           ( orElse, mapCatMaybes )
53 import ErrUtils         ( showPass, dumpIfSet_core )
54 import PackageConfig    ( PackageId )
55 import UniqSupply       ( splitUniqSupply, uniqFromSupply )
56 import Outputable
57 import FastTypes  hiding ( fastOr )
58
59 import Data.List        ( partition )
60 import Data.Maybe       ( isJust )
61 import Data.IORef       ( IORef, readIORef, writeIORef )
62 \end{code}
63
64
65 Constructing the TypeEnv, Instances, Rules from which the ModIface is
66 constructed, and which goes on to subsequent modules in --make mode.
67
68 Most of the interface file is obtained simply by serialising the
69 TypeEnv.  One important consequence is that if the *interface file*
70 has pragma info if and only if the final TypeEnv does. This is not so
71 important for *this* module, but it's essential for ghc --make:
72 subsequent compilations must not see (e.g.) the arity if the interface
73 file does not contain arity If they do, they'll exploit the arity;
74 then the arity might change, but the iface file doesn't change =>
75 recompilation does not happen => disaster. 
76
77 For data types, the final TypeEnv will have a TyThing for the TyCon,
78 plus one for each DataCon; the interface file will contain just one
79 data type declaration, but it is de-serialised back into a collection
80 of TyThings.
81
82 %************************************************************************
83 %*                                                                      *
84                 Plan A: simpleTidyPgm
85 %*                                                                      * 
86 %************************************************************************
87
88
89 Plan A: mkBootModDetails: omit pragmas, make interfaces small
90 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
91 * Ignore the bindings
92
93 * Drop all WiredIn things from the TypeEnv 
94         (we never want them in interface files)
95
96 * Retain all TyCons and Classes in the TypeEnv, to avoid
97         having to find which ones are mentioned in the
98         types of exported Ids
99
100 * Trim off the constructors of non-exported TyCons, both
101         from the TyCon and from the TypeEnv
102
103 * Drop non-exported Ids from the TypeEnv
104
105 * Tidy the types of the DFunIds of Instances, 
106   make them into GlobalIds, (they already have External Names)
107   and add them to the TypeEnv
108
109 * Tidy the types of the (exported) Ids in the TypeEnv,
110   make them into GlobalIds (they already have External Names)
111
112 * Drop rules altogether
113
114 * Tidy the bindings, to ensure that the Caf and Arity
115   information is correct for each top-level binder; the 
116   code generator needs it. And to ensure that local names have
117   distinct OccNames in case of object-file splitting
118
119 \begin{code}
120 mkBootModDetails :: HscEnv -> ModGuts -> IO ModDetails
121 -- This is Plan A: make a small type env when typechecking only,
122 -- or when compiling a hs-boot file, or simply when not using -O
123 --
124 -- We don't look at the bindings at all -- there aren't any
125 -- for hs-boot files
126
127 mkBootModDetails hsc_env (ModGuts { mg_module    = mod
128                                   , mg_exports   = exports
129                                   , mg_types     = type_env
130                                   , mg_insts     = insts
131                                   , mg_fam_insts = fam_insts
132                                   , mg_modBreaks = modBreaks   
133                                   })
134   = do  { let dflags = hsc_dflags hsc_env 
135         ; showPass dflags "Tidy [hoot] type env"
136
137         ; let { insts'     = tidyInstances tidyExternalId insts
138               ; type_env1  = filterNameEnv (not . isWiredInThing) type_env
139               ; type_env2  = mapNameEnv tidyBootThing type_env1
140               ; type_env'  = extendTypeEnvWithIds type_env2
141                                 (map instanceDFunId insts')
142               }
143         ; return (ModDetails { md_types     = type_env'
144                              , md_insts     = insts'
145                              , md_fam_insts = fam_insts
146                              , md_rules     = []
147                              , md_exports   = exports
148                              , md_vect_info = noVectInfo
149                              })
150         }
151   where
152
153 isWiredInThing :: TyThing -> Bool
154 isWiredInThing thing = isWiredInName (getName thing)
155
156 tidyBootThing :: TyThing -> TyThing
157 -- Just externalise the Ids; keep everything
158 tidyBootThing (AnId id) | isLocalId id = AnId (tidyExternalId id)
159 tidyBootThing thing                    = thing
160
161 tidyExternalId :: Id -> Id
162 -- Takes an LocalId with an External Name, 
163 -- makes it into a GlobalId with VanillaIdInfo, and tidies its type
164 -- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.)
165 tidyExternalId id 
166   = ASSERT2( isLocalId id && isExternalName (idName id), ppr id )
167     mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo
168 \end{code}
169
170
171 %************************************************************************
172 %*                                                                      *
173         Plan B: tidy bindings, make TypeEnv full of IdInfo
174 %*                                                                      * 
175 %************************************************************************
176
177 Plan B: include pragmas, make interfaces 
178 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
179 * Figure out which Ids are externally visible
180
181 * Tidy the bindings, externalising appropriate Ids
182
183 * Drop all Ids from the TypeEnv, and add all the External Ids from 
184   the bindings.  (This adds their IdInfo to the TypeEnv; and adds
185   floated-out Ids that weren't even in the TypeEnv before.)
186
187 Step 1: Figure out external Ids
188 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
189 First we figure out which Ids are "external" Ids.  An
190 "external" Id is one that is visible from outside the compilation
191 unit.  These are
192         a) the user exported ones
193         b) ones mentioned in the unfoldings, workers, 
194            or rules of externally-visible ones 
195 This exercise takes a sweep of the bindings bottom to top.  Actually,
196 in Step 2 we're also going to need to know which Ids should be
197 exported with their unfoldings, so we produce not an IdSet but an
198 IdEnv Bool
199
200
201 Step 2: Tidy the program
202 ~~~~~~~~~~~~~~~~~~~~~~~~
203 Next we traverse the bindings top to bottom.  For each *top-level*
204 binder
205
206  1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, 
207     reflecting the fact that from now on we regard it as a global, 
208     not local, Id
209
210  2. Give it a system-wide Unique.
211     [Even non-exported things need system-wide Uniques because the
212     byte-code generator builds a single Name->BCO symbol table.]
213
214     We use the NameCache kept in the HscEnv as the
215     source of such system-wide uniques.
216
217     For external Ids, use the original-name cache in the NameCache
218     to ensure that the unique assigned is the same as the Id had 
219     in any previous compilation run.
220   
221  3. If it's an external Id, make it have a External Name, otherwise
222     make it have an Internal Name.
223     This is used by the code generator to decide whether
224     to make the label externally visible
225
226  4. Give external Ids a "tidy" OccName.  This means
227     we can print them in interface files without confusing 
228     "x" (unique 5) with "x" (unique 10).
229   
230  5. Give it its UTTERLY FINAL IdInfo; in ptic, 
231         * its unfolding, if it should have one
232         
233         * its arity, computed from the number of visible lambdas
234
235         * its CAF info, computed from what is free in its RHS
236
237                 
238 Finally, substitute these new top-level binders consistently
239 throughout, including in unfoldings.  We also tidy binders in
240 RHSs, so that they print nicely in interfaces.
241
242 \begin{code}
243 tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
244 tidyProgram hsc_env
245             mod_impl@(ModGuts { mg_module = mod, mg_exports = exports, 
246                                 mg_types = type_env, 
247                                 mg_insts = insts, mg_fam_insts = fam_insts,
248                                 mg_binds = binds, 
249                                 mg_rules = imp_rules,
250                                 mg_vect_info = vect_info,
251                                 mg_dir_imps = dir_imps, mg_deps = deps, 
252                                 mg_foreign = foreign_stubs,
253                                 mg_hpc_info = hpc_info,
254                                 mg_modBreaks = modBreaks })
255
256   = do  { let dflags = hsc_dflags hsc_env
257         ; showPass dflags "Tidy Core"
258
259         ; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags
260               ; ext_ids = findExternalIds omit_prags binds
261               ; ext_rules 
262                    | omit_prags = []
263                    | otherwise  = findExternalRules binds imp_rules ext_ids
264                 -- findExternalRules filters imp_rules to avoid binders that 
265                 -- aren't externally visible; but the externally-visible binders 
266                 -- are computed (by findExternalIds) assuming that all orphan
267                 -- rules are exported (they get their Exported flag set in the desugarer)
268                 -- So in fact we may export more than we need. 
269                 -- (It's a sort of mutual recursion.)
270         }
271
272         ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids 
273                                                  binds
274
275         ; let { export_set = availsToNameSet exports
276               ; tidy_type_env = tidyTypeEnv omit_prags export_set type_env 
277                                             tidy_binds
278               ; tidy_insts    = tidyInstances (lookup_dfun tidy_type_env) insts
279                 -- A DFunId will have a binding in tidy_binds, and so
280                 -- will now be in final_env, replete with IdInfo
281                 -- Its name will be unchanged since it was born, but
282                 -- we want Global, IdInfo-rich (or not) DFunId in the
283                 -- tidy_insts
284
285               ; tidy_rules = tidyRules tidy_env ext_rules
286                 -- You might worry that the tidy_env contains IdInfo-rich stuff
287                 -- and indeed it does, but if omit_prags is on, ext_rules is
288                 -- empty
289
290               ; implicit_binds = getImplicitBinds type_env
291               ; all_tidy_binds = implicit_binds ++ tidy_binds
292               ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
293               }
294
295         ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds
296         ; dumpIfSet_core dflags Opt_D_dump_simpl
297                 "Tidy Core Rules"
298                 (pprRules tidy_rules)
299
300         ; return (CgGuts { cg_module   = mod, 
301                            cg_tycons   = alg_tycons,
302                            cg_binds    = all_tidy_binds,
303                            cg_dir_imps = dir_imps,
304                            cg_foreign  = foreign_stubs,
305                            cg_dep_pkgs = dep_pkgs deps,
306                            cg_hpc_info = hpc_info,
307                            cg_modBreaks = modBreaks }, 
308
309                    ModDetails { md_types     = tidy_type_env,
310                                 md_rules     = tidy_rules,
311                                 md_insts     = tidy_insts,
312                                 md_fam_insts = fam_insts,
313                                 md_exports   = exports,
314                                 md_vect_info = vect_info    -- is already tidy
315                               })
316         }
317
318 lookup_dfun type_env dfun_id
319   = case lookupTypeEnv type_env (idName dfun_id) of
320         Just (AnId dfun_id') -> dfun_id'
321         other -> pprPanic "lookup_dfun" (ppr dfun_id)
322
323 tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv
324
325 -- The competed type environment is gotten from
326 --      Dropping any wired-in things, and then
327 --      a) keeping the types and classes
328 --      b) removing all Ids, 
329 --      c) adding Ids with correct IdInfo, including unfoldings,
330 --              gotten from the bindings
331 -- From (c) we keep only those Ids with External names;
332 --          the CoreTidy pass makes sure these are all and only
333 --          the externally-accessible ones
334 -- This truncates the type environment to include only the 
335 -- exported Ids and things needed from them, which saves space
336
337 tidyTypeEnv omit_prags exports type_env tidy_binds
338   = let type_env1 = filterNameEnv keep_it type_env
339         type_env2 = extendTypeEnvWithIds type_env1 final_ids
340         type_env3 | omit_prags = mapNameEnv trim_thing type_env2
341                   | otherwise  = type_env2
342     in 
343     type_env3
344   where
345     final_ids  = [ id | id <- bindersOfBinds tidy_binds, 
346                         isExternalName (idName id)]
347
348         -- We keep GlobalIds, because they won't appear 
349         -- in the bindings from which final_ids are derived!
350         -- (The bindings bind LocalIds.)
351     keep_it thing | isWiredInThing thing = False
352     keep_it (AnId id) = isGlobalId id   -- Keep GlobalIds (e.g. class ops)
353     keep_it other     = True            -- Keep all TyCons, DataCons, and Classes
354
355     trim_thing thing
356         = case thing of
357             ATyCon tc | mustExposeTyCon exports tc -> thing
358                       | otherwise -> ATyCon (makeTyConAbstract tc)
359
360             AnId id | isImplicitId id -> thing
361                     | otherwise       -> AnId (id `setIdInfo` vanillaIdInfo)
362
363             other -> thing
364
365 mustExposeTyCon :: NameSet      -- Exports
366                 -> TyCon        -- The tycon
367                 -> Bool         -- Can its rep be hidden?
368 -- We are compiling without -O, and thus trying to write as little as 
369 -- possible into the interface file.  But we must expose the details of
370 -- any data types whose constructors or fields are exported
371 mustExposeTyCon exports tc
372   | not (isAlgTyCon tc)         -- Synonyms
373   = True
374   | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors
375   = True                        -- won't lead to the need for further exposure
376                                 -- (This includes data types with no constructors.)
377   | isOpenTyCon tc              -- open type family
378   = True
379   | otherwise                   -- Newtype, datatype
380   = any exported_con (tyConDataCons tc)
381         -- Expose rep if any datacon or field is exported
382
383   || (isNewTyCon tc && isFFITy (snd (newTyConRep tc)))
384         -- Expose the rep for newtypes if the rep is an FFI type.  
385         -- For a very annoying reason.  'Foreign import' is meant to
386         -- be able to look through newtypes transparently, but it
387         -- can only do that if it can "see" the newtype representation
388   where
389     exported_con con = any (`elemNameSet` exports) 
390                            (dataConName con : dataConFieldLabels con)
391
392 tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance]
393 tidyInstances tidy_dfun ispecs
394   = map tidy ispecs
395   where
396     tidy ispec = setInstanceDFunId ispec $
397                  tidy_dfun (instanceDFunId ispec)
398
399 getImplicitBinds :: TypeEnv -> [CoreBind]
400 getImplicitBinds type_env
401   = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env)
402                   ++ concatMap other_implicit_ids (typeEnvElts type_env))
403         -- Put the constructor wrappers first, because
404         -- other implicit bindings (notably the fromT functions arising 
405         -- from generics) use the constructor wrappers.  At least that's
406         -- what External Core likes
407   where
408     implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
409     
410     other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc)
411         -- The "naughty" ones are not real functions at all
412         -- They are there just so we can get decent error messages
413         -- See Note  [Naughty record selectors] in MkId.lhs
414     other_implicit_ids (AClass cl) = classSelIds cl
415     other_implicit_ids other       = []
416     
417     get_defn :: Id -> CoreBind
418     get_defn id = NonRec id (tidyExpr emptyTidyEnv rhs)
419         where
420           rhs = unfoldingTemplate (idUnfolding id)
421         -- Don't forget to tidy the body !  Otherwise you get silly things like
422         --      \ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl
423 \end{code}
424
425
426 %************************************************************************
427 %*                                                                      *
428 \subsection{Step 1: finding externals}
429 %*                                                                      * 
430 %************************************************************************
431
432 \begin{code}
433 findExternalIds :: Bool
434                 -> [CoreBind]
435                 -> IdEnv Bool   -- In domain => external
436                                 -- Range = True <=> show unfolding
437         -- Step 1 from the notes above
438 findExternalIds omit_prags binds
439   | omit_prags
440   = mkVarEnv [ (id,False) | id <- bindersOfBinds binds, isExportedId id ]
441
442   | otherwise
443   = foldr find emptyVarEnv binds
444   where
445     find (NonRec id rhs) needed
446         | need_id needed id = addExternal (id,rhs) needed
447         | otherwise         = needed
448     find (Rec prs) needed   = find_prs prs needed
449
450         -- For a recursive group we have to look for a fixed point
451     find_prs prs needed 
452         | null needed_prs = needed
453         | otherwise       = find_prs other_prs new_needed
454         where
455           (needed_prs, other_prs) = partition (need_pr needed) prs
456           new_needed = foldr addExternal needed needed_prs
457
458         -- The 'needed' set contains the Ids that are needed by earlier
459         -- interface file emissions.  If the Id isn't in this set, and isn't
460         -- exported, there's no need to emit anything
461     need_id needed_set id       = id `elemVarEnv` needed_set || isExportedId id 
462     need_pr needed_set (id,rhs) = need_id needed_set id
463
464 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
465 -- The Id is needed; extend the needed set
466 -- with it and its dependents (free vars etc)
467 addExternal (id,rhs) needed
468   = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
469                  id show_unfold
470   where
471     add_occ id needed | id `elemVarEnv` needed = needed
472                       | otherwise              = extendVarEnv needed id False
473         -- "False" because we don't know we need the Id's unfolding
474         -- Don't override existing bindings; we might have already set it to True
475
476     new_needed_ids = worker_ids `unionVarSet`
477                      unfold_ids `unionVarSet`
478                      spec_ids
479
480     idinfo         = idInfo id
481     dont_inline    = isNeverActive (inlinePragInfo idinfo)
482     loop_breaker   = isNonRuleLoopBreaker (occInfo idinfo)
483     bottoming_fn   = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
484     spec_ids       = specInfoFreeVars (specInfo idinfo)
485     worker_info    = workerInfo idinfo
486
487         -- Stuff to do with the Id's unfolding
488         -- The simplifier has put an up-to-date unfolding
489         -- in the IdInfo, but the RHS will do just as well
490     unfolding    = unfoldingInfo idinfo
491     rhs_is_small = not (neverUnfold unfolding)
492
493         -- We leave the unfolding there even if there is a worker
494         -- In GHCI the unfolding is used by importers
495         -- When writing an interface file, we omit the unfolding 
496         -- if there is a worker
497     show_unfold = not bottoming_fn       &&     -- Not necessary
498                   not dont_inline        &&
499                   not loop_breaker       &&
500                   rhs_is_small                  -- Small enough
501
502     unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
503                | otherwise   = emptyVarSet
504
505     worker_ids = case worker_info of
506                    HasWorker work_id _ -> unitVarSet work_id
507                    otherwise           -> emptyVarSet
508 \end{code}
509
510
511 \begin{code}
512 findExternalRules :: [CoreBind]
513                   -> [CoreRule] -- Non-local rules (i.e. ones for imported fns)
514                   -> IdEnv a    -- Ids that are exported, so we need their rules
515                   -> [CoreRule]
516   -- The complete rules are gotten by combining
517   --    a) the non-local rules
518   --    b) rules embedded in the top-level Ids
519 findExternalRules binds non_local_rules ext_ids
520   = filter (not . internal_rule) (non_local_rules ++ local_rules)
521   where
522     local_rules  = [ rule
523                    | id <- bindersOfBinds binds,
524                      id `elemVarEnv` ext_ids,
525                      rule <- idCoreRules id
526                    ]
527
528     internal_rule rule
529         =  any internal_id (varSetElems (ruleLhsFreeIds rule))
530                 -- Don't export a rule whose LHS mentions a locally-defined
531                 --  Id that is completely internal (i.e. not visible to an
532                 -- importing module)
533
534     internal_id id = not (id `elemVarEnv` ext_ids)
535 \end{code}
536
537
538
539 %************************************************************************
540 %*                                                                      *
541 \subsection{Step 2: top-level tidying}
542 %*                                                                      *
543 %************************************************************************
544
545
546 \begin{code}
547 -- TopTidyEnv: when tidying we need to know
548 --   * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.  
549 --        These may have arisen because the
550 --        renamer read in an interface file mentioning M.$wf, say,
551 --        and assigned it unique r77.  If, on this compilation, we've
552 --        invented an Id whose name is $wf (but with a different unique)
553 --        we want to rename it to have unique r77, so that we can do easy
554 --        comparisons with stuff from the interface file
555 --
556 --   * occ_env: The TidyOccEnv, which tells us which local occurrences 
557 --     are 'used'
558 --
559 --   * subst_env: A Var->Var mapping that substitutes the new Var for the old
560
561 tidyTopBinds :: HscEnv
562              -> Module
563              -> TypeEnv
564              -> IdEnv Bool      -- Domain = Ids that should be external
565                                 -- True <=> their unfolding is external too
566              -> [CoreBind]
567              -> IO (TidyEnv, [CoreBind])
568
569 tidyTopBinds hsc_env mod type_env ext_ids binds
570   = tidy init_env binds
571   where
572     nc_var = hsc_NC hsc_env 
573
574         -- We also make sure to avoid any exported binders.  Consider
575         --      f{-u1-} = 1     -- Local decl
576         --      ...
577         --      f{-u2-} = 2     -- Exported decl
578         --
579         -- The second exported decl must 'get' the name 'f', so we
580         -- have to put 'f' in the avoids list before we get to the first
581         -- decl.  tidyTopId then does a no-op on exported binders.
582     init_env = (initTidyOccEnv avoids, emptyVarEnv)
583     avoids   = [getOccName name | bndr <- typeEnvIds type_env,
584                                   let name = idName bndr,
585                                   isExternalName name]
586                 -- In computing our "avoids" list, we must include
587                 --      all implicit Ids
588                 --      all things with global names (assigned once and for
589                 --                                      all by the renamer)
590                 -- since their names are "taken".
591                 -- The type environment is a convenient source of such things.
592
593     this_pkg = thisPackage (hsc_dflags hsc_env)
594
595     tidy env []     = return (env, [])
596     tidy env (b:bs) = do { (env1, b')  <- tidyTopBind this_pkg mod nc_var ext_ids env b
597                          ; (env2, bs') <- tidy env1 bs
598                          ; return (env2, b':bs') }
599
600 ------------------------
601 tidyTopBind  :: PackageId
602              -> Module
603              -> IORef NameCache -- For allocating new unique names
604              -> IdEnv Bool      -- Domain = Ids that should be external
605                                 -- True <=> their unfolding is external too
606              -> TidyEnv -> CoreBind
607              -> IO (TidyEnv, CoreBind)
608
609 tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs)
610   = do  { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr
611         ; let   { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs)
612                 ; subst2        = extendVarEnv subst1 bndr bndr'
613                 ; tidy_env2     = (occ_env2, subst2) }
614         ; return (tidy_env2, NonRec bndr' rhs') }
615   where
616     caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs
617
618 tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
619   = do  { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs
620         ; let   { prs'      = zipWith (tidyTopPair ext_ids tidy_env2 caf_info)
621                                       names' prs
622                 ; subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')
623                 ; tidy_env2 = (occ_env2, subst2) }
624         ; return (tidy_env2, Rec prs') }
625   where
626     bndrs = map fst prs
627
628         -- the CafInfo for a recursive group says whether *any* rhs in
629         -- the group may refer indirectly to a CAF (because then, they all do).
630     caf_info 
631         | or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs)
632              | (bndr,rhs) <- prs ] = MayHaveCafRefs
633         | otherwise                = NoCafRefs
634
635 --------------------------------------------------------------------
636 --              tidyTopName
637 -- This is where we set names to local/global based on whether they really are 
638 -- externally visible (see comment at the top of this module).  If the name
639 -- was previously local, we have to give it a unique occurrence name if
640 -- we intend to externalise it.
641 tidyTopNames mod nc_var ext_ids occ_env [] = return (occ_env, [])
642 tidyTopNames mod nc_var ext_ids occ_env (id:ids)
643   = do  { (occ_env1, name)  <- tidyTopName  mod nc_var ext_ids occ_env id
644         ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids
645         ; return (occ_env2, name:names) }
646
647 tidyTopName :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv
648             -> Id -> IO (TidyOccEnv, Name)
649 tidyTopName mod nc_var ext_ids occ_env id
650   | global && internal = return (occ_env, localiseName name)
651
652   | global && external = return (occ_env, name)
653         -- Global names are assumed to have been allocated by the renamer,
654         -- so they already have the "right" unique
655         -- And it's a system-wide unique too
656
657   -- Now we get to the real reason that all this is in the IO Monad:
658   -- we have to update the name cache in a nice atomic fashion
659
660   | local  && internal = do { nc <- readIORef nc_var
661                             ; let (nc', new_local_name) = mk_new_local nc
662                             ; writeIORef nc_var nc'
663                             ; return (occ_env', new_local_name) }
664         -- Even local, internal names must get a unique occurrence, because
665         -- if we do -split-objs we externalise the name later, in the code generator
666         --
667         -- Similarly, we must make sure it has a system-wide Unique, because
668         -- the byte-code generator builds a system-wide Name->BCO symbol table
669
670   | local  && external = do { nc <- readIORef nc_var
671                             ; let (nc', new_external_name) = mk_new_external nc
672                             ; writeIORef nc_var nc'
673                             ; return (occ_env', new_external_name) }
674   where
675     name        = idName id
676     external    = id `elemVarEnv` ext_ids
677     global      = isExternalName name
678     local       = not global
679     internal    = not external
680     loc         = nameSrcSpan name
681
682     (occ_env', occ') = tidyOccName occ_env (nameOccName name)
683
684     mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc)
685                     where
686                       (us1, us2) = splitUniqSupply (nsUniqs nc)
687                       uniq       = uniqFromSupply us1
688
689     mk_new_external nc = allocateGlobalBinder nc mod occ' loc
690         -- If we want to externalise a currently-local name, check
691         -- whether we have already assigned a unique for it.
692         -- If so, use it; if not, extend the table.
693         -- All this is done by allcoateGlobalBinder.
694         -- This is needed when *re*-compiling a module in GHCi; we must
695         -- use the same name for externally-visible things as we did before.
696
697
698 -----------------------------------------------------------
699 tidyTopPair :: VarEnv Bool
700             -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo
701                         -- It is knot-tied: don't look at it!
702             -> CafInfo
703             -> Name             -- New name
704             -> (Id, CoreExpr)   -- Binder and RHS before tidying
705             -> (Id, CoreExpr)
706         -- This function is the heart of Step 2
707         -- The rec_tidy_env is the one to use for the IdInfo
708         -- It's necessary because when we are dealing with a recursive
709         -- group, a variable late in the group might be mentioned
710         -- in the IdInfo of one early in the group
711
712 tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs)
713   | isGlobalId bndr             -- Injected binding for record selector, etc
714   = (bndr, tidyExpr rhs_tidy_env rhs)
715   | otherwise
716   = (bndr', rhs')
717   where
718     bndr'   = mkVanillaGlobal name' ty' idinfo'
719     ty'     = tidyTopType (idType bndr)
720     rhs'    = tidyExpr rhs_tidy_env rhs
721     idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external)
722                             (idInfo bndr) unfold_info arity
723                             caf_info
724
725     -- Expose an unfolding if ext_ids tells us to
726     -- Remember that ext_ids maps an Id to a Bool: 
727     --  True to show the unfolding, False to hide it
728     maybe_external = lookupVarEnv ext_ids bndr
729     show_unfold = maybe_external `orElse` False
730     unfold_info | show_unfold = mkTopUnfolding rhs'
731                 | otherwise   = noUnfolding
732
733     -- Usually the Id will have an accurate arity on it, because
734     -- the simplifier has just run, but not always. 
735     -- One case I found was when the last thing the simplifier
736     -- did was to let-bind a non-atomic argument and then float
737     -- it to the top level. So it seems more robust just to
738     -- fix it here.
739     arity = exprArity rhs
740
741
742 -- tidyTopIdInfo creates the final IdInfo for top-level
743 -- binders.  There are two delicate pieces:
744 --
745 --  * Arity.  After CoreTidy, this arity must not change any more.
746 --      Indeed, CorePrep must eta expand where necessary to make
747 --      the manifest arity equal to the claimed arity.
748 --
749 --  * CAF info.  This must also remain valid through to code generation.
750 --      We add the info here so that it propagates to all
751 --      occurrences of the binders in RHSs, and hence to occurrences in
752 --      unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
753 --      CoreToStg makes use of this when constructing SRTs.
754
755 tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info
756   | not is_external     -- For internal Ids (not externally visible)
757   = vanillaIdInfo       -- we only need enough info for code generation
758                         -- Arity and strictness info are enough;
759                         --      c.f. CoreTidy.tidyLetBndr
760         `setCafInfo`           caf_info
761         `setArityInfo`         arity
762         `setAllStrictnessInfo` newStrictnessInfo idinfo
763
764   | otherwise           -- Externally-visible Ids get the whole lot
765   = vanillaIdInfo
766         `setCafInfo`           caf_info
767         `setArityInfo`         arity
768         `setAllStrictnessInfo` newStrictnessInfo idinfo
769         `setInlinePragInfo`    inlinePragInfo idinfo
770         `setUnfoldingInfo`     unfold_info
771         `setWorkerInfo`        tidyWorker tidy_env (workerInfo idinfo)
772                 -- NB: we throw away the Rules
773                 -- They have already been extracted by findExternalRules
774
775
776
777 ------------  Worker  --------------
778 tidyWorker tidy_env (HasWorker work_id wrap_arity) 
779   = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
780 tidyWorker tidy_env other
781   = NoWorker
782 \end{code}
783
784 %************************************************************************
785 %*                                                                      *
786 \subsection{Figuring out CafInfo for an expression}
787 %*                                                                      *
788 %************************************************************************
789
790 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
791 We mark such things as `MayHaveCafRefs' because this information is
792 used to decide whether a particular closure needs to be referenced
793 in an SRT or not.
794
795 There are two reasons for setting MayHaveCafRefs:
796         a) The RHS is a CAF: a top-level updatable thunk.
797         b) The RHS refers to something that MayHaveCafRefs
798
799 Possible improvement: In an effort to keep the number of CAFs (and 
800 hence the size of the SRTs) down, we could also look at the expression and 
801 decide whether it requires a small bounded amount of heap, so we can ignore 
802 it as a CAF.  In these cases however, we would need to use an additional
803 CAF list to keep track of non-collectable CAFs.  
804
805 \begin{code}
806 hasCafRefs  :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
807 hasCafRefs this_pkg p arity expr 
808   | is_caf || mentions_cafs 
809                             = MayHaveCafRefs
810   | otherwise               = NoCafRefs
811  where
812   mentions_cafs = isFastTrue (cafRefs p expr)
813   is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
814
815   -- NB. we pass in the arity of the expression, which is expected
816   -- to be calculated by exprArity.  This is because exprArity
817   -- knows how much eta expansion is going to be done by 
818   -- CorePrep later on, and we don't want to duplicate that
819   -- knowledge in rhsIsStatic below.
820
821 cafRefs p (Var id)
822         -- imported Ids first:
823   | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id))
824         -- now Ids local to this module:
825   | otherwise =
826      case lookupVarEnv p id of
827         Just id' -> fastBool (mayHaveCafRefs (idCafInfo id'))
828         Nothing  -> fastBool False
829
830 cafRefs p (Lit l)              = fastBool False
831 cafRefs p (App f a)            = fastOr (cafRefs p f) (cafRefs p) a
832 cafRefs p (Lam x e)            = cafRefs p e
833 cafRefs p (Let b e)            = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
834 cafRefs p (Case e bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
835 cafRefs p (Note n e)           = cafRefs p e
836 cafRefs p (Cast e co)          = cafRefs p e
837 cafRefs p (Type t)             = fastBool False
838
839 cafRefss p []     = fastBool False
840 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
841
842 -- hack for lazy-or over FastBool.
843 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
844 \end{code}