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