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