Refactor buildClass and mkDictSelId a bit, to avoid the no_unf argument
[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 (
8        mkBootModDetailsTc, tidyProgram, globaliseAndTidyId
9    ) where
10
11 #include "HsVersions.h"
12
13 import TcRnTypes
14 import DynFlags
15 import CoreSyn
16 import CoreUnfold
17 import CoreFVs
18 import CoreTidy
19 import CoreMonad
20 import CorePrep
21 import CoreUtils
22 import Literal
23 import Rules
24 import CoreArity        ( exprArity, exprBotStrictness_maybe )
25 import VarEnv
26 import VarSet
27 import Var
28 import Id
29 import MkId             ( mkDictSelRhs )
30 import IdInfo
31 import InstEnv
32 import FamInstEnv
33 import Type             ( tidyTopType )
34 import Demand           ( appIsBottom, isNopSig, isBottomingSig )
35 import BasicTypes
36 import Name hiding (varName)
37 import NameSet
38 import NameEnv
39 import Avail
40 import IfaceEnv
41 import TcEnv
42 import TcRnMonad
43 import DataCon
44 import TyCon
45 import Class
46 import Module
47 import Packages( isDllName )
48 import HscTypes
49 import Maybes
50 import UniqSupply
51 import ErrUtils (Severity(..))
52 import Outputable
53 import FastBool hiding ( fastOr )
54 import SrcLoc
55 import Util
56 import FastString
57 import qualified ErrUtils as Err
58
59 import Control.Monad
60 import Data.Function
61 import Data.List        ( sortBy )
62 import Data.IORef       ( atomicModifyIORef )
63 \end{code}
64
65
66 Constructing the TypeEnv, Instances, Rules, VectInfo from which the
67 ModIface is constructed, and which goes on to subsequent modules in
68 --make mode.
69
70 Most of the interface file is obtained simply by serialising the
71 TypeEnv.  One important consequence is that if the *interface file*
72 has pragma info if and only if the final TypeEnv does. This is not so
73 important for *this* module, but it's essential for ghc --make:
74 subsequent compilations must not see (e.g.) the arity if the interface
75 file does not contain arity If they do, they'll exploit the arity;
76 then the arity might change, but the iface file doesn't change =>
77 recompilation does not happen => disaster.
78
79 For data types, the final TypeEnv will have a TyThing for the TyCon,
80 plus one for each DataCon; the interface file will contain just one
81 data type declaration, but it is de-serialised back into a collection
82 of TyThings.
83
84 %************************************************************************
85 %*                                                                      *
86                 Plan A: simpleTidyPgm
87 %*                                                                      *
88 %************************************************************************
89
90
91 Plan A: mkBootModDetails: omit pragmas, make interfaces small
92 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
93 * Ignore the bindings
94
95 * Drop all WiredIn things from the TypeEnv
96         (we never want them in interface files)
97
98 * Retain all TyCons and Classes in the TypeEnv, to avoid
99         having to find which ones are mentioned in the
100         types of exported Ids
101
102 * Trim off the constructors of non-exported TyCons, both
103         from the TyCon and from the TypeEnv
104
105 * Drop non-exported Ids from the TypeEnv
106
107 * Tidy the types of the DFunIds of Instances,
108   make them into GlobalIds, (they already have External Names)
109   and add them to the TypeEnv
110
111 * Tidy the types of the (exported) Ids in the TypeEnv,
112   make them into GlobalIds (they already have External Names)
113
114 * Drop rules altogether
115
116 * Tidy the bindings, to ensure that the Caf and Arity
117   information is correct for each top-level binder; the
118   code generator needs it. And to ensure that local names have
119   distinct OccNames in case of object-file splitting
120
121 \begin{code}
122 -- This is Plan A: make a small type env when typechecking only,
123 -- or when compiling a hs-boot file, or simply when not using -O
124 --
125 -- We don't look at the bindings at all -- there aren't any
126 -- for hs-boot files
127
128 mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails
129 mkBootModDetailsTc hsc_env
130         TcGblEnv{ tcg_exports   = exports,
131                   tcg_type_env  = type_env, -- just for the Ids
132                   tcg_tcs       = tcs,
133                   tcg_insts     = insts,
134                   tcg_fam_insts = fam_insts
135                 }
136   = do  { let dflags = hsc_dflags hsc_env
137         ; showPass dflags CoreTidy
138
139         ; let { insts'     = map (tidyClsInstDFun globaliseAndTidyId) insts
140               ; dfun_ids   = map instanceDFunId insts'
141               ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
142                                 (typeEnvIds type_env) tcs fam_insts
143               ; type_env2  = extendTypeEnvWithPatSyns type_env1 (typeEnvPatSyns type_env)
144               ; type_env'  = extendTypeEnvWithIds type_env2 dfun_ids
145               }
146         ; return (ModDetails { md_types     = type_env'
147                              , md_insts     = insts'
148                              , md_fam_insts = fam_insts
149                              , md_rules     = []
150                              , md_anns      = []
151                              , md_exports   = exports
152                              , md_vect_info = noVectInfo
153                              })
154         }
155   where
156
157 mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
158 mkBootTypeEnv exports ids tcs fam_insts
159   = tidyTypeEnv True $
160        typeEnvFromEntities final_ids tcs fam_insts
161   where
162         -- Find the LocalIds in the type env that are exported
163         -- Make them into GlobalIds, and tidy their types
164         --
165         -- It's very important to remove the non-exported ones
166         -- because we don't tidy the OccNames, and if we don't remove
167         -- the non-exported ones we'll get many things with the
168         -- same name in the interface file, giving chaos.
169         --
170         -- Do make sure that we keep Ids that are already Global.
171         -- When typechecking an .hs-boot file, the Ids come through as
172         -- GlobalIds.
173     final_ids = [ if isLocalId id then globaliseAndTidyId id
174                                   else id
175                 | id <- ids
176                 , keep_it id ]
177
178         -- default methods have their export flag set, but everything
179         -- else doesn't (yet), because this is pre-desugaring, so we
180         -- must test both.
181     keep_it id = isExportedId id || idName id `elemNameSet` exports
182
183
184
185 globaliseAndTidyId :: Id -> Id
186 -- Takes an LocalId with an External Name,
187 -- makes it into a GlobalId
188 --     * unchanged Name (might be Internal or External)
189 --     * unchanged details
190 --     * VanillaIdInfo (makes a conservative assumption about Caf-hood)
191 globaliseAndTidyId id
192   = Id.setIdType (globaliseId id) tidy_type
193   where
194     tidy_type = tidyTopType (idType id)
195 \end{code}
196
197
198 %************************************************************************
199 %*                                                                      *
200         Plan B: tidy bindings, make TypeEnv full of IdInfo
201 %*                                                                      *
202 %************************************************************************
203
204 Plan B: include pragmas, make interfaces
205 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
206 * Figure out which Ids are externally visible
207
208 * Tidy the bindings, externalising appropriate Ids
209
210 * Drop all Ids from the TypeEnv, and add all the External Ids from
211   the bindings.  (This adds their IdInfo to the TypeEnv; and adds
212   floated-out Ids that weren't even in the TypeEnv before.)
213
214 Step 1: Figure out external Ids
215 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
216 Note [choosing external names]
217
218 See also the section "Interface stability" in the
219 RecompilationAvoidance commentary:
220   http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
221
222 First we figure out which Ids are "external" Ids.  An
223 "external" Id is one that is visible from outside the compilation
224 unit.  These are
225   a) the user exported ones
226   b) ones mentioned in the unfoldings, workers,
227      rules of externally-visible ones ,
228      or vectorised versions of externally-visible ones
229
230 While figuring out which Ids are external, we pick a "tidy" OccName
231 for each one.  That is, we make its OccName distinct from the other
232 external OccNames in this module, so that in interface files and
233 object code we can refer to it unambiguously by its OccName.  The
234 OccName for each binder is prefixed by the name of the exported Id
235 that references it; e.g. if "f" references "x" in its unfolding, then
236 "x" is renamed to "f_x".  This helps distinguish the different "x"s
237 from each other, and means that if "f" is later removed, things that
238 depend on the other "x"s will not need to be recompiled.  Of course,
239 if there are multiple "f_x"s, then we have to disambiguate somehow; we
240 use "f_x0", "f_x1" etc.
241
242 As far as possible we should assign names in a deterministic fashion.
243 Each time this module is compiled with the same options, we should end
244 up with the same set of external names with the same types.  That is,
245 the ABI hash in the interface should not change.  This turns out to be
246 quite tricky, since the order of the bindings going into the tidy
247 phase is already non-deterministic, as it is based on the ordering of
248 Uniques, which are assigned unpredictably.
249
250 To name things in a stable way, we do a depth-first-search of the
251 bindings, starting from the exports sorted by name.  This way, as long
252 as the bindings themselves are deterministic (they sometimes aren't!),
253 the order in which they are presented to the tidying phase does not
254 affect the names we assign.
255
256 Step 2: Tidy the program
257 ~~~~~~~~~~~~~~~~~~~~~~~~
258 Next we traverse the bindings top to bottom.  For each *top-level*
259 binder
260
261  1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,
262     reflecting the fact that from now on we regard it as a global,
263     not local, Id
264
265  2. Give it a system-wide Unique.
266     [Even non-exported things need system-wide Uniques because the
267     byte-code generator builds a single Name->BCO symbol table.]
268
269     We use the NameCache kept in the HscEnv as the
270     source of such system-wide uniques.
271
272     For external Ids, use the original-name cache in the NameCache
273     to ensure that the unique assigned is the same as the Id had
274     in any previous compilation run.
275
276  3. Rename top-level Ids according to the names we chose in step 1.
277     If it's an external Id, make it have a External Name, otherwise
278     make it have an Internal Name.  This is used by the code generator
279     to decide whether to make the label externally visible
280
281  4. Give it its UTTERLY FINAL IdInfo; in ptic,
282         * its unfolding, if it should have one
283
284         * its arity, computed from the number of visible lambdas
285
286         * its CAF info, computed from what is free in its RHS
287
288
289 Finally, substitute these new top-level binders consistently
290 throughout, including in unfoldings.  We also tidy binders in
291 RHSs, so that they print nicely in interfaces.
292
293 \begin{code}
294 tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
295 tidyProgram hsc_env  (ModGuts { mg_module    = mod
296                               , mg_exports   = exports
297                               , mg_tcs       = tcs
298                               , mg_insts     = insts
299                               , mg_fam_insts = fam_insts
300                               , mg_binds     = binds
301                               , mg_patsyns   = patsyns
302                               , mg_rules     = imp_rules
303                               , mg_vect_info = vect_info
304                               , mg_anns      = anns
305                               , mg_deps      = deps
306                               , mg_foreign   = foreign_stubs
307                               , mg_hpc_info  = hpc_info
308                               , mg_modBreaks = modBreaks
309                               })
310
311   = do  { let { dflags     = hsc_dflags hsc_env
312               ; omit_prags = gopt Opt_OmitInterfacePragmas dflags
313               ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags
314               }
315         ; showPass dflags CoreTidy
316
317         ; let { type_env = typeEnvFromEntities [] tcs fam_insts
318
319               ; implicit_binds
320                   = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++
321                     concatMap getTyConImplicitBinds (typeEnvTyCons type_env)
322               }
323
324         ; (unfold_env, tidy_occ_env)
325               <- chooseExternalIds hsc_env mod omit_prags expose_all
326                                    binds implicit_binds imp_rules (vectInfoVar vect_info)
327         ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env }
328                 -- Glom together imp_rules and rules currently attached to binders
329                 -- Then pick just the ones we need to expose
330                 -- See Note [Which rules to expose]
331
332         ; (tidy_env, tidy_binds)
333                  <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env binds
334
335         ; let { final_ids  = [ id | id <- bindersOfBinds tidy_binds,
336                                     isExternalName (idName id)]
337               ; final_patsyns = filter (isExternalName . getName) patsyns
338
339               ; type_env' = extendTypeEnvWithIds type_env final_ids
340               ; type_env'' = extendTypeEnvWithPatSyns type_env' final_patsyns
341
342               ; tidy_type_env = tidyTypeEnv omit_prags type_env''
343
344               ; tidy_insts    = map (tidyClsInstDFun (lookup_dfun tidy_type_env)) insts
345                 -- A DFunId will have a binding in tidy_binds, and so
346                 -- will now be in final_env, replete with IdInfo
347                 -- Its name will be unchanged since it was born, but
348                 -- we want Global, IdInfo-rich (or not) DFunId in the
349                 -- tidy_insts
350
351               ; tidy_rules = tidyRules tidy_env ext_rules
352                 -- You might worry that the tidy_env contains IdInfo-rich stuff
353                 -- and indeed it does, but if omit_prags is on, ext_rules is
354                 -- empty
355
356               ; tidy_vect_info = tidyVectInfo tidy_env vect_info
357
358               -- See Note [Injecting implicit bindings]
359               ; all_tidy_binds = implicit_binds ++ tidy_binds
360
361               -- get the TyCons to generate code for.  Careful!  We must use
362               -- the untidied TypeEnv here, because we need
363               --  (a) implicit TyCons arising from types and classes defined
364               --      in this module
365               --  (b) wired-in TyCons, which are normally removed from the
366               --      TypeEnv we put in the ModDetails
367               --  (c) Constructors even if they are not exported (the
368               --      tidied TypeEnv has trimmed these away)
369               ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
370               }
371
372         ; endPass hsc_env CoreTidy all_tidy_binds tidy_rules
373
374           -- If the endPass didn't print the rules, but ddump-rules is
375           -- on, print now
376         ; unless (dopt Opt_D_dump_simpl dflags) $
377             Err.dumpIfSet_dyn dflags Opt_D_dump_rules
378               (showSDoc dflags (ppr CoreTidy <+> ptext (sLit "rules")))
379               (pprRulesForUser tidy_rules)
380
381           -- Print one-line size info
382         ; let cs = coreBindsStats tidy_binds
383         ; when (dopt Opt_D_dump_core_stats dflags)
384                (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
385                           (ptext (sLit "Tidy size (terms,types,coercions)")
386                            <+> ppr (moduleName mod) <> colon
387                            <+> int (cs_tm cs)
388                            <+> int (cs_ty cs)
389                            <+> int (cs_co cs) ))
390
391         ; return (CgGuts { cg_module   = mod,
392                            cg_tycons   = alg_tycons,
393                            cg_binds    = all_tidy_binds,
394                            cg_foreign  = foreign_stubs,
395                            cg_dep_pkgs = map fst $ dep_pkgs deps,
396                            cg_hpc_info = hpc_info,
397                            cg_modBreaks = modBreaks },
398
399                    ModDetails { md_types     = tidy_type_env,
400                                 md_rules     = tidy_rules,
401                                 md_insts     = tidy_insts,
402                                 md_vect_info = tidy_vect_info,
403                                 md_fam_insts = fam_insts,
404                                 md_exports   = exports,
405                                 md_anns      = anns      -- are already tidy
406                               })
407         }
408
409 lookup_dfun :: TypeEnv -> Var -> Id
410 lookup_dfun type_env dfun_id
411   = case lookupTypeEnv type_env (idName dfun_id) of
412         Just (AnId dfun_id') -> dfun_id'
413         _other -> pprPanic "lookup_dfun" (ppr dfun_id)
414
415 --------------------------
416 tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags
417             -> TypeEnv -> TypeEnv
418
419 -- The competed type environment is gotten from
420 --      a) the types and classes defined here (plus implicit things)
421 --      b) adding Ids with correct IdInfo, including unfoldings,
422 --              gotten from the bindings
423 -- From (b) we keep only those Ids with External names;
424 --          the CoreTidy pass makes sure these are all and only
425 --          the externally-accessible ones
426 -- This truncates the type environment to include only the
427 -- exported Ids and things needed from them, which saves space
428 --
429 -- See Note [Don't attempt to trim data types]
430
431 tidyTypeEnv omit_prags type_env
432  = let
433         type_env1 = filterNameEnv (not . isWiredInName . getName) type_env
434           -- (1) remove wired-in things
435         type_env2 | omit_prags = mapNameEnv trimThing type_env1
436                   | otherwise  = type_env1
437           -- (2) trimmed if necessary
438     in
439     type_env2
440
441 --------------------------
442 trimThing :: TyThing -> TyThing
443 -- Trim off inessentials, for boot files and no -O
444 trimThing (AnId id)
445    | not (isImplicitId id)
446    = AnId (id `setIdInfo` vanillaIdInfo)
447
448 trimThing other_thing
449   = other_thing
450 \end{code}
451
452 \begin{code}
453 tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo
454 tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars
455                                          , vectInfoParallelVars = parallelVars
456                                          })
457   = info { vectInfoVar          = tidy_vars
458          , vectInfoParallelVars = tidy_parallelVars
459          }
460   where
461       -- we only export mappings whose domain and co-domain is exported (otherwise, the iface is
462       -- inconsistent)
463     tidy_vars = mkVarEnv [ (tidy_var, (tidy_var, tidy_var_v))
464                          | (var, var_v) <- varEnvElts vars
465                          , let tidy_var   = lookup_var var
466                                tidy_var_v = lookup_var var_v
467                          , isExternalId tidy_var   && isExportedId tidy_var
468                          , isExternalId tidy_var_v && isExportedId tidy_var_v
469                          , isDataConWorkId var || not (isImplicitId var)
470                          ]
471
472     tidy_parallelVars = mkVarSet [ tidy_var
473                                  | var <- varSetElems parallelVars
474                                  , let tidy_var = lookup_var var
475                                  , isExternalId tidy_var && isExportedId tidy_var
476                                  ]
477
478     lookup_var var = lookupWithDefaultVarEnv var_env var var
479     
480     -- We need to make sure that all names getting into the iface version of 'VectInfo' are
481     -- external; otherwise, 'MkIface' will bomb out.
482     isExternalId = isExternalName . idName
483 \end{code}
484
485 Note [Don't attempt to trim data types]
486 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
487 For some time GHC tried to avoid exporting the data constructors
488 of a data type if it wasn't strictly necessary to do so; see Trac #835.
489 But "strictly necessary" accumulated a longer and longer list 
490 of exceptions, and finally I gave up the battle:
491
492     commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11
493     Author: Simon Peyton Jones <simonpj@microsoft.com>
494     Date:   Thu Dec 6 16:03:16 2012 +0000
495
496     Stop attempting to "trim" data types in interface files
497     
498     Without -O, we previously tried to make interface files smaller
499     by not including the data constructors of data types.  But
500     there are a lot of exceptions, notably when Template Haskell is
501     involved or, more recently, DataKinds.
502     
503     However Trac #7445 shows that even without TemplateHaskell, using
504     the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ
505     is enough to require us to expose the data constructors.
506     
507     So I've given up on this "optimisation" -- it's probably not
508     important anyway.  Now I'm simply not attempting to trim off
509     the data constructors.  The gain in simplicity is worth the
510     modest cost in interface file growth, which is limited to the
511     bits reqd to describe those data constructors.
512
513 %************************************************************************
514 %*                                                                      *
515         Implicit bindings
516 %*                                                                      *
517 %************************************************************************
518
519 Note [Injecting implicit bindings]
520 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
521 We inject the implict bindings right at the end, in CoreTidy.
522 Some of these bindings, notably record selectors, are not
523 constructed in an optimised form.  E.g. record selector for
524         data T = MkT { x :: {-# UNPACK #-} !Int }
525 Then the unfolding looks like
526         x = \t. case t of MkT x1 -> let x = I# x1 in x
527 This generates bad code unless it's first simplified a bit.  That is
528 why CoreUnfold.mkImplicitUnfolding uses simleExprOpt to do a bit of
529 optimisation first.  (Only matters when the selector is used curried;
530 eg map x ys.)  See Trac #2070.
531
532 [Oct 09: in fact, record selectors are no longer implicit Ids at all,
533 because we really do want to optimise them properly. They are treated
534 much like any other Id.  But doing "light" optimisation on an implicit
535 Id still makes sense.]
536
537 At one time I tried injecting the implicit bindings *early*, at the
538 beginning of SimplCore.  But that gave rise to real difficulty,
539 because GlobalIds are supposed to have *fixed* IdInfo, but the
540 simplifier and other core-to-core passes mess with IdInfo all the
541 time.  The straw that broke the camels back was when a class selector
542 got the wrong arity -- ie the simplifier gave it arity 2, whereas
543 importing modules were expecting it to have arity 1 (Trac #2844).
544 It's much safer just to inject them right at the end, after tidying.
545
546 Oh: two other reasons for injecting them late:
547
548   - If implicit Ids are already in the bindings when we start TidyPgm,
549     we'd have to be careful not to treat them as external Ids (in
550     the sense of findExternalIds); else the Ids mentioned in *their*
551     RHSs will be treated as external and you get an interface file
552     saying      a18 = <blah>
553     but nothing refererring to a18 (because the implicit Id is the
554     one that does, and implicit Ids don't appear in interface files).
555
556   - More seriously, the tidied type-envt will include the implicit
557     Id replete with a18 in its unfolding; but we won't take account
558     of a18 when computing a fingerprint for the class; result chaos.
559
560 There is one sort of implicit binding that is injected still later,
561 namely those for data constructor workers. Reason (I think): it's
562 really just a code generation trick.... binding itself makes no sense.
563 See CorePrep Note [Data constructor workers].
564
565 \begin{code}
566 getTyConImplicitBinds :: TyCon -> [CoreBind]
567 getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))
568
569 getClassImplicitBinds :: Class -> [CoreBind]
570 getClassImplicitBinds cls
571   = [ NonRec op (mkDictSelRhs cls val_index)
572     | (op, val_index) <- classAllSelIds cls `zip` [0..] ]
573
574 get_defn :: Id -> CoreBind
575 get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))
576 \end{code}
577
578
579 %************************************************************************
580 %*                                                                      *
581 \subsection{Step 1: finding externals}
582 %*                                                                      *
583 %************************************************************************
584
585 See Note [Choosing external names].
586
587 \begin{code}
588 type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
589   -- Maps each top-level Id to its new Name (the Id is tidied in step 2)
590   -- The Unique is unchanged.  If the new Name is external, it will be
591   -- visible in the interface file.
592   --
593   -- Bool => expose unfolding or not.
594
595 chooseExternalIds :: HscEnv
596                   -> Module
597                   -> Bool -> Bool
598                   -> [CoreBind]
599                   -> [CoreBind]
600                   -> [CoreRule]
601                   -> VarEnv (Var, Var)
602                   -> IO (UnfoldEnv, TidyOccEnv)
603                   -- Step 1 from the notes above
604
605 chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules vect_vars
606   = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
607        ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
608        ; tidy_internal internal_ids unfold_env1 occ_env1 }
609  where
610   nc_var = hsc_NC hsc_env
611
612   -- init_ext_ids is the intial list of Ids that should be
613   -- externalised.  It serves as the starting point for finding a
614   -- deterministic, tidy, renaming for all external Ids in this
615   -- module.
616   --
617   -- It is sorted, so that it has adeterministic order (i.e. it's the
618   -- same list every time this module is compiled), in contrast to the
619   -- bindings, which are ordered non-deterministically.
620   init_work_list = zip init_ext_ids init_ext_ids
621   init_ext_ids   = sortBy (compare `on` getOccName) $
622                    filter is_external binders
623
624   -- An Id should be external if either (a) it is exported,
625   -- (b) it appears in the RHS of a local rule for an imported Id, or
626   -- (c) it is the vectorised version of an imported Id
627   -- See Note [Which rules to expose]
628   is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars || id `elemVarSet` vect_var_vs
629   rule_rhs_vars  = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet imp_id_rules
630   vect_var_vs    = mkVarSet [var_v | (var, var_v) <- nameEnvElts vect_vars, isGlobalId var]
631
632   binders          = bindersOfBinds binds
633   implicit_binders = bindersOfBinds implicit_binds
634   binder_set       = mkVarSet binders
635
636   avoids   = [getOccName name | bndr <- binders ++ implicit_binders,
637                                 let name = idName bndr,
638                                 isExternalName name ]
639                 -- In computing our "avoids" list, we must include
640                 --      all implicit Ids
641                 --      all things with global names (assigned once and for
642                 --                                      all by the renamer)
643                 -- since their names are "taken".
644                 -- The type environment is a convenient source of such things.
645                 -- In particular, the set of binders doesn't include
646                 -- implicit Ids at this stage.
647
648         -- We also make sure to avoid any exported binders.  Consider
649         --      f{-u1-} = 1     -- Local decl
650         --      ...
651         --      f{-u2-} = 2     -- Exported decl
652         --
653         -- The second exported decl must 'get' the name 'f', so we
654         -- have to put 'f' in the avoids list before we get to the first
655         -- decl.  tidyTopId then does a no-op on exported binders.
656   init_occ_env = initTidyOccEnv avoids
657
658
659   search :: [(Id,Id)]    -- The work-list: (external id, referrring id)
660                          -- Make a tidy, external Name for the external id,
661                          --   add it to the UnfoldEnv, and do the same for the
662                          --   transitive closure of Ids it refers to
663                          -- The referring id is used to generate a tidy
664                          ---  name for the external id
665          -> UnfoldEnv    -- id -> (new Name, show_unfold)
666          -> TidyOccEnv   -- occ env for choosing new Names
667          -> IO (UnfoldEnv, TidyOccEnv)
668
669   search [] unfold_env occ_env = return (unfold_env, occ_env)
670
671   search ((idocc,referrer) : rest) unfold_env occ_env
672     | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env
673     | otherwise = do
674       (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc
675       let
676           (new_ids, show_unfold)
677                 | omit_prags = ([], False)
678                 | otherwise  = addExternal expose_all refined_id
679
680                 -- add vectorised version if any exists
681           new_ids' = new_ids ++ maybeToList (fmap snd $ lookupVarEnv vect_vars idocc)
682           
683                 -- 'idocc' is an *occurrence*, but we need to see the
684                 -- unfolding in the *definition*; so look up in binder_set
685           refined_id = case lookupVarSet binder_set idocc of
686                          Just id -> id
687                          Nothing -> WARN( True, ppr idocc ) idocc
688
689           unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)
690           referrer' | isExportedId refined_id = refined_id
691                     | otherwise               = referrer
692       --
693       search (zip new_ids' (repeat referrer') ++ rest) unfold_env' occ_env'
694
695   tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
696                 -> IO (UnfoldEnv, TidyOccEnv)
697   tidy_internal []       unfold_env occ_env = return (unfold_env,occ_env)
698   tidy_internal (id:ids) unfold_env occ_env = do
699       (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id
700       let unfold_env' = extendVarEnv unfold_env id (name',False)
701       tidy_internal ids unfold_env' occ_env'
702
703 addExternal :: Bool -> Id -> ([Id], Bool)
704 addExternal expose_all id = (new_needed_ids, show_unfold)
705   where
706     new_needed_ids = bndrFvsInOrder show_unfold id
707     idinfo         = idInfo id
708     show_unfold    = show_unfolding (unfoldingInfo idinfo)
709     never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
710     loop_breaker   = isStrongLoopBreaker (occInfo idinfo)
711     bottoming_fn   = isBottomingSig (strictnessInfo idinfo)
712
713         -- Stuff to do with the Id's unfolding
714         -- We leave the unfolding there even if there is a worker
715         -- In GHCi the unfolding is used by importers
716
717     show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })
718        =  expose_all         -- 'expose_all' says to expose all
719                              -- unfoldings willy-nilly
720
721        || isStableSource src     -- Always expose things whose
722                                  -- source is an inline rule
723
724        || not (bottoming_fn      -- No need to inline bottom functions
725            || never_active       -- Or ones that say not to
726            || loop_breaker       -- Or that are loop breakers
727            || neverUnfoldGuidance guidance)
728     show_unfolding (DFunUnfolding {}) = True
729     show_unfolding _                  = False
730 \end{code}
731
732 %************************************************************************
733 %*                                                                      *
734                Deterministic free variables
735 %*                                                                      *
736 %************************************************************************
737
738 We want a deterministic free-variable list.  exprFreeVars gives us
739 a VarSet, which is in a non-deterministic order when converted to a
740 list.  Hence, here we define a free-variable finder that returns
741 the free variables in the order that they are encountered.
742
743 See Note [Choosing external names]
744
745 \begin{code}
746 bndrFvsInOrder :: Bool -> Id -> [Id]
747 bndrFvsInOrder show_unfold id
748   = run (dffvLetBndr show_unfold id)
749
750 run :: DFFV () -> [Id]
751 run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of
752                  ((_,ids),_) -> ids
753
754 newtype DFFV a
755   = DFFV (VarSet              -- Envt: non-top-level things that are in scope
756                               -- we don't want to record these as free vars
757       -> (VarSet, [Var])      -- Input State: (set, list) of free vars so far
758       -> ((VarSet,[Var]),a))  -- Output state
759
760 instance Functor DFFV where
761     fmap = liftM
762
763 instance Applicative DFFV where
764     pure = return
765     (<*>) = ap
766
767 instance Monad DFFV where
768   return a = DFFV $ \_ st -> (st, a)
769   (DFFV m) >>= k = DFFV $ \env st ->
770     case m env st of
771        (st',a) -> case k a of
772                      DFFV f -> f env st'
773
774 extendScope :: Var -> DFFV a -> DFFV a
775 extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st)
776
777 extendScopeList :: [Var] -> DFFV a -> DFFV a
778 extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st)
779
780 insert :: Var -> DFFV ()
781 insert v = DFFV $ \ env (set, ids) ->
782            let keep_me = isLocalId v &&
783                          not (v `elemVarSet` env) &&
784                            not (v `elemVarSet` set)
785            in if keep_me
786               then ((extendVarSet set v, v:ids), ())
787               else ((set,                ids),   ())
788
789
790 dffvExpr :: CoreExpr -> DFFV ()
791 dffvExpr (Var v)              = insert v
792 dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2
793 dffvExpr (Lam v e)            = extendScope v (dffvExpr e)
794 dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e
795 dffvExpr (Tick _other e)    = dffvExpr e
796 dffvExpr (Cast e _)           = dffvExpr e
797 dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)
798 dffvExpr (Let (Rec prs) e)    = extendScopeList (map fst prs) $
799                                 (mapM_ dffvBind prs >> dffvExpr e)
800 dffvExpr (Case e b _ as)      = dffvExpr e >> extendScope b (mapM_ dffvAlt as)
801 dffvExpr _other               = return ()
802
803 dffvAlt :: (t, [Var], CoreExpr) -> DFFV ()
804 dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r)
805
806 dffvBind :: (Id, CoreExpr) -> DFFV ()
807 dffvBind(x,r)
808   | not (isId x) = dffvExpr r
809   | otherwise    = dffvLetBndr False x >> dffvExpr r
810                 -- Pass False because we are doing the RHS right here
811                 -- If you say True you'll get *exponential* behaviour!
812
813 dffvLetBndr :: Bool -> Id -> DFFV ()
814 -- Gather the free vars of the RULES and unfolding of a binder
815 -- We always get the free vars of a *stable* unfolding, but
816 -- for a *vanilla* one (InlineRhs), the flag controls what happens:
817 --   True <=> get fvs of even a *vanilla* unfolding
818 --   False <=> ignore an InlineRhs
819 -- For nested bindings (call from dffvBind) we always say "False" because
820 --       we are taking the fvs of the RHS anyway
821 -- For top-level bindings (call from addExternal, via bndrFvsInOrder)
822 --       we say "True" if we are exposing that unfolding
823 dffvLetBndr vanilla_unfold id
824   = do { go_unf (unfoldingInfo idinfo)
825        ; mapM_ go_rule (specInfoRules (specInfo idinfo)) }
826   where
827     idinfo = idInfo id
828
829     go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
830        = case src of
831            InlineRhs | vanilla_unfold -> dffvExpr rhs
832                      | otherwise      -> return ()
833            _                          -> dffvExpr rhs
834
835     go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) 
836              = extendScopeList bndrs $ mapM_ dffvExpr args
837     go_unf _ = return ()
838
839     go_rule (BuiltinRule {}) = return ()
840     go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs })
841       = extendScopeList bndrs (dffvExpr rhs)
842 \end{code}
843
844
845 %************************************************************************
846 %*                                                                      *
847                tidyTopName
848 %*                                                                      *
849 %************************************************************************
850
851 This is where we set names to local/global based on whether they really are
852 externally visible (see comment at the top of this module).  If the name
853 was previously local, we have to give it a unique occurrence name if
854 we intend to externalise it.
855
856 \begin{code}
857 tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv
858             -> Id -> IO (TidyOccEnv, Name)
859 tidyTopName mod nc_var maybe_ref occ_env id
860   | global && internal = return (occ_env, localiseName name)
861
862   | global && external = return (occ_env, name)
863         -- Global names are assumed to have been allocated by the renamer,
864         -- so they already have the "right" unique
865         -- And it's a system-wide unique too
866
867   -- Now we get to the real reason that all this is in the IO Monad:
868   -- we have to update the name cache in a nice atomic fashion
869
870   | local  && internal = do { new_local_name <- atomicModifyIORef nc_var mk_new_local
871                             ; return (occ_env', new_local_name) }
872         -- Even local, internal names must get a unique occurrence, because
873         -- if we do -split-objs we externalise the name later, in the code generator
874         --
875         -- Similarly, we must make sure it has a system-wide Unique, because
876         -- the byte-code generator builds a system-wide Name->BCO symbol table
877
878   | local  && external = do { new_external_name <- atomicModifyIORef nc_var mk_new_external
879                             ; return (occ_env', new_external_name) }
880
881   | otherwise = panic "tidyTopName"
882   where
883     name        = idName id
884     external    = isJust maybe_ref
885     global      = isExternalName name
886     local       = not global
887     internal    = not external
888     loc         = nameSrcSpan name
889
890     old_occ     = nameOccName name
891     new_occ
892       | Just ref <- maybe_ref, ref /= id =
893           mkOccName (occNameSpace old_occ) $
894              let
895                  ref_str = occNameString (getOccName ref)
896                  occ_str = occNameString old_occ
897              in
898              case occ_str of
899                '$':'w':_ -> occ_str
900                   -- workers: the worker for a function already
901                   -- includes the occname for its parent, so there's
902                   -- no need to prepend the referrer.
903                _other | isSystemName name -> ref_str
904                       | otherwise         -> ref_str ++ '_' : occ_str
905                   -- If this name was system-generated, then don't bother
906                   -- to retain its OccName, just use the referrer.  These
907                   -- system-generated names will become "f1", "f2", etc. for
908                   -- a referrer "f".
909       | otherwise = old_occ
910
911     (occ_env', occ') = tidyOccName occ_env new_occ
912
913     mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)
914                     where
915                       (uniq, us) = takeUniqFromSupply (nsUniqs nc)
916
917     mk_new_external nc = allocateGlobalBinder nc mod occ' loc
918         -- If we want to externalise a currently-local name, check
919         -- whether we have already assigned a unique for it.
920         -- If so, use it; if not, extend the table.
921         -- All this is done by allcoateGlobalBinder.
922         -- This is needed when *re*-compiling a module in GHCi; we must
923         -- use the same name for externally-visible things as we did before.
924 \end{code}
925
926 \begin{code}
927 findExternalRules :: Bool       -- Omit pragmas
928                   -> [CoreBind]
929                   -> [CoreRule] -- Local rules for imported fns
930                   -> UnfoldEnv  -- Ids that are exported, so we need their rules
931                   -> [CoreRule]
932   -- The complete rules are gotten by combining
933   --    a) local rules for imported Ids
934   --    b) rules embedded in the top-level Ids
935 findExternalRules omit_prags binds imp_id_rules unfold_env
936   | omit_prags = []
937   | otherwise  = filterOut internal_rule (imp_id_rules ++ local_rules)
938   where
939     local_rules  = [ rule
940                    | id <- bindersOfBinds binds,
941                      external_id id,
942                      rule <- idCoreRules id
943                    ]
944
945     internal_rule rule
946         =  any (not . external_id) (varSetElems (ruleLhsFreeIds rule))
947                 -- Don't export a rule whose LHS mentions a locally-defined
948                 --  Id that is completely internal (i.e. not visible to an
949                 -- importing module)
950
951     external_id id
952       | Just (name,_) <- lookupVarEnv unfold_env id = isExternalName name
953       | otherwise = False
954 \end{code}
955
956 Note [Which rules to expose]
957 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
958 findExternalRules filters imp_rules to avoid binders that
959 aren't externally visible; but the externally-visible binders
960 are computed (by findExternalIds) assuming that all orphan
961 rules are externalised (see init_ext_ids in function
962 'search'). So in fact we may export more than we need.
963 (It's a sort of mutual recursion.)
964
965 %************************************************************************
966 %*                                                                      *
967 \subsection{Step 2: top-level tidying}
968 %*                                                                      *
969 %************************************************************************
970
971
972 \begin{code}
973 -- TopTidyEnv: when tidying we need to know
974 --   * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.
975 --        These may have arisen because the
976 --        renamer read in an interface file mentioning M.$wf, say,
977 --        and assigned it unique r77.  If, on this compilation, we've
978 --        invented an Id whose name is $wf (but with a different unique)
979 --        we want to rename it to have unique r77, so that we can do easy
980 --        comparisons with stuff from the interface file
981 --
982 --   * occ_env: The TidyOccEnv, which tells us which local occurrences
983 --     are 'used'
984 --
985 --   * subst_env: A Var->Var mapping that substitutes the new Var for the old
986
987 tidyTopBinds :: HscEnv
988              -> Module
989              -> UnfoldEnv
990              -> TidyOccEnv
991              -> CoreProgram
992              -> IO (TidyEnv, CoreProgram)
993
994 tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
995   = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
996        return $ tidy mkIntegerId init_env binds
997   where
998     dflags = hsc_dflags hsc_env
999
1000     init_env = (init_occ_env, emptyVarEnv)
1001
1002     this_pkg = thisPackage dflags
1003
1004     tidy _           env []     = (env, [])
1005     tidy mkIntegerId env (b:bs) = let (env1, b')  = tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env env b
1006                                       (env2, bs') = tidy mkIntegerId env1 bs
1007                                   in
1008                                       (env2, b':bs')
1009
1010 ------------------------
1011 tidyTopBind  :: DynFlags
1012              -> PackageId
1013              -> Module
1014              -> Id
1015              -> UnfoldEnv
1016              -> TidyEnv
1017              -> CoreBind
1018              -> (TidyEnv, CoreBind)
1019
1020 tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs)
1021   = (tidy_env2,  NonRec bndr' rhs')
1022   where
1023     Just (name',show_unfold) = lookupVarEnv unfold_env bndr
1024     caf_info      = hasCafRefs dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs
1025     (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs)
1026     subst2        = extendVarEnv subst1 bndr bndr'
1027     tidy_env2     = (occ_env, subst2)
1028
1029 tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env (occ_env,subst1) (Rec prs)
1030   = (tidy_env2, Rec prs')
1031   where
1032     prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs)
1033            | (id,rhs) <- prs,
1034              let (name',show_unfold) =
1035                     expectJust "tidyTopBind" $ lookupVarEnv unfold_env id
1036            ]
1037
1038     subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')
1039     tidy_env2 = (occ_env, subst2)
1040
1041     bndrs = map fst prs
1042
1043         -- the CafInfo for a recursive group says whether *any* rhs in
1044         -- the group may refer indirectly to a CAF (because then, they all do).
1045     caf_info
1046         | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs)
1047              | (bndr,rhs) <- prs ] = MayHaveCafRefs
1048         | otherwise                = NoCafRefs
1049
1050 -----------------------------------------------------------
1051 tidyTopPair :: DynFlags
1052             -> Bool  -- show unfolding
1053             -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo
1054                         -- It is knot-tied: don't look at it!
1055             -> CafInfo
1056             -> Name             -- New name
1057             -> (Id, CoreExpr)   -- Binder and RHS before tidying
1058             -> (Id, CoreExpr)
1059         -- This function is the heart of Step 2
1060         -- The rec_tidy_env is the one to use for the IdInfo
1061         -- It's necessary because when we are dealing with a recursive
1062         -- group, a variable late in the group might be mentioned
1063         -- in the IdInfo of one early in the group
1064
1065 tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs)
1066   = (bndr1, rhs1)
1067   where
1068     bndr1    = mkGlobalId details name' ty' idinfo'
1069     details  = idDetails bndr   -- Preserve the IdDetails
1070     ty'      = tidyTopType (idType bndr)
1071     rhs1     = tidyExpr rhs_tidy_env rhs
1072     idinfo'  = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr)
1073                              show_unfold caf_info
1074
1075 -- tidyTopIdInfo creates the final IdInfo for top-level
1076 -- binders.  There are two delicate pieces:
1077 --
1078 --  * Arity.  After CoreTidy, this arity must not change any more.
1079 --      Indeed, CorePrep must eta expand where necessary to make
1080 --      the manifest arity equal to the claimed arity.
1081 --
1082 --  * CAF info.  This must also remain valid through to code generation.
1083 --      We add the info here so that it propagates to all
1084 --      occurrences of the binders in RHSs, and hence to occurrences in
1085 --      unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
1086 --      CoreToStg makes use of this when constructing SRTs.
1087 tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr
1088               -> IdInfo -> Bool -> CafInfo -> IdInfo
1089 tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
1090   | not is_external     -- For internal Ids (not externally visible)
1091   = vanillaIdInfo       -- we only need enough info for code generation
1092                         -- Arity and strictness info are enough;
1093                         --      c.f. CoreTidy.tidyLetBndr
1094         `setCafInfo`        caf_info
1095         `setArityInfo`      arity
1096         `setStrictnessInfo` final_sig
1097
1098   | otherwise           -- Externally-visible Ids get the whole lot
1099   = vanillaIdInfo
1100         `setCafInfo`           caf_info
1101         `setArityInfo`         arity
1102         `setStrictnessInfo`    final_sig
1103         `setOccInfo`           robust_occ_info
1104         `setInlinePragInfo`    (inlinePragInfo idinfo)
1105         `setUnfoldingInfo`     unfold_info
1106                 -- NB: we throw away the Rules
1107                 -- They have already been extracted by findExternalRules
1108   where
1109     is_external = isExternalName name
1110
1111     --------- OccInfo ------------
1112     robust_occ_info = zapFragileOcc (occInfo idinfo)
1113     -- It's important to keep loop-breaker information
1114     -- when we are doing -fexpose-all-unfoldings
1115
1116     --------- Strictness ------------
1117     mb_bot_str = exprBotStrictness_maybe orig_rhs
1118
1119     sig = strictnessInfo idinfo
1120     final_sig | not $ isNopSig sig
1121                  = WARN( _bottom_hidden sig , ppr name ) sig 
1122                  -- try a cheap-and-cheerful bottom analyser
1123                  | Just (_, nsig) <- mb_bot_str = nsig
1124                  | otherwise                    = sig
1125
1126     _bottom_hidden id_sig = case mb_bot_str of
1127                                   Nothing         -> False
1128                                   Just (arity, _) -> not (appIsBottom id_sig arity)
1129
1130     --------- Unfolding ------------
1131     unf_info = unfoldingInfo idinfo
1132     unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
1133                 | otherwise   = noUnfolding
1134     unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs
1135     is_bot = isBottomingSig final_sig
1136     -- NB: do *not* expose the worker if show_unfold is off,
1137     --     because that means this thing is a loop breaker or
1138     --     marked NOINLINE or something like that
1139     -- This is important: if you expose the worker for a loop-breaker
1140     -- then you can make the simplifier go into an infinite loop, because
1141     -- in effect the unfolding is exposed.  See Trac #1709
1142     --
1143     -- You might think that if show_unfold is False, then the thing should
1144     -- not be w/w'd in the first place.  But a legitimate reason is this:
1145     --    the function returns bottom
1146     -- In this case, show_unfold will be false (we don't expose unfoldings
1147     -- for bottoming functions), but we might still have a worker/wrapper
1148     -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs
1149
1150     --------- Arity ------------
1151     -- Usually the Id will have an accurate arity on it, because
1152     -- the simplifier has just run, but not always.
1153     -- One case I found was when the last thing the simplifier
1154     -- did was to let-bind a non-atomic argument and then float
1155     -- it to the top level. So it seems more robust just to
1156     -- fix it here.
1157     arity = exprArity orig_rhs
1158 \end{code}
1159
1160 %************************************************************************
1161 %*                                                                      *
1162 \subsection{Figuring out CafInfo for an expression}
1163 %*                                                                      *
1164 %************************************************************************
1165
1166 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
1167 We mark such things as `MayHaveCafRefs' because this information is
1168 used to decide whether a particular closure needs to be referenced
1169 in an SRT or not.
1170
1171 There are two reasons for setting MayHaveCafRefs:
1172         a) The RHS is a CAF: a top-level updatable thunk.
1173         b) The RHS refers to something that MayHaveCafRefs
1174
1175 Possible improvement: In an effort to keep the number of CAFs (and
1176 hence the size of the SRTs) down, we could also look at the expression and
1177 decide whether it requires a small bounded amount of heap, so we can ignore
1178 it as a CAF.  In these cases however, we would need to use an additional
1179 CAF list to keep track of non-collectable CAFs.
1180
1181 \begin{code}
1182 hasCafRefs :: DynFlags -> PackageId -> Module
1183            -> (Id, VarEnv Var) -> Arity -> CoreExpr
1184            -> CafInfo
1185 hasCafRefs dflags this_pkg this_mod p arity expr
1186   | is_caf || mentions_cafs = MayHaveCafRefs
1187   | otherwise               = NoCafRefs
1188  where
1189   mentions_cafs = isFastTrue (cafRefsE dflags p expr)
1190   is_dynamic_name = isDllName dflags this_pkg this_mod
1191   is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr)
1192
1193   -- NB. we pass in the arity of the expression, which is expected
1194   -- to be calculated by exprArity.  This is because exprArity
1195   -- knows how much eta expansion is going to be done by
1196   -- CorePrep later on, and we don't want to duplicate that
1197   -- knowledge in rhsIsStatic below.
1198
1199 cafRefsE :: DynFlags -> (Id, VarEnv Id) -> Expr a -> FastBool
1200 cafRefsE _      p (Var id)            = cafRefsV p id
1201 cafRefsE dflags p (Lit lit)           = cafRefsL dflags p lit
1202 cafRefsE dflags p (App f a)           = fastOr (cafRefsE dflags p f) (cafRefsE dflags p) a
1203 cafRefsE dflags p (Lam _ e)           = cafRefsE dflags p e
1204 cafRefsE dflags p (Let b e)           = fastOr (cafRefsEs dflags p (rhssOfBind b)) (cafRefsE dflags p) e
1205 cafRefsE dflags p (Case e _bndr _ alts) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) (rhssOfAlts alts)
1206 cafRefsE dflags p (Tick _n e)         = cafRefsE dflags p e
1207 cafRefsE dflags p (Cast e _co)        = cafRefsE dflags p e
1208 cafRefsE _      _ (Type _)            = fastBool False
1209 cafRefsE _      _ (Coercion _)        = fastBool False
1210
1211 cafRefsEs :: DynFlags -> (Id, VarEnv Id) -> [Expr a] -> FastBool
1212 cafRefsEs _      _ []     = fastBool False
1213 cafRefsEs dflags p (e:es) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) es
1214
1215 cafRefsL :: DynFlags -> (Id, VarEnv Id) -> Literal -> FastBool
1216 -- Don't forget that mk_integer id might have Caf refs!
1217 -- We first need to convert the Integer into its final form, to
1218 -- see whether mkInteger is used.
1219 cafRefsL dflags p@(mk_integer, _) (LitInteger i _) = cafRefsE dflags p (cvtLitInteger dflags mk_integer i)
1220 cafRefsL _      _ _                         = fastBool False
1221
1222 cafRefsV :: (Id, VarEnv Id) -> Id -> FastBool
1223 cafRefsV (_, p) id
1224   | not (isLocalId id)            = fastBool (mayHaveCafRefs (idCafInfo id))
1225   | Just id' <- lookupVarEnv p id = fastBool (mayHaveCafRefs (idCafInfo id'))
1226   | otherwise                     = fastBool False
1227
1228 fastOr :: FastBool -> (a -> FastBool) -> a -> FastBool
1229 -- hack for lazy-or over FastBool.
1230 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
1231 \end{code}
1232
1233
1234 ------------------------------------------------------------------------------
1235 --               Old, dead, type-trimming code
1236 -------------------------------------------------------------------------------
1237
1238 We used to try to "trim off" the constructors of data types that are
1239 not exported, to reduce the size of interface files, at least without
1240 -O.  But that is not always possible: see the old Note [When we can't
1241 trim types] below for exceptions.
1242
1243 Then (Trac #7445) I realised that the TH problem arises for any data type
1244 that we have deriving( Data ), because we can invoke
1245    Language.Haskell.TH.Quote.dataToExpQ
1246 to get a TH Exp representation of a value built from that data type.
1247 You don't even need {-# LANGUAGE TemplateHaskell #-}.
1248
1249 At this point I give up. The pain of trimming constructors just
1250 doesn't seem worth the gain.  So I've dumped all the code, and am just
1251 leaving it here at the end of the module in case something like this
1252 is ever resurrected.
1253
1254
1255 Note [When we can't trim types]
1256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1257 The basic idea of type trimming is to export algebraic data types
1258 abstractly (without their data constructors) when compiling without
1259 -O, unless of course they are explicitly exported by the user.
1260
1261 We always export synonyms, because they can be mentioned in the type
1262 of an exported Id.  We could do a full dependency analysis starting
1263 from the explicit exports, but that's quite painful, and not done for
1264 now.
1265
1266 But there are some times we can't do that, indicated by the 'no_trim_types' flag.
1267
1268 First, Template Haskell.  Consider (Trac #2386) this
1269         module M(T, makeOne) where
1270           data T = Yay String
1271           makeOne = [| Yay "Yep" |]
1272 Notice that T is exported abstractly, but makeOne effectively exports it too!
1273 A module that splices in $(makeOne) will then look for a declartion of Yay,
1274 so it'd better be there.  Hence, brutally but simply, we switch off type
1275 constructor trimming if TH is enabled in this module.
1276
1277 Second, data kinds.  Consider (Trac #5912)
1278      {-# LANGUAGE DataKinds #-}
1279      module M() where
1280      data UnaryTypeC a = UnaryDataC a
1281      type Bug = 'UnaryDataC
1282 We always export synonyms, so Bug is exposed, and that means that
1283 UnaryTypeC must be too, even though it's not explicitly exported.  In
1284 effect, DataKinds means that we'd need to do a full dependency analysis
1285 to see what data constructors are mentioned.  But we don't do that yet.
1286
1287 In these two cases we just switch off type trimming altogether.
1288
1289 mustExposeTyCon :: Bool         -- Type-trimming flag
1290                 -> NameSet      -- Exports
1291                 -> TyCon        -- The tycon
1292                 -> Bool         -- Can its rep be hidden?
1293 -- We are compiling without -O, and thus trying to write as little as
1294 -- possible into the interface file.  But we must expose the details of
1295 -- any data types whose constructors or fields are exported
1296 mustExposeTyCon no_trim_types exports tc
1297   | no_trim_types               -- See Note [When we can't trim types]
1298   = True
1299
1300   | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to
1301                                 -- figure out whether it was mentioned in the type
1302                                 -- of any other exported thing)
1303   = True
1304
1305   | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors
1306   = True                        -- won't lead to the need for further exposure
1307
1308   | isFamilyTyCon tc            -- Open type family
1309   = True
1310
1311   -- Below here we just have data/newtype decls or family instances
1312
1313   | null data_cons              -- Ditto if there are no data constructors
1314   = True                        -- (NB: empty data types do not count as enumerations
1315                                 -- see Note [Enumeration types] in TyCon
1316
1317   | any exported_con data_cons  -- Expose rep if any datacon or field is exported
1318   = True
1319
1320   | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))
1321   = True   -- Expose the rep for newtypes if the rep is an FFI type.
1322            -- For a very annoying reason.  'Foreign import' is meant to
1323            -- be able to look through newtypes transparently, but it
1324            -- can only do that if it can "see" the newtype representation
1325
1326   | otherwise
1327   = False
1328   where
1329     data_cons = tyConDataCons tc
1330     exported_con con = any (`elemNameSet` exports)
1331                            (dataConName con : dataConFieldLabels con)