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