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