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