2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section{Tidying up Core}
7 module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, tidyProgram ) where
9 #include "HsVersions.h"
44 import FastTypes hiding (fastOr)
46 import Data.List ( partition )
47 import Data.Maybe ( isJust )
48 import Data.IORef ( IORef, readIORef, writeIORef )
50 _dummy :: FS.FastString
55 Constructing the TypeEnv, Instances, Rules from which the ModIface is
56 constructed, and which goes on to subsequent modules in --make mode.
58 Most of the interface file is obtained simply by serialising the
59 TypeEnv. One important consequence is that if the *interface file*
60 has pragma info if and only if the final TypeEnv does. This is not so
61 important for *this* module, but it's essential for ghc --make:
62 subsequent compilations must not see (e.g.) the arity if the interface
63 file does not contain arity If they do, they'll exploit the arity;
64 then the arity might change, but the iface file doesn't change =>
65 recompilation does not happen => disaster.
67 For data types, the final TypeEnv will have a TyThing for the TyCon,
68 plus one for each DataCon; the interface file will contain just one
69 data type declaration, but it is de-serialised back into a collection
72 %************************************************************************
76 %************************************************************************
79 Plan A: mkBootModDetails: omit pragmas, make interfaces small
80 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
83 * Drop all WiredIn things from the TypeEnv
84 (we never want them in interface files)
86 * Retain all TyCons and Classes in the TypeEnv, to avoid
87 having to find which ones are mentioned in the
90 * Trim off the constructors of non-exported TyCons, both
91 from the TyCon and from the TypeEnv
93 * Drop non-exported Ids from the TypeEnv
95 * Tidy the types of the DFunIds of Instances,
96 make them into GlobalIds, (they already have External Names)
97 and add them to the TypeEnv
99 * Tidy the types of the (exported) Ids in the TypeEnv,
100 make them into GlobalIds (they already have External Names)
102 * Drop rules altogether
104 * Tidy the bindings, to ensure that the Caf and Arity
105 information is correct for each top-level binder; the
106 code generator needs it. And to ensure that local names have
107 distinct OccNames in case of object-file splitting
110 -- This is Plan A: make a small type env when typechecking only,
111 -- or when compiling a hs-boot file, or simply when not using -O
113 -- We don't look at the bindings at all -- there aren't any
116 mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails
117 mkBootModDetailsTc hsc_env
118 TcGblEnv{ tcg_exports = exports,
119 tcg_type_env = type_env,
121 tcg_fam_insts = fam_insts
123 = mkBootModDetails hsc_env exports type_env insts fam_insts
125 mkBootModDetailsDs :: HscEnv -> ModGuts -> IO ModDetails
126 mkBootModDetailsDs hsc_env
127 ModGuts{ mg_exports = exports,
130 mg_fam_insts = fam_insts
132 = mkBootModDetails hsc_env exports type_env insts fam_insts
134 mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing
135 -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails
136 mkBootModDetails hsc_env exports type_env insts fam_insts
137 = do { let dflags = hsc_dflags hsc_env
138 ; showPass dflags "Tidy [hoot] type env"
140 ; let { insts' = tidyInstances tidyExternalId insts
141 ; type_env1 = filterNameEnv (not . isWiredInThing) type_env
142 ; type_env2 = mapNameEnv tidyBootThing type_env1
143 ; type_env' = extendTypeEnvWithIds type_env2
144 (map instanceDFunId insts')
146 ; return (ModDetails { md_types = type_env'
148 , md_fam_insts = fam_insts
150 , md_exports = exports
151 , md_vect_info = noVectInfo
156 isWiredInThing :: TyThing -> Bool
157 isWiredInThing thing = isWiredInName (getName thing)
159 tidyBootThing :: TyThing -> TyThing
160 -- Just externalise the Ids; keep everything
161 tidyBootThing (AnId id) | isLocalId id = AnId (tidyExternalId id)
162 tidyBootThing thing = thing
164 tidyExternalId :: Id -> Id
165 -- Takes an LocalId with an External Name,
166 -- makes it into a GlobalId with VanillaIdInfo, and tidies its type
167 -- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.)
169 = ASSERT2( isLocalId id && isExternalName (idName id), ppr id )
170 mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo
174 %************************************************************************
176 Plan B: tidy bindings, make TypeEnv full of IdInfo
178 %************************************************************************
180 Plan B: include pragmas, make interfaces
181 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
182 * Figure out which Ids are externally visible
184 * Tidy the bindings, externalising appropriate Ids
186 * Drop all Ids from the TypeEnv, and add all the External Ids from
187 the bindings. (This adds their IdInfo to the TypeEnv; and adds
188 floated-out Ids that weren't even in the TypeEnv before.)
190 Step 1: Figure out external Ids
191 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
192 First we figure out which Ids are "external" Ids. An
193 "external" Id is one that is visible from outside the compilation
195 a) the user exported ones
196 b) ones mentioned in the unfoldings, workers,
197 or rules of externally-visible ones
198 This exercise takes a sweep of the bindings bottom to top. Actually,
199 in Step 2 we're also going to need to know which Ids should be
200 exported with their unfoldings, so we produce not an IdSet but an
204 Step 2: Tidy the program
205 ~~~~~~~~~~~~~~~~~~~~~~~~
206 Next we traverse the bindings top to bottom. For each *top-level*
209 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,
210 reflecting the fact that from now on we regard it as a global,
213 2. Give it a system-wide Unique.
214 [Even non-exported things need system-wide Uniques because the
215 byte-code generator builds a single Name->BCO symbol table.]
217 We use the NameCache kept in the HscEnv as the
218 source of such system-wide uniques.
220 For external Ids, use the original-name cache in the NameCache
221 to ensure that the unique assigned is the same as the Id had
222 in any previous compilation run.
224 3. If it's an external Id, make it have a External Name, otherwise
225 make it have an Internal Name.
226 This is used by the code generator to decide whether
227 to make the label externally visible
229 4. Give external Ids a "tidy" OccName. This means
230 we can print them in interface files without confusing
231 "x" (unique 5) with "x" (unique 10).
233 5. Give it its UTTERLY FINAL IdInfo; in ptic,
234 * its unfolding, if it should have one
236 * its arity, computed from the number of visible lambdas
238 * its CAF info, computed from what is free in its RHS
241 Finally, substitute these new top-level binders consistently
242 throughout, including in unfoldings. We also tidy binders in
243 RHSs, so that they print nicely in interfaces.
246 tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
248 (ModGuts { mg_module = mod, mg_exports = exports,
250 mg_insts = insts, mg_fam_insts = fam_insts,
252 mg_rules = imp_rules,
253 mg_vect_info = vect_info,
254 mg_dir_imps = dir_imps,
256 mg_foreign = foreign_stubs,
257 mg_hpc_info = hpc_info,
258 mg_modBreaks = modBreaks })
260 = do { let dflags = hsc_dflags hsc_env
261 ; showPass dflags "Tidy Core"
263 ; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags
264 ; ext_ids = findExternalIds omit_prags binds
267 | otherwise = findExternalRules binds imp_rules ext_ids
268 -- findExternalRules filters imp_rules to avoid binders that
269 -- aren't externally visible; but the externally-visible binders
270 -- are computed (by findExternalIds) assuming that all orphan
271 -- rules are exported (they get their Exported flag set in the desugarer)
272 -- So in fact we may export more than we need.
273 -- (It's a sort of mutual recursion.)
276 ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids
279 ; let { export_set = availsToNameSet exports
280 ; tidy_type_env = tidyTypeEnv omit_prags export_set type_env
282 ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts
283 -- A DFunId will have a binding in tidy_binds, and so
284 -- will now be in final_env, replete with IdInfo
285 -- Its name will be unchanged since it was born, but
286 -- we want Global, IdInfo-rich (or not) DFunId in the
289 ; tidy_rules = tidyRules tidy_env ext_rules
290 -- You might worry that the tidy_env contains IdInfo-rich stuff
291 -- and indeed it does, but if omit_prags is on, ext_rules is
294 ; implicit_binds = getImplicitBinds type_env
295 ; all_tidy_binds = implicit_binds ++ tidy_binds
296 ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
299 ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds
300 ; dumpIfSet_core dflags Opt_D_dump_simpl
302 (pprRules tidy_rules)
304 ; let dir_imp_mods = map fst (moduleEnvElts dir_imps)
306 ; return (CgGuts { cg_module = mod,
307 cg_tycons = alg_tycons,
308 cg_binds = all_tidy_binds,
309 cg_dir_imps = dir_imp_mods,
310 cg_foreign = foreign_stubs,
311 cg_dep_pkgs = dep_pkgs deps,
312 cg_hpc_info = hpc_info,
313 cg_modBreaks = modBreaks },
315 ModDetails { md_types = tidy_type_env,
316 md_rules = tidy_rules,
317 md_insts = tidy_insts,
318 md_fam_insts = fam_insts,
319 md_exports = exports,
320 md_vect_info = vect_info -- is already tidy
324 lookup_dfun :: TypeEnv -> Var -> Id
325 lookup_dfun type_env dfun_id
326 = case lookupTypeEnv type_env (idName dfun_id) of
327 Just (AnId dfun_id') -> dfun_id'
328 _other -> pprPanic "lookup_dfun" (ppr dfun_id)
330 tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv
332 -- The competed type environment is gotten from
333 -- Dropping any wired-in things, and then
334 -- a) keeping the types and classes
335 -- b) removing all Ids,
336 -- c) adding Ids with correct IdInfo, including unfoldings,
337 -- gotten from the bindings
338 -- From (c) we keep only those Ids with External names;
339 -- the CoreTidy pass makes sure these are all and only
340 -- the externally-accessible ones
341 -- This truncates the type environment to include only the
342 -- exported Ids and things needed from them, which saves space
344 tidyTypeEnv omit_prags exports type_env tidy_binds
345 = let type_env1 = filterNameEnv keep_it type_env
346 type_env2 = extendTypeEnvWithIds type_env1 final_ids
347 type_env3 | omit_prags = mapNameEnv trim_thing type_env2
348 | otherwise = type_env2
352 final_ids = [ id | id <- bindersOfBinds tidy_binds,
353 isExternalName (idName id)]
355 -- We keep GlobalIds, because they won't appear
356 -- in the bindings from which final_ids are derived!
357 -- (The bindings bind LocalIds.)
358 keep_it thing | isWiredInThing thing = False
359 keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops)
360 keep_it _other = True -- Keep all TyCons, DataCons, and Classes
364 ATyCon tc | mustExposeTyCon exports tc -> thing
365 | otherwise -> ATyCon (makeTyConAbstract tc)
367 AnId id | isImplicitId id -> thing
368 | otherwise -> AnId (id `setIdInfo` vanillaIdInfo)
372 mustExposeTyCon :: NameSet -- Exports
373 -> TyCon -- The tycon
374 -> Bool -- Can its rep be hidden?
375 -- We are compiling without -O, and thus trying to write as little as
376 -- possible into the interface file. But we must expose the details of
377 -- any data types whose constructors or fields are exported
378 mustExposeTyCon exports tc
379 | not (isAlgTyCon tc) -- Synonyms
381 | isEnumerationTyCon tc -- For an enumeration, exposing the constructors
382 = True -- won't lead to the need for further exposure
383 -- (This includes data types with no constructors.)
384 | isOpenTyCon tc -- open type family
386 | otherwise -- Newtype, datatype
387 = any exported_con (tyConDataCons tc)
388 -- Expose rep if any datacon or field is exported
390 || (isNewTyCon tc && isFFITy (snd (newTyConRep tc)))
391 -- Expose the rep for newtypes if the rep is an FFI type.
392 -- For a very annoying reason. 'Foreign import' is meant to
393 -- be able to look through newtypes transparently, but it
394 -- can only do that if it can "see" the newtype representation
396 exported_con con = any (`elemNameSet` exports)
397 (dataConName con : dataConFieldLabels con)
399 tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance]
400 tidyInstances tidy_dfun ispecs
403 tidy ispec = setInstanceDFunId ispec $
404 tidy_dfun (instanceDFunId ispec)
406 getImplicitBinds :: TypeEnv -> [CoreBind]
407 getImplicitBinds type_env
408 = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env)
409 ++ concatMap other_implicit_ids (typeEnvElts type_env))
410 -- Put the constructor wrappers first, because
411 -- other implicit bindings (notably the fromT functions arising
412 -- from generics) use the constructor wrappers. At least that's
413 -- what External Core likes
415 implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
417 other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc)
418 -- The "naughty" ones are not real functions at all
419 -- They are there just so we can get decent error messages
420 -- See Note [Naughty record selectors] in MkId.lhs
421 other_implicit_ids (AClass cl) = classSelIds cl
422 other_implicit_ids _other = []
424 get_defn :: Id -> CoreBind
425 get_defn id = NonRec id (tidyExpr emptyTidyEnv rhs)
427 rhs = unfoldingTemplate (idUnfolding id)
428 -- Don't forget to tidy the body ! Otherwise you get silly things like
429 -- \ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl
433 %************************************************************************
435 \subsection{Step 1: finding externals}
437 %************************************************************************
440 findExternalIds :: Bool
442 -> IdEnv Bool -- In domain => external
443 -- Range = True <=> show unfolding
444 -- Step 1 from the notes above
445 findExternalIds omit_prags binds
447 = mkVarEnv [ (id,False) | id <- bindersOfBinds binds, isExportedId id ]
450 = foldr find emptyVarEnv binds
452 find (NonRec id rhs) needed
453 | need_id needed id = addExternal (id,rhs) needed
455 find (Rec prs) needed = find_prs prs needed
457 -- For a recursive group we have to look for a fixed point
459 | null needed_prs = needed
460 | otherwise = find_prs other_prs new_needed
462 (needed_prs, other_prs) = partition (need_pr needed) prs
463 new_needed = foldr addExternal needed needed_prs
465 -- The 'needed' set contains the Ids that are needed by earlier
466 -- interface file emissions. If the Id isn't in this set, and isn't
467 -- exported, there's no need to emit anything
468 need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
469 need_pr needed_set (id,_) = need_id needed_set id
471 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
472 -- The Id is needed; extend the needed set
473 -- with it and its dependents (free vars etc)
474 addExternal (id,rhs) needed
475 = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
478 add_occ id needed | id `elemVarEnv` needed = needed
479 | otherwise = extendVarEnv needed id False
480 -- "False" because we don't know we need the Id's unfolding
481 -- Don't override existing bindings; we might have already set it to True
483 new_needed_ids = worker_ids `unionVarSet`
484 unfold_ids `unionVarSet`
488 dont_inline = isNeverActive (inlinePragInfo idinfo)
489 loop_breaker = isNonRuleLoopBreaker (occInfo idinfo)
490 bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
491 spec_ids = specInfoFreeVars (specInfo idinfo)
492 worker_info = workerInfo idinfo
494 -- Stuff to do with the Id's unfolding
495 -- The simplifier has put an up-to-date unfolding
496 -- in the IdInfo, but the RHS will do just as well
497 unfolding = unfoldingInfo idinfo
498 rhs_is_small = not (neverUnfold unfolding)
500 -- We leave the unfolding there even if there is a worker
501 -- In GHCI the unfolding is used by importers
502 -- When writing an interface file, we omit the unfolding
503 -- if there is a worker
504 show_unfold = not bottoming_fn && -- Not necessary
507 rhs_is_small -- Small enough
509 unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
510 | otherwise = emptyVarSet
512 worker_ids = case worker_info of
513 HasWorker work_id _ -> unitVarSet work_id
514 _otherwise -> emptyVarSet
519 findExternalRules :: [CoreBind]
520 -> [CoreRule] -- Non-local rules (i.e. ones for imported fns)
521 -> IdEnv a -- Ids that are exported, so we need their rules
523 -- The complete rules are gotten by combining
524 -- a) the non-local rules
525 -- b) rules embedded in the top-level Ids
526 findExternalRules binds non_local_rules ext_ids
527 = filter (not . internal_rule) (non_local_rules ++ local_rules)
530 | id <- bindersOfBinds binds,
531 id `elemVarEnv` ext_ids,
532 rule <- idCoreRules id
536 = any internal_id (varSetElems (ruleLhsFreeIds rule))
537 -- Don't export a rule whose LHS mentions a locally-defined
538 -- Id that is completely internal (i.e. not visible to an
541 internal_id id = not (id `elemVarEnv` ext_ids)
546 %************************************************************************
548 \subsection{Step 2: top-level tidying}
550 %************************************************************************
554 -- TopTidyEnv: when tidying we need to know
555 -- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.
556 -- These may have arisen because the
557 -- renamer read in an interface file mentioning M.$wf, say,
558 -- and assigned it unique r77. If, on this compilation, we've
559 -- invented an Id whose name is $wf (but with a different unique)
560 -- we want to rename it to have unique r77, so that we can do easy
561 -- comparisons with stuff from the interface file
563 -- * occ_env: The TidyOccEnv, which tells us which local occurrences
566 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
568 tidyTopBinds :: HscEnv
571 -> IdEnv Bool -- Domain = Ids that should be external
572 -- True <=> their unfolding is external too
574 -> IO (TidyEnv, [CoreBind])
576 tidyTopBinds hsc_env mod type_env ext_ids binds
577 = tidy init_env binds
579 nc_var = hsc_NC hsc_env
581 -- We also make sure to avoid any exported binders. Consider
582 -- f{-u1-} = 1 -- Local decl
584 -- f{-u2-} = 2 -- Exported decl
586 -- The second exported decl must 'get' the name 'f', so we
587 -- have to put 'f' in the avoids list before we get to the first
588 -- decl. tidyTopId then does a no-op on exported binders.
589 init_env = (initTidyOccEnv avoids, emptyVarEnv)
590 avoids = [getOccName name | bndr <- typeEnvIds type_env,
591 let name = idName bndr,
593 -- In computing our "avoids" list, we must include
595 -- all things with global names (assigned once and for
596 -- all by the renamer)
597 -- since their names are "taken".
598 -- The type environment is a convenient source of such things.
600 this_pkg = thisPackage (hsc_dflags hsc_env)
602 tidy env [] = return (env, [])
603 tidy env (b:bs) = do { (env1, b') <- tidyTopBind this_pkg mod nc_var ext_ids env b
604 ; (env2, bs') <- tidy env1 bs
605 ; return (env2, b':bs') }
607 ------------------------
608 tidyTopBind :: PackageId
610 -> IORef NameCache -- For allocating new unique names
611 -> IdEnv Bool -- Domain = Ids that should be external
612 -- True <=> their unfolding is external too
613 -> TidyEnv -> CoreBind
614 -> IO (TidyEnv, CoreBind)
616 tidyTopBind this_pkg mod nc_var ext_ids (occ_env1,subst1) (NonRec bndr rhs)
617 = do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr
618 ; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs)
619 ; subst2 = extendVarEnv subst1 bndr bndr'
620 ; tidy_env2 = (occ_env2, subst2) }
621 ; return (tidy_env2, NonRec bndr' rhs') }
623 caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs
625 tidyTopBind this_pkg mod nc_var ext_ids (occ_env1,subst1) (Rec prs)
626 = do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs
627 ; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info)
629 ; subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs')
630 ; tidy_env2 = (occ_env2, subst2) }
631 ; return (tidy_env2, Rec prs') }
635 -- the CafInfo for a recursive group says whether *any* rhs in
636 -- the group may refer indirectly to a CAF (because then, they all do).
638 | or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs)
639 | (bndr,rhs) <- prs ] = MayHaveCafRefs
640 | otherwise = NoCafRefs
642 --------------------------------------------------------------------
644 -- This is where we set names to local/global based on whether they really are
645 -- externally visible (see comment at the top of this module). If the name
646 -- was previously local, we have to give it a unique occurrence name if
647 -- we intend to externalise it.
648 tidyTopNames :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv
649 -> [Id] -> IO (TidyOccEnv, [Name])
650 tidyTopNames _mod _nc_var _ext_ids occ_env [] = return (occ_env, [])
651 tidyTopNames mod nc_var ext_ids occ_env (id:ids)
652 = do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id
653 ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids
654 ; return (occ_env2, name:names) }
656 tidyTopName :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv
657 -> Id -> IO (TidyOccEnv, Name)
658 tidyTopName mod nc_var ext_ids occ_env id
659 | global && internal = return (occ_env, localiseName name)
661 | global && external = return (occ_env, name)
662 -- Global names are assumed to have been allocated by the renamer,
663 -- so they already have the "right" unique
664 -- And it's a system-wide unique too
666 -- Now we get to the real reason that all this is in the IO Monad:
667 -- we have to update the name cache in a nice atomic fashion
669 | local && internal = do { nc <- readIORef nc_var
670 ; let (nc', new_local_name) = mk_new_local nc
671 ; writeIORef nc_var nc'
672 ; return (occ_env', new_local_name) }
673 -- Even local, internal names must get a unique occurrence, because
674 -- if we do -split-objs we externalise the name later, in the code generator
676 -- Similarly, we must make sure it has a system-wide Unique, because
677 -- the byte-code generator builds a system-wide Name->BCO symbol table
679 | local && external = do { nc <- readIORef nc_var
680 ; let (nc', new_external_name) = mk_new_external nc
681 ; writeIORef nc_var nc'
682 ; return (occ_env', new_external_name) }
684 | otherwise = panic "tidyTopName"
687 external = id `elemVarEnv` ext_ids
688 global = isExternalName name
690 internal = not external
691 loc = nameSrcSpan name
693 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
695 mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc)
697 (us1, us2) = splitUniqSupply (nsUniqs nc)
698 uniq = uniqFromSupply us1
700 mk_new_external nc = allocateGlobalBinder nc mod occ' loc
701 -- If we want to externalise a currently-local name, check
702 -- whether we have already assigned a unique for it.
703 -- If so, use it; if not, extend the table.
704 -- All this is done by allcoateGlobalBinder.
705 -- This is needed when *re*-compiling a module in GHCi; we must
706 -- use the same name for externally-visible things as we did before.
709 -----------------------------------------------------------
710 tidyTopPair :: VarEnv Bool
711 -> TidyEnv -- The TidyEnv is used to tidy the IdInfo
712 -- It is knot-tied: don't look at it!
715 -> (Id, CoreExpr) -- Binder and RHS before tidying
717 -- This function is the heart of Step 2
718 -- The rec_tidy_env is the one to use for the IdInfo
719 -- It's necessary because when we are dealing with a recursive
720 -- group, a variable late in the group might be mentioned
721 -- in the IdInfo of one early in the group
723 tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs)
724 | isGlobalId bndr -- Injected binding for record selector, etc
725 = (bndr, tidyExpr rhs_tidy_env rhs)
729 bndr' = mkVanillaGlobal name' ty' idinfo'
730 ty' = tidyTopType (idType bndr)
731 rhs' = tidyExpr rhs_tidy_env rhs
733 idinfo' = tidyTopIdInfo (isJust maybe_external)
734 idinfo unfold_info worker_info
737 -- Expose an unfolding if ext_ids tells us to
738 -- Remember that ext_ids maps an Id to a Bool:
739 -- True to show the unfolding, False to hide it
740 maybe_external = lookupVarEnv ext_ids bndr
741 show_unfold = maybe_external `orElse` False
742 unfold_info | show_unfold = mkTopUnfolding rhs'
743 | otherwise = noUnfolding
744 worker_info = tidyWorker rhs_tidy_env show_unfold (workerInfo idinfo)
746 -- Usually the Id will have an accurate arity on it, because
747 -- the simplifier has just run, but not always.
748 -- One case I found was when the last thing the simplifier
749 -- did was to let-bind a non-atomic argument and then float
750 -- it to the top level. So it seems more robust just to
752 arity = exprArity rhs
755 -- tidyTopIdInfo creates the final IdInfo for top-level
756 -- binders. There are two delicate pieces:
758 -- * Arity. After CoreTidy, this arity must not change any more.
759 -- Indeed, CorePrep must eta expand where necessary to make
760 -- the manifest arity equal to the claimed arity.
762 -- * CAF info. This must also remain valid through to code generation.
763 -- We add the info here so that it propagates to all
764 -- occurrences of the binders in RHSs, and hence to occurrences in
765 -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
766 -- CoreToStg makes use of this when constructing SRTs.
767 tidyTopIdInfo :: Bool -> IdInfo -> Unfolding
768 -> WorkerInfo -> ArityInfo -> CafInfo
770 tidyTopIdInfo is_external idinfo unfold_info worker_info arity caf_info
771 | not is_external -- For internal Ids (not externally visible)
772 = vanillaIdInfo -- we only need enough info for code generation
773 -- Arity and strictness info are enough;
774 -- c.f. CoreTidy.tidyLetBndr
775 `setCafInfo` caf_info
777 `setAllStrictnessInfo` newStrictnessInfo idinfo
779 | otherwise -- Externally-visible Ids get the whole lot
781 `setCafInfo` caf_info
783 `setAllStrictnessInfo` newStrictnessInfo idinfo
784 `setInlinePragInfo` inlinePragInfo idinfo
785 `setUnfoldingInfo` unfold_info
786 `setWorkerInfo` worker_info
787 -- NB: we throw away the Rules
788 -- They have already been extracted by findExternalRules
792 ------------ Worker --------------
793 tidyWorker :: TidyEnv -> Bool -> WorkerInfo -> WorkerInfo
794 tidyWorker _tidy_env _show_unfold NoWorker
796 tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity)
797 | show_unfold = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
798 | otherwise = WARN( True, ppr work_id ) NoWorker
799 -- NB: do *not* expose the worker if show_unfold is off,
800 -- because that means this thing is a loop breaker or
801 -- marked NOINLINE or something like that
802 -- This is important: if you expose the worker for a loop-breaker
803 -- then you can make the simplifier go into an infinite loop, because
804 -- in effect the unfolding is exposed. See Trac #1709
806 -- Mind you, it probably should not be w/w'd in the first place;
810 %************************************************************************
812 \subsection{Figuring out CafInfo for an expression}
814 %************************************************************************
816 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
817 We mark such things as `MayHaveCafRefs' because this information is
818 used to decide whether a particular closure needs to be referenced
821 There are two reasons for setting MayHaveCafRefs:
822 a) The RHS is a CAF: a top-level updatable thunk.
823 b) The RHS refers to something that MayHaveCafRefs
825 Possible improvement: In an effort to keep the number of CAFs (and
826 hence the size of the SRTs) down, we could also look at the expression and
827 decide whether it requires a small bounded amount of heap, so we can ignore
828 it as a CAF. In these cases however, we would need to use an additional
829 CAF list to keep track of non-collectable CAFs.
832 hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
833 hasCafRefs this_pkg p arity expr
834 | is_caf || mentions_cafs
836 | otherwise = NoCafRefs
838 mentions_cafs = isFastTrue (cafRefs p expr)
839 is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
841 -- NB. we pass in the arity of the expression, which is expected
842 -- to be calculated by exprArity. This is because exprArity
843 -- knows how much eta expansion is going to be done by
844 -- CorePrep later on, and we don't want to duplicate that
845 -- knowledge in rhsIsStatic below.
847 cafRefs :: VarEnv Id -> Expr a -> FastBool
849 -- imported Ids first:
850 | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id))
851 -- now Ids local to this module:
853 case lookupVarEnv p id of
854 Just id' -> fastBool (mayHaveCafRefs (idCafInfo id'))
855 Nothing -> fastBool False
857 cafRefs _ (Lit _) = fastBool False
858 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
859 cafRefs p (Lam _ e) = cafRefs p e
860 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
861 cafRefs p (Case e _bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
862 cafRefs p (Note _n e) = cafRefs p e
863 cafRefs p (Cast e _co) = cafRefs p e
864 cafRefs _ (Type _) = fastBool False
866 cafRefss :: VarEnv Id -> [Expr a] -> FastBool
867 cafRefss _ [] = fastBool False
868 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
870 fastOr :: FastBool -> (a -> FastBool) -> a -> FastBool
871 -- hack for lazy-or over FastBool.
872 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))