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