2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section{Tidying up Core}
8 tidyCorePgm, tidyExpr, tidyCoreExpr,
12 #include "HsVersions.h"
14 import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
16 import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
17 import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars )
18 import PprCore ( pprIdCoreRule )
19 import CoreLint ( showPass, endPass )
22 import Var ( Id, Var )
23 import Id ( idType, idInfo, idName, isExportedId,
24 idSpecialisation, idUnique, isDataConWrapId,
25 mkVanillaGlobal, mkGlobalId, isLocalId,
26 isDataConId, mkUserLocal, isGlobalId, globalIdDetails,
27 idNewDemandInfo, setIdNewDemandInfo, setIdCgInfo,
28 idNewStrictness, setIdNewStrictness
30 import IdInfo {- loads of stuff -}
31 import NewDemand ( isBottomingSig, topSig )
32 import BasicTypes ( isNeverActive )
33 import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
34 localiseName, isGlobalName, setNameUnique
36 import NameEnv ( filterNameEnv )
37 import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
38 import Type ( tidyTopType, tidyType, tidyTyVarBndr )
39 import Module ( Module, moduleName )
40 import HscTypes ( PersistentCompilerState( pcs_PRS ),
41 PersistentRenamerState( prsOrig ),
42 NameSupply( nsNames, nsUniqs ),
43 TypeEnv, extendTypeEnvList,
44 ModDetails(..), TyThing(..)
46 import FiniteMap ( lookupFM, addToFM )
47 import Maybes ( orElse )
48 import ErrUtils ( showPass, dumpIfSet_core )
49 import SrcLoc ( noSrcLoc )
50 import UniqFM ( mapUFM )
51 import UniqSupply ( splitUniqSupply, uniqFromSupply )
52 import List ( partition )
53 import Util ( mapAccumL )
54 import Maybe ( isJust )
60 %************************************************************************
62 \subsection{What goes on}
64 %************************************************************************
70 Step 1: Figure out external Ids
71 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
72 First we figure out which Ids are "external" Ids. An
73 "external" Id is one that is visible from outside the compilation
75 a) the user exported ones
76 b) ones mentioned in the unfoldings, workers,
77 or rules of externally-visible ones
78 This exercise takes a sweep of the bindings bottom to top. Actually,
79 in Step 2 we're also going to need to know which Ids should be
80 exported with their unfoldings, so we produce not an IdSet but an
84 Step 2: Tidy the program
85 ~~~~~~~~~~~~~~~~~~~~~~~~
86 Next we traverse the bindings top to bottom. For each *top-level*
89 1. Make it into a GlobalId
91 2. Give it a system-wide Unique.
92 [Even non-exported things need system-wide Uniques because the
93 byte-code generator builds a single Name->BCO symbol table.]
95 We use the NameSupply kept in the PersistentRenamerState as the
96 source of such system-wide uniques.
98 For external Ids, use the original-name cache in the NameSupply
99 to ensure that the unique assigned is the same as the Id had
100 in any previous compilation run.
102 3. If it's an external Id, make it have a global Name, otherwise
103 make it have a local Name.
104 This is used by the code generator to decide whether
105 to make the label externally visible
107 4. Give external Ids a "tidy" occurrence name. This means
108 we can print them in interface files without confusing
109 "x" (unique 5) with "x" (unique 10).
111 5. Give it its UTTERLY FINAL IdInfo; in ptic,
112 * Its IdDetails becomes VanillaGlobal, reflecting the fact that
113 from now on we regard it as a global, not local, Id
115 * its unfolding, if it should have one
117 * its arity, computed from the number of visible lambdas
119 * its CAF info, computed from what is free in its RHS
122 Finally, substitute these new top-level binders consistently
123 throughout, including in unfoldings. We also tidy binders in
124 RHSs, so that they print nicely in interfaces.
127 tidyCorePgm :: DynFlags -> Module
128 -> PersistentCompilerState
129 -> CgInfoEnv -- Information from the back end,
130 -- to be splatted into the IdInfo
132 -> IO (PersistentCompilerState, ModDetails)
134 tidyCorePgm dflags mod pcs cg_info_env
135 (ModDetails { md_types = env_tc, md_insts = insts_tc,
136 md_binds = binds_in, md_rules = orphans_in })
137 = do { showPass dflags "Tidy Core"
139 ; let ext_ids = findExternalSet binds_in orphans_in
140 ; let ext_rules = findExternalRules binds_in orphans_in ext_ids
142 -- We also make sure to avoid any exported binders. Consider
143 -- f{-u1-} = 1 -- Local decl
145 -- f{-u2-} = 2 -- Exported decl
147 -- The second exported decl must 'get' the name 'f', so we
148 -- have to put 'f' in the avoids list before we get to the first
149 -- decl. tidyTopId then does a no-op on exported binders.
150 ; let prs = pcs_PRS pcs
151 orig_ns = prsOrig prs
153 init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv)
154 avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
155 isGlobalName (idName bndr)]
157 ; let ((orig_ns', occ_env, subst_env), tidy_binds)
158 = mapAccumL (tidyTopBind mod ext_ids)
159 init_tidy_env binds_in
161 ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
163 ; let prs' = prs { prsOrig = orig_ns' }
164 pcs' = pcs { pcs_PRS = prs' }
166 ; let final_ids = [ addCgInfo cg_info_env id
168 , id <- bindersOf bind
169 , isGlobalName (idName id)]
171 -- Dfuns are local Ids that might have
172 -- changed their unique during tidying
173 ; let lookup_dfun_id id = lookupVarEnv subst_env id `orElse`
174 pprPanic "lookup_dfun_id" (ppr id)
177 ; let tidy_type_env = mkFinalTypeEnv env_tc final_ids
178 tidy_dfun_ids = map lookup_dfun_id insts_tc
180 ; let tidy_details = ModDetails { md_types = tidy_type_env,
181 md_rules = tidy_rules,
182 md_insts = tidy_dfun_ids,
183 md_binds = tidy_binds }
185 ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
186 ; dumpIfSet_core dflags Opt_D_dump_simpl
188 (vcat (map pprIdCoreRule tidy_rules))
190 ; return (pcs', tidy_details)
193 addCgInfo :: CgInfoEnv -> Id -> Id
194 -- Pin on the info that comes from the code generator
195 -- This doesn't make its way into the *bindings* that
196 -- go on to the code generator (that might give black holes etc)
197 -- Rather, it's pinned onto the Id in the type environment
198 -- that (a) generates the interface file
199 -- (b) in GHCi goes into subsequent compilations
200 addCgInfo cg_info_env id
201 = id `setIdCgInfo` lookupCgInfo cg_info_env (idName id)
203 tidyCoreExpr :: CoreExpr -> IO CoreExpr
204 tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr)
208 %************************************************************************
210 \subsection{Write a new interface file}
212 %************************************************************************
215 mkFinalTypeEnv :: TypeEnv -- From typechecker
219 mkFinalTypeEnv type_env final_ids
220 = extendTypeEnvList (filterNameEnv keep_it type_env)
223 -- The competed type environment is gotten from
224 -- a) keeping the types and classes
225 -- b) removing all Ids,
226 -- c) adding Ids with correct IdInfo, including unfoldings,
227 -- gotten from the bindings
228 -- From (c) we keep only those Ids with Global names;
229 -- the CoreTidy pass makes sure these are all and only
230 -- the externally-accessible ones
231 -- This truncates the type environment to include only the
232 -- exported Ids and things needed from them, which saves space
234 -- However, we do keep things like constructors, which should not appear
235 -- in interface files, because they are needed by importing modules when
236 -- using the compilation manager
238 -- We keep constructor workers,
239 -- because they won't appear in the bindings from which final_ids are derived!
240 keep_it (AnId id) = isDataConId id -- Remove all Ids except constructor workers
241 keep_it other = True -- Keep all TyCons and Classes
245 findExternalRules :: [CoreBind]
246 -> [IdCoreRule] -- Orphan rules
247 -> IdEnv a -- Ids that are exported, so we need their rules
249 -- The complete rules are gotten by combining
250 -- a) the orphan rules
251 -- b) rules embedded in the top-level Ids
252 findExternalRules binds orphan_rules ext_ids
253 | opt_OmitInterfacePragmas = []
255 = orphan_rules ++ local_rules
257 local_rules = [ (id, rule)
258 | id <- bindersOfBinds binds,
259 id `elemVarEnv` ext_ids,
260 rule <- rulesRules (idSpecialisation id),
261 not (isBuiltinRule rule)
262 -- We can't print builtin rules in interface files
263 -- Since they are built in, an importing module
264 -- will have access to them anyway
268 %************************************************************************
270 \subsection{Step 1: finding externals}
272 %************************************************************************
275 findExternalSet :: [CoreBind] -> [IdCoreRule]
276 -> IdEnv Bool -- In domain => external
277 -- Range = True <=> show unfolding
278 -- Step 1 from the notes above
279 findExternalSet binds orphan_rules
280 = foldr find init_needed binds
282 orphan_rule_ids :: IdSet
283 orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isLocalId rule
284 | (_, rule) <- orphan_rules]
285 init_needed :: IdEnv Bool
286 init_needed = mapUFM (\_ -> False) orphan_rule_ids
287 -- The mapUFM is a bit cheesy. It is a cheap way
288 -- to turn the set of orphan_rule_ids, which we use to initialise
289 -- the sweep, into a mapping saying 'don't expose unfolding'
290 -- (When we come to the binding site we may change our mind, of course.)
292 find (NonRec id rhs) needed
293 | need_id needed id = addExternal (id,rhs) needed
295 find (Rec prs) needed = find_prs prs needed
297 -- For a recursive group we have to look for a fixed point
299 | null needed_prs = needed
300 | otherwise = find_prs other_prs new_needed
302 (needed_prs, other_prs) = partition (need_pr needed) prs
303 new_needed = foldr addExternal needed needed_prs
305 -- The 'needed' set contains the Ids that are needed by earlier
306 -- interface file emissions. If the Id isn't in this set, and isn't
307 -- exported, there's no need to emit anything
308 need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
309 need_pr needed_set (id,rhs) = need_id needed_set id
311 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
312 -- The Id is needed; extend the needed set
313 -- with it and its dependents (free vars etc)
314 addExternal (id,rhs) needed
315 = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
318 add_occ id needed = extendVarEnv needed id False
319 -- "False" because we don't know we need the Id's unfolding
320 -- We'll override it later when we find the binding site
322 new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
323 | otherwise = worker_ids `unionVarSet`
324 unfold_ids `unionVarSet`
328 dont_inline = isNeverActive (inlinePragInfo idinfo)
329 loop_breaker = isLoopBreaker (occInfo idinfo)
330 bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
331 spec_ids = rulesRhsFreeVars (specInfo idinfo)
332 worker_info = workerInfo idinfo
334 -- Stuff to do with the Id's unfolding
335 -- The simplifier has put an up-to-date unfolding
336 -- in the IdInfo, but the RHS will do just as well
337 unfolding = unfoldingInfo idinfo
338 rhs_is_small = not (neverUnfold unfolding)
340 -- We leave the unfolding there even if there is a worker
341 -- In GHCI the unfolding is used by importers
342 -- When writing an interface file, we omit the unfolding
343 -- if there is a worker
344 show_unfold = not bottoming_fn && -- Not necessary
347 rhs_is_small && -- Small enough
348 okToUnfoldInHiFile rhs -- No casms etc
350 unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
351 | otherwise = emptyVarSet
353 worker_ids = case worker_info of
354 HasWorker work_id _ -> unitVarSet work_id
355 otherwise -> emptyVarSet
359 %************************************************************************
361 \subsection{Step 2: top-level tidying}
363 %************************************************************************
367 type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var)
369 -- TopTidyEnv: when tidying we need to know
370 -- * ns: The NameSupply, containing a unique supply and any pre-ordained Names.
371 -- These may have arisen because the
372 -- renamer read in an interface file mentioning M.$wf, say,
373 -- and assigned it unique r77. If, on this compilation, we've
374 -- invented an Id whose name is $wf (but with a different unique)
375 -- we want to rename it to have unique r77, so that we can do easy
376 -- comparisons with stuff from the interface file
378 -- * occ_env: The TidyOccEnv, which tells us which local occurrences
381 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
386 tidyTopBind :: Module
387 -> IdEnv Bool -- Domain = Ids that should be external
388 -- True <=> their unfolding is external too
389 -> TopTidyEnv -> CoreBind
390 -> (TopTidyEnv, CoreBind)
392 tidyTopBind mod ext_ids top_tidy_env (NonRec bndr rhs)
393 = ((orig,occ,subst) , NonRec bndr' rhs')
395 ((orig,occ,subst), bndr')
396 = tidyTopBinder mod ext_ids rec_tidy_env rhs' top_tidy_env bndr
397 rec_tidy_env = (occ,subst)
398 rhs' = tidyExpr rec_tidy_env rhs
400 tidyTopBind mod ext_ids top_tidy_env (Rec prs)
401 = (final_env, Rec prs')
403 (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
404 rec_tidy_env = (occ,subst)
406 do_one top_tidy_env (bndr,rhs)
407 = ((orig,occ,subst), (bndr',rhs'))
409 ((orig,occ,subst), bndr')
410 = tidyTopBinder mod ext_ids
411 rec_tidy_env rhs' top_tidy_env bndr
413 rhs' = tidyExpr rec_tidy_env rhs
415 tidyTopBinder :: Module -> IdEnv Bool
416 -> TidyEnv -> CoreExpr
417 -- The TidyEnv is used to tidy the IdInfo
418 -- The expr is the already-tided RHS
419 -- Both are knot-tied: don't look at them!
420 -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
421 -- NB: tidyTopBinder doesn't affect the unique supply
423 tidyTopBinder mod ext_ids tidy_env rhs
424 env@(ns2, occ_env2, subst_env2) id
426 | isDataConWrapId id -- Don't tidy constructor wrappers
427 = (env, id) -- The Id is stored in the TyCon, so it would be bad
428 -- if anything changed
430 -- HACK ALERT: we *do* tidy record selectors. Reason: they mention error
431 -- messages, which may be floated out:
432 -- x_field pt = case pt of
434 -- Pol _ _ -> error "buggle wuggle"
435 -- The error message will be floated out so we'll get
436 -- lvl5 = error "buggle wuggle"
437 -- x_field pt = case pt of
441 -- When this happens, it's vital that the Id exposed to importing modules
442 -- (by ghci) mentions lvl5 in its unfolding, not the un-tidied version.
444 -- What about the Id in the TyCon? It probably shouldn't be in the TyCon at
445 -- all, but in any case it will have the error message inline so it won't matter.
449 -- This function is the heart of Step 2
450 -- The second env is the one to use for the IdInfo
451 -- It's necessary because when we are dealing with a recursive
452 -- group, a variable late in the group might be mentioned
453 -- in the IdInfo of one early in the group
455 -- The rhs is already tidied
457 = ((orig_env', occ_env', subst_env'), id')
459 (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2
462 ty' = tidyTopType (idType id)
463 idinfo' = tidyIdInfo tidy_env is_external unfold_info id
465 id' | isGlobalId id = mkGlobalId (globalIdDetails id) name' ty' idinfo'
466 | otherwise = mkVanillaGlobal name' ty' idinfo'
467 -- The test ensures that record selectors (which must be tidied; see above)
468 -- retain their details. If it's forgotten, importing modules get confused.
470 subst_env' = extendVarEnv subst_env2 id id'
472 maybe_external = lookupVarEnv ext_ids id
473 is_external = isJust maybe_external
475 -- Expose an unfolding if ext_ids tells us to
476 show_unfold = maybe_external `orElse` False
477 unfold_info | show_unfold = mkTopUnfolding rhs
478 | otherwise = noUnfolding
481 tidyIdInfo tidy_env is_external unfold_info id
482 | opt_OmitInterfacePragmas || not is_external
483 -- No IdInfo if the Id isn't external, or if we don't have -O
485 `setArityInfo` arityInfo core_idinfo
486 `setNewStrictnessInfo` newStrictnessInfo core_idinfo
487 -- Keep strictness and arity; both are used by CorePrep
491 `setArityInfo` arityInfo core_idinfo
492 `setNewStrictnessInfo` newStrictnessInfo core_idinfo
493 `setInlinePragInfo` inlinePragInfo core_idinfo
494 `setUnfoldingInfo` unfold_info
495 `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo)
496 -- NB: we throw away the Rules
497 -- They have already been extracted by findExternalRules
499 core_idinfo = idInfo id
502 -- This is where we set names to local/global based on whether they really are
503 -- externally visible (see comment at the top of this module). If the name
504 -- was previously local, we have to give it a unique occurrence name if
505 -- we intend to globalise it.
506 tidyTopName mod ns occ_env external name
507 | global && internal = (ns, occ_env, localiseName name)
509 | global && external = (ns, occ_env, name)
510 -- Global names are assumed to have been allocated by the renamer,
511 -- so they already have the "right" unique
512 -- And it's a system-wide unique too
514 | local && internal = (ns { nsUniqs = us2 }, occ_env', unique_name)
515 -- Even local, internal names must get a unique occurrence, because
516 -- if we do -split-objs we globalise the name later, in the code generator
518 -- Similarly, we must make sure it has a system-wide Unique, because
519 -- the byte-code generator builds a system-wide Name->BCO symbol table
521 | local && external = case lookupFM ns_names key of
522 Just orig -> (ns, occ_env', orig)
523 Nothing -> (ns { nsUniqs = us2, nsNames = ns_names' }, occ_env', global_name)
524 -- If we want to globalise a currently-local name, check
525 -- whether we have already assigned a unique for it.
526 -- If so, use it; if not, extend the table
529 global = isGlobalName name
531 internal = not external
533 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
534 key = (moduleName mod, occ')
535 ns_names = nsNames ns
536 ns_uniqs = nsUniqs ns
537 (us1, us2) = splitUniqSupply ns_uniqs
538 unique_name = setNameUnique (setNameOcc name occ') (uniqFromSupply us1)
539 global_name = globaliseName unique_name mod
540 ns_names' = addToFM ns_names key global_name
543 ------------ Worker --------------
544 tidyWorker tidy_env (HasWorker work_id wrap_arity)
545 = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
546 tidyWorker tidy_env other
549 ------------ Rules --------------
550 tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
551 tidyIdRules env [] = []
552 tidyIdRules env ((fn,rule) : rules)
553 = tidyRule env rule =: \ rule ->
554 tidyIdRules env rules =: \ rules ->
555 ((tidyVarOcc env fn, rule) : rules)
557 tidyRule :: TidyEnv -> CoreRule -> CoreRule
558 tidyRule env rule@(BuiltinRule _ _) = rule
559 tidyRule env (Rule name act vars tpl_args rhs)
560 = tidyBndrs env vars =: \ (env', vars) ->
561 map (tidyExpr env') tpl_args =: \ tpl_args ->
562 (Rule name act vars tpl_args (tidyExpr env' rhs))
565 %************************************************************************
567 \subsection{Step 2: inner tidying
569 %************************************************************************
574 -> (TidyEnv, CoreBind)
576 tidyBind env (NonRec bndr rhs)
577 = tidyLetBndr env (bndr,rhs) =: \ (env', bndr') ->
578 (env', NonRec bndr' (tidyExpr env' rhs))
580 tidyBind env (Rec prs)
581 = mapAccumL tidyLetBndr env prs =: \ (env', bndrs') ->
582 map (tidyExpr env') (map snd prs) =: \ rhss' ->
583 (env', Rec (zip bndrs' rhss'))
586 tidyExpr env (Var v) = Var (tidyVarOcc env v)
587 tidyExpr env (Type ty) = Type (tidyType env ty)
588 tidyExpr env (Lit lit) = Lit lit
589 tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
590 tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
592 tidyExpr env (Let b e)
593 = tidyBind env b =: \ (env', b') ->
594 Let b' (tidyExpr env' e)
596 tidyExpr env (Case e b alts)
597 = tidyBndr env b =: \ (env', b) ->
598 Case (tidyExpr env e) b (map (tidyAlt env') alts)
600 tidyExpr env (Lam b e)
601 = tidyBndr env b =: \ (env', b) ->
602 Lam b (tidyExpr env' e)
605 tidyAlt env (con, vs, rhs)
606 = tidyBndrs env vs =: \ (env', vs) ->
607 (con, vs, tidyExpr env' rhs)
609 tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
610 tidyNote env note = note
614 %************************************************************************
616 \subsection{Tidying up non-top-level binders}
618 %************************************************************************
621 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
625 -- tidyBndr is used for lambda and case binders
626 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
628 | isTyVar var = tidyTyVarBndr env var
629 | otherwise = tidyIdBndr env var
631 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
632 tidyBndrs env vars = mapAccumL tidyBndr env vars
634 tidyLetBndr :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var)
635 -- Used for local (non-top-level) let(rec)s
636 tidyLetBndr env (id,rhs)
637 = ((tidy_env,new_var_env), final_id)
639 ((tidy_env,var_env), new_id) = tidyIdBndr env id
641 -- We need to keep around any interesting strictness and demand info
642 -- because later on we may need to use it when converting to A-normal form.
644 -- f (g x), where f is strict in its argument, will be converted
645 -- into case (g x) of z -> f z by CorePrep, but only if f still
646 -- has its strictness info.
648 -- Similarly for the demand info - on a let binder, this tells
649 -- CorePrep to turn the let into a case.
650 final_id = new_id `setIdNewDemandInfo` idNewDemandInfo id
651 `setIdNewStrictness` idNewStrictness id
653 -- Override the env we get back from tidyId with the new IdInfo
654 -- so it gets propagated to the usage sites.
655 new_var_env = extendVarEnv var_env id final_id
657 tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
658 tidyIdBndr env@(tidy_env, var_env) id
659 = -- Non-top-level variables
661 -- Give the Id a fresh print-name, *and* rename its type
662 -- The SrcLoc isn't important now,
663 -- though we could extract it from the Id
665 -- All local Ids now have the same IdInfo, which should save some
667 (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
668 ty' = tidyType env (idType id)
669 id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc
670 var_env' = extendVarEnv var_env id id'
672 ((tidy_env', var_env'), id')