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