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