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