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