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