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