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