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