2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section{Tidying up Core}
12 #include "HsVersions.h"
14 import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas, dopt )
16 import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
17 import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars )
18 import CoreLint ( showPass, endPass )
21 import Var ( Id, Var )
22 import Id ( idType, idInfo, idName, isExportedId,
23 mkVanillaId, mkId, isLocalId, omitIfaceSigForId,
24 setIdStrictness, setIdDemandInfo,
26 import IdInfo ( constantIdInfo,
27 specInfo, setSpecInfo,
29 inlinePragInfo, setInlinePragInfo, isNeverInlinePrag,
30 strictnessInfo, setStrictnessInfo, isBottomingStrictness,
31 unfoldingInfo, setUnfoldingInfo,
33 occInfo, isLoopBreaker,
34 workerInfo, setWorkerInfo, WorkerInfo(..)
36 import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
37 localiseName, mkLocalName, isGlobalName
39 import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
40 import Type ( tidyTopType, tidyType, tidyTyVar )
41 import Module ( Module, moduleName )
42 import HscTypes ( PersistentCompilerState( pcs_PRS ), PersistentRenamerState( prsOrig ),
43 OrigNameEnv( origNames ), OrigNameNameEnv
45 import Unique ( Uniquable(..) )
46 import FiniteMap ( lookupFM, addToFM )
47 import Maybes ( maybeToBool, orElse )
48 import ErrUtils ( showPass )
49 import SrcLoc ( noSrcLoc )
50 import UniqFM ( mapUFM )
52 import List ( partition )
53 import Util ( mapAccumL )
58 %************************************************************************
60 \subsection{What goes on}
62 %************************************************************************
68 Step 1: Figure out external Ids
69 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
70 First we figure out which Ids are "external" Ids. An
71 "external" Id is one that is visible from outside the compilation
73 a) the user exported ones
74 b) ones mentioned in the unfoldings, workers,
75 or rules of externally-visible ones
76 This exercise takes a sweep of the bindings bottom to top. Actually,
77 in Step 2 we're also going to need to know which Ids should be
78 exported with their unfoldings, so we produce not an IdSet but an
83 Step 2: Tidy the program
84 ~~~~~~~~~~~~~~~~~~~~~~~~
85 Next we traverse the bindings top to bottom. For each top-level
88 - Make all external Ids have Global names and vice versa
89 This is used by the code generator to decide whether
90 to make the label externally visible
92 - Give external ids a "tidy" occurrence name. This means
93 we can print them in interface files without confusing
94 "x" (unique 5) with "x" (unique 10).
96 - Give external Ids the same Unique as they had before
97 if the name is in the renamer's name cache
99 - Give the Id its final IdInfo; in ptic,
100 * Its flavour becomes ConstantId, reflecting the fact that
101 from now on we regard it as a constant, not local, Id
102 * its unfolding, if it should have one
104 Finally, substitute these new top-level binders consistently
105 throughout, including in unfoldings. We also tidy binders in
106 RHSs, so that they print nicely in interfaces.
109 tidyCorePgm :: DynFlags -> Module
110 -> PersistentCompilerState
111 -> [CoreBind] -> [IdCoreRule]
112 -> IO (PersistentCompilerState, [CoreBind], [IdCoreRule])
113 tidyCorePgm dflags mod pcs binds_in orphans_in
114 = do { showPass dflags "Tidy Core"
116 ; let ext_ids = findExternalSet binds_in orphans_in
118 ; let ((orig_env', occ_env, subst_env), binds_out)
119 = mapAccumL (tidyTopBind mod ext_ids) init_tidy_env binds_in
121 ; let orphans_out = tidyIdRules (occ_env,subst_env) orphans_in
123 ; let pcs' = pcs { pcs_PRS = prs { prsOrig = orig { origNames = orig_env' }}}
125 ; endPass dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags ||
126 dopt Opt_D_verbose_core2core dflags)
129 ; return (pcs', binds_out, orphans_out)
132 -- We also make sure to avoid any exported binders. Consider
133 -- f{-u1-} = 1 -- Local decl
135 -- f{-u2-} = 2 -- Exported decl
137 -- The second exported decl must 'get' the name 'f', so we
138 -- have to put 'f' in the avoids list before we get to the first
139 -- decl. tidyTopId then does a no-op on exported binders.
142 orig_env = origNames orig
144 init_tidy_env = (orig_env, initTidyOccEnv avoids, emptyVarEnv)
145 avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
146 isGlobalName (idName bndr)]
150 %************************************************************************
152 \subsection{Step 1: finding externals}
154 %************************************************************************
157 findExternalSet :: [CoreBind] -> [IdCoreRule]
158 -> IdEnv Bool -- True <=> show unfolding
159 -- Step 1 from the notes above
160 findExternalSet binds orphan_rules
161 = foldr find init_needed binds
163 orphan_rule_ids :: IdSet
164 orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isIdAndLocal rule
165 | (_, rule) <- orphan_rules]
166 init_needed :: IdEnv Bool
167 init_needed = mapUFM (\_ -> False) orphan_rule_ids
168 -- The mapUFM is a bit cheesy. It is a cheap way
169 -- to turn the set of orphan_rule_ids, which we use to initialise
170 -- the sweep, into a mapping saying 'don't expose unfolding'
171 -- (When we come to the binding site we may change our mind, of course.)
173 find (NonRec id rhs) needed
174 | need_id needed id = addExternal (id,rhs) needed
176 find (Rec prs) needed = find_prs prs needed
178 -- For a recursive group we have to look for a fixed point
180 | null needed_prs = needed
181 | otherwise = find_prs other_prs new_needed
183 (needed_prs, other_prs) = partition (need_pr needed) prs
184 new_needed = foldr addExternal needed needed_prs
186 -- The 'needed' set contains the Ids that are needed by earlier
187 -- interface file emissions. If the Id isn't in this set, and isn't
188 -- exported, there's no need to emit anything
189 need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
190 need_pr needed_set (id,rhs) = need_id needed_set id
192 isIdAndLocal id = isId id && isLocalId id
194 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
195 -- The Id is needed; extend the needed set
196 -- with it and its dependents (free vars etc)
197 addExternal (id,rhs) needed
198 = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
201 add_occ id needed = extendVarEnv needed id False
202 -- "False" because we don't know we need the Id's unfolding
203 -- We'll override it later when we find the binding site
205 new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
206 | otherwise = worker_ids `unionVarSet`
207 unfold_ids `unionVarSet`
211 dont_inline = isNeverInlinePrag (inlinePragInfo idinfo)
212 loop_breaker = isLoopBreaker (occInfo idinfo)
213 bottoming_fn = isBottomingStrictness (strictnessInfo idinfo)
214 spec_ids = rulesRhsFreeVars (specInfo idinfo)
215 worker_info = workerInfo idinfo
217 -- Stuff to do with the Id's unfolding
218 -- The simplifier has put an up-to-date unfolding
219 -- in the IdInfo, but the RHS will do just as well
220 unfolding = unfoldingInfo idinfo
221 rhs_is_small = not (neverUnfold unfolding)
223 -- We leave the unfolding there even if there is a worker
224 -- In GHCI the unfolding is used by importers
225 -- When writing an interface file, we omit the unfolding
226 -- if there is a worker
227 show_unfold = not bottoming_fn && -- Not necessary
230 rhs_is_small && -- Small enough
231 okToUnfoldInHiFile rhs -- No casms etc
233 unfold_ids | show_unfold = exprSomeFreeVars isIdAndLocal rhs
234 | otherwise = emptyVarSet
236 worker_ids = case worker_info of
237 HasWorker work_id _ -> unitVarSet work_id
238 otherwise -> emptyVarSet
242 %************************************************************************
244 \subsection{Step 2: top-level tidying}
246 %************************************************************************
250 type TopTidyEnv = (OrigNameNameEnv, TidyOccEnv, VarEnv Var)
252 -- TopTidyEnv: when tidying we need to know
253 -- * orig_env: Any pre-ordained Names. These may have arisen because the
254 -- renamer read in an interface file mentioning M.$wf, say,
255 -- and assigned it unique r77. If, on this compilation, we've
256 -- invented an Id whose name is $wf (but with a different unique)
257 -- we want to rename it to have unique r77, so that we can do easy
258 -- comparisons with stuff from the interface file
260 -- * occ_env: The TidyOccEnv, which tells us which local occurrences are 'used'
262 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
267 tidyTopBind :: Module
268 -> IdEnv Bool -- Domain = Ids that should be exernal
269 -- True <=> their unfolding is external too
270 -> TopTidyEnv -> CoreBind
271 -> (TopTidyEnv, CoreBind)
273 tidyTopBind mod ext_ids env (NonRec bndr rhs)
274 = (env', NonRec bndr' rhs')
276 rhs' = tidyTopRhs env rhs
277 (env', bndr') = tidyTopBinder mod ext_ids env rhs' env bndr
279 tidyTopBind mod ext_ids env (Rec prs)
280 = (final_env, Rec prs')
282 (final_env, prs') = mapAccumL do_one env prs
283 do_one env (bndr,rhs) = (env', (bndr', rhs'))
285 rhs' = tidyTopRhs final_env rhs
286 (env', bndr') = tidyTopBinder mod ext_ids final_env
289 tidyTopRhs :: TopTidyEnv -> CoreExpr -> CoreExpr
290 -- Just an impedence matcher
291 tidyTopRhs (_, occ_env, subst_env) rhs = tidyExpr (occ_env, subst_env) rhs
293 tidyTopBinder :: Module -> IdEnv Bool
294 -> TopTidyEnv -> CoreExpr
295 -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
296 tidyTopBinder mod ext_ids env_idinfo rhs env@(orig_env, occ_env, subst_env) id
297 | omitIfaceSigForId id -- Don't mess with constructors,
298 = (env, id) -- record selectors, and the like
301 -- This function is the heart of Step 2
302 -- The second env is the one to use for the IdInfo
303 -- It's necessary because when we are dealing with a recursive
304 -- group, a variable late in the group might be mentioned
305 -- in the IdInfo of one early in the group
307 -- The rhs is already tidied
309 = ((orig_env', occ_env', subst_env'), id')
311 (orig_env', occ_env', name') = tidyTopName mod orig_env occ_env
314 ty' = tidyTopType (idType id)
315 idinfo' = tidyIdInfo env_idinfo is_external unfold_info id
316 id' = mkId name' ty' idinfo'
317 subst_env' = extendVarEnv subst_env id id'
319 maybe_external = lookupVarEnv ext_ids id
320 is_external = maybeToBool maybe_external
322 -- Expose an unfolding if ext_ids tells us to
323 show_unfold = maybe_external `orElse` False
324 unfold_info | show_unfold = mkTopUnfolding rhs
325 | otherwise = noUnfolding
327 tidyIdInfo (_, occ_env, subst_env) is_external unfold_info id
328 | opt_OmitInterfacePragmas || not is_external
329 -- No IdInfo if the Id isn't
333 = constantIdInfo `setCprInfo` cprInfo core_idinfo
334 `setStrictnessInfo` strictnessInfo core_idinfo
335 `setInlinePragInfo` inlinePragInfo core_idinfo
336 `setUnfoldingInfo` unfold_info
337 `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo)
338 `setSpecInfo` tidyRules tidy_env (specInfo core_idinfo)
340 tidy_env = (occ_env, subst_env)
341 core_idinfo = idInfo id
343 tidyTopName mod orig_env occ_env external name
344 | global && internal = (orig_env, occ_env, localiseName name)
345 | local && internal = (orig_env, occ_env', setNameOcc name occ')
346 | global && external = (orig_env, occ_env, name)
347 | local && external = globalise
349 -- If we want to globalise a currently-local name, check
350 -- whether we have already assigned a unique for it.
351 -- If so, use it; if not, extend the table
352 globalise = case lookupFM orig_env key of
353 Just orig -> (orig_env, occ_env', orig)
354 Nothing -> (addToFM orig_env key global_name, occ_env', global_name)
356 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
357 key = (moduleName mod, occ')
358 global_name = globaliseName (setNameOcc name occ') mod
359 global = isGlobalName name
361 internal = not external
363 tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
364 tidyIdRules env rules
365 = [ (tidyVarOcc env fn, tidyRule env rule) | (fn,rule) <- rules ]
368 tidyWorker tidy_env (HasWorker work_id wrap_arity)
369 = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
370 tidyWorker tidy_env NoWorker
373 tidyRules :: TidyEnv -> CoreRules -> CoreRules
374 tidyRules env (Rules rules fvs)
375 = Rules (map (tidyRule env) rules)
376 (foldVarSet tidy_set_elem emptyVarSet fvs)
378 tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
380 tidyRule :: TidyEnv -> CoreRule -> CoreRule
381 tidyRule env rule@(BuiltinRule _) = rule
382 tidyRule env (Rule name vars tpl_args rhs)
383 = (Rule name vars' (map (tidyExpr env') tpl_args) (tidyExpr env' rhs))
385 (env', vars') = tidyBndrs env vars
389 %************************************************************************
391 \subsection{Step 2: inner tidying
393 %************************************************************************
398 -> (TidyEnv, CoreBind)
399 tidyBind env (NonRec bndr rhs)
401 (env', bndr') = tidyBndr env bndr
402 rhs' = tidyExpr env' rhs
403 -- We use env' when tidying the RHS even though it's not
404 -- strictly necessary; it makes the tidied code pretty
405 -- hard to read if we don't!
407 (env', NonRec bndr' rhs')
409 tidyBind env (Rec prs)
410 = (final_env, Rec prs')
412 (final_env, prs') = mapAccumL do_one env prs
413 do_one env (bndr,rhs) = (env', (bndr', rhs'))
415 (env', bndr') = tidyBndr env bndr
416 rhs' = tidyExpr final_env rhs
418 tidyExpr env (Type ty) = Type (tidyType env ty)
419 tidyExpr env (Lit lit) = Lit lit
420 tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
421 tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
423 tidyExpr env (Let b e) = Let b' (tidyExpr env' e)
425 (env', b') = tidyBind env b
427 tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
429 (env', b') = tidyBndr env b
431 tidyExpr env (Var v) = Var (tidyVarOcc env v)
433 tidyExpr env (Lam b e) = Lam b' (tidyExpr env' e)
435 (env', b') = tidyBndr env b
437 tidyAlt env (con, vs, rhs) = (con, vs', tidyExpr env' rhs)
439 (env', vs') = tidyBndrs env vs
441 tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
443 tidyNote env note = note
447 %************************************************************************
449 \subsection{Tidying up non-top-level binders}
451 %************************************************************************
454 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
458 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
459 tidyBndr env var | isTyVar var = tidyTyVar env var
460 | otherwise = tidyId env var
462 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
463 tidyBndrs env vars = mapAccumL tidyBndr env vars
465 tidyId :: TidyEnv -> Id -> (TidyEnv, Id)
466 tidyId env@(tidy_env, var_env) id
467 = -- Non-top-level variables
469 -- Give the Id a fresh print-name, *and* rename its type
470 -- The SrcLoc isn't important now, though we could extract it from the Id
471 name' = mkLocalName (getUnique id) occ' noSrcLoc
472 (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
473 ty' = tidyType env (idType id)
475 id' = mkVanillaId name' ty'
476 `setIdStrictness` strictnessInfo idinfo
477 `setIdDemandInfo` demandInfo idinfo
478 -- NB: This throws away the IdInfo of the Id, which we
479 -- no longer need. That means we don't need to
480 -- run over it with env, nor renumber it.
482 -- The exception is strictness and demand info, which
483 -- is used to decide whether to use let or case for
484 -- function arguments and let bindings
486 var_env' = extendVarEnv var_env id id'
488 ((tidy_env', var_env'), id')