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