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 )
16 import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
17 import CoreUtils ( exprArity, exprIsBottom )
18 import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars )
19 import CoreLint ( showPass, endPass )
22 import Var ( Id, Var )
23 import Id ( idType, idInfo, idName, isExportedId,
24 idCafInfo, mkId, isLocalId, omitIfaceSigForId,
25 idFlavour, modifyIdInfo
27 import IdInfo {- loads of stuff -}
28 import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
29 localiseName, mkLocalName, isGlobalName
31 import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
32 import Type ( tidyTopType, tidyType, tidyTyVar )
33 import Module ( Module, moduleName )
34 import PrimOp ( PrimOp(..), setCCallUnique )
35 import HscTypes ( PersistentCompilerState( pcs_PRS ),
36 PersistentRenamerState( prsOrig ),
37 OrigNameEnv( origNames ), OrigNameNameEnv
40 import FiniteMap ( lookupFM, addToFM )
41 import Maybes ( maybeToBool, orElse )
42 import ErrUtils ( showPass )
43 import SrcLoc ( noSrcLoc )
44 import UniqFM ( mapUFM )
47 import List ( partition )
48 import Util ( mapAccumL )
53 %************************************************************************
55 \subsection{What goes on}
57 %************************************************************************
63 Step 1: Figure out external Ids
64 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
65 First we figure out which Ids are "external" Ids. An
66 "external" Id is one that is visible from outside the compilation
68 a) the user exported ones
69 b) ones mentioned in the unfoldings, workers,
70 or rules of externally-visible ones
71 This exercise takes a sweep of the bindings bottom to top. Actually,
72 in Step 2 we're also going to need to know which Ids should be
73 exported with their unfoldings, so we produce not an IdSet but an
77 Step 2: Tidy the program
78 ~~~~~~~~~~~~~~~~~~~~~~~~
79 Next we traverse the bindings top to bottom. For each top-level
82 - Make all external Ids have Global names and vice versa
83 This is used by the code generator to decide whether
84 to make the label externally visible
86 - Give external ids a "tidy" occurrence name. This means
87 we can print them in interface files without confusing
88 "x" (unique 5) with "x" (unique 10).
90 - Give external Ids the same Unique as they had before
91 if the name is in the renamer's name cache
93 - Clone all local Ids. This means that Tidy Core has the property
94 that all Ids are unique, rather than the weaker guarantee of
95 no clashes which the simplifier provides.
97 - Give the Id its final IdInfo; in ptic,
98 * Its flavour becomes ConstantId, reflecting the fact that
99 from now on we regard it as a constant, not local, Id
100 * its unfolding, if it should have one
102 Finally, substitute these new top-level binders consistently
103 throughout, including in unfoldings. We also tidy binders in
104 RHSs, so that they print nicely in interfaces.
107 tidyCorePgm :: DynFlags -> Module
108 -> PersistentCompilerState
109 -> [CoreBind] -> [IdCoreRule]
110 -> IO (PersistentCompilerState, [CoreBind], [IdCoreRule])
111 tidyCorePgm dflags mod pcs binds_in orphans_in
112 = do { showPass dflags "Tidy Core"
114 ; let ext_ids = findExternalSet binds_in orphans_in
116 ; us <- mkSplitUniqSupply 't' -- for "tidy"
118 ; let ((us1, orig_env', occ_env, subst_env), binds_out)
119 = mapAccumL (tidyTopBind mod ext_ids)
120 (init_tidy_env us) binds_in
122 ; let (orphans_out, _)
123 = initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in)
125 ; let prs' = prs { prsOrig = orig { origNames = orig_env' } }
126 pcs' = pcs { pcs_PRS = prs' }
128 ; endPass dflags "Tidy Core" Opt_D_dump_simpl binds_out
130 ; return (pcs', binds_out, orphans_out)
133 -- We also make sure to avoid any exported binders. Consider
134 -- f{-u1-} = 1 -- Local decl
136 -- f{-u2-} = 2 -- Exported decl
138 -- The second exported decl must 'get' the name 'f', so we
139 -- have to put 'f' in the avoids list before we get to the first
140 -- decl. tidyTopId then does a no-op on exported binders.
143 orig_env = origNames orig
145 init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv)
146 avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
147 isGlobalName (idName bndr)]
151 %************************************************************************
153 \subsection{Step 1: finding externals}
155 %************************************************************************
158 findExternalSet :: [CoreBind] -> [IdCoreRule]
159 -> IdEnv Bool -- True <=> show unfolding
160 -- Step 1 from the notes above
161 findExternalSet binds orphan_rules
162 = foldr find init_needed binds
164 orphan_rule_ids :: IdSet
165 orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isIdAndLocal rule
166 | (_, rule) <- orphan_rules]
167 init_needed :: IdEnv Bool
168 init_needed = mapUFM (\_ -> False) orphan_rule_ids
169 -- The mapUFM is a bit cheesy. It is a cheap way
170 -- to turn the set of orphan_rule_ids, which we use to initialise
171 -- the sweep, into a mapping saying 'don't expose unfolding'
172 -- (When we come to the binding site we may change our mind, of course.)
174 find (NonRec id rhs) needed
175 | need_id needed id = addExternal (id,rhs) needed
177 find (Rec prs) needed = find_prs prs needed
179 -- For a recursive group we have to look for a fixed point
181 | null needed_prs = needed
182 | otherwise = find_prs other_prs new_needed
184 (needed_prs, other_prs) = partition (need_pr needed) prs
185 new_needed = foldr addExternal needed needed_prs
187 -- The 'needed' set contains the Ids that are needed by earlier
188 -- interface file emissions. If the Id isn't in this set, and isn't
189 -- exported, there's no need to emit anything
190 need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
191 need_pr needed_set (id,rhs) = need_id needed_set id
193 isIdAndLocal id = isId id && isLocalId id
195 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
196 -- The Id is needed; extend the needed set
197 -- with it and its dependents (free vars etc)
198 addExternal (id,rhs) needed
199 = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
202 add_occ id needed = extendVarEnv needed id False
203 -- "False" because we don't know we need the Id's unfolding
204 -- We'll override it later when we find the binding site
206 new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
207 | otherwise = worker_ids `unionVarSet`
208 unfold_ids `unionVarSet`
212 dont_inline = isNeverInlinePrag (inlinePragInfo idinfo)
213 loop_breaker = isLoopBreaker (occInfo idinfo)
214 bottoming_fn = isBottomingStrictness (strictnessInfo idinfo)
215 spec_ids = rulesRhsFreeVars (specInfo idinfo)
216 worker_info = workerInfo idinfo
218 -- Stuff to do with the Id's unfolding
219 -- The simplifier has put an up-to-date unfolding
220 -- in the IdInfo, but the RHS will do just as well
221 unfolding = unfoldingInfo idinfo
222 rhs_is_small = not (neverUnfold unfolding)
224 -- We leave the unfolding there even if there is a worker
225 -- In GHCI the unfolding is used by importers
226 -- When writing an interface file, we omit the unfolding
227 -- if there is a worker
228 show_unfold = not bottoming_fn && -- Not necessary
231 rhs_is_small && -- Small enough
232 okToUnfoldInHiFile rhs -- No casms etc
234 unfold_ids | show_unfold = exprSomeFreeVars isIdAndLocal rhs
235 | otherwise = emptyVarSet
237 worker_ids = case worker_info of
238 HasWorker work_id _ -> unitVarSet work_id
239 otherwise -> emptyVarSet
243 %************************************************************************
245 \subsection{Step 2: top-level tidying}
247 %************************************************************************
251 type TopTidyEnv = (UniqSupply, OrigNameNameEnv, TidyOccEnv, VarEnv Var)
253 -- TopTidyEnv: when tidying we need to know
254 -- * orig_env: Any pre-ordained Names. These may have arisen because the
255 -- renamer read in an interface file mentioning M.$wf, say,
256 -- and assigned it unique r77. If, on this compilation, we've
257 -- invented an Id whose name is $wf (but with a different unique)
258 -- we want to rename it to have unique r77, so that we can do easy
259 -- comparisons with stuff from the interface file
261 -- * occ_env: The TidyOccEnv, which tells us which local occurrences
264 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
266 -- * uniqsuppy: so we can clone any Ids with non-preordained names.
272 tidyTopBind :: Module
273 -> IdEnv Bool -- Domain = Ids that should be external
274 -- True <=> their unfolding is external too
275 -> TopTidyEnv -> CoreBind
276 -> (TopTidyEnv, CoreBind)
278 tidyTopBind mod ext_ids env (NonRec bndr rhs)
279 = ((us2,orig,occ,subst) , NonRec bndr' rhs')
281 ((us1,orig,occ,subst), bndr')
282 = tidyTopBinder mod ext_ids tidy_env rhs' caf_info env bndr
283 tidy_env = (occ,subst)
284 caf_info = hasCafRefs (const True) rhs'
285 (rhs',us2) = initUs us1 (tidyExpr tidy_env rhs)
287 tidyTopBind mod ext_ids env (Rec prs)
288 = (final_env, Rec prs')
290 (final_env@(_,_,occ,subst), prs') = mapAccumL do_one env prs
291 final_tidy_env = (occ,subst)
293 do_one env (bndr,rhs)
294 = ((us',orig,occ,subst), (bndr',rhs'))
296 ((us,orig,occ,subst), bndr')
297 = tidyTopBinder mod ext_ids final_tidy_env rhs' caf_info env bndr
298 (rhs', us') = initUs us (tidyExpr final_tidy_env rhs)
300 -- the CafInfo for a recursive group says whether *any* rhs in
301 -- the group may refer indirectly to a CAF (because then, they all do).
302 (bndrs, rhss) = unzip prs'
303 caf_info = hasCafRefss pred rhss
304 pred v = v `notElem` bndrs
307 tidyTopBinder :: Module -> IdEnv Bool
308 -> TidyEnv -> CoreExpr -> CafInfo
309 -- The TidyEnv is used to tidy the IdInfo
310 -- The expr is the already-tided RHS
311 -- Both are knot-tied: don't look at them!
312 -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
314 tidyTopBinder mod ext_ids tidy_env rhs caf_info
315 env@(us, orig_env2, occ_env2, subst_env2) id
317 | omitIfaceSigForId id -- Don't mess with constructors,
318 = (env, id) -- record selectors, and the like
321 -- This function is the heart of Step 2
322 -- The second env is the one to use for the IdInfo
323 -- It's necessary because when we are dealing with a recursive
324 -- group, a variable late in the group might be mentioned
325 -- in the IdInfo of one early in the group
327 -- The rhs is already tidied
329 = ((us_r, orig_env', occ_env', subst_env'), id')
331 (us_l, us_r) = splitUniqSupply us
333 (orig_env', occ_env', name') = tidyTopName mod orig_env2 occ_env2
336 ty' = tidyTopType (idType id)
337 idinfo' = tidyIdInfo us_l tidy_env
338 is_external unfold_info arity_info caf_info id
340 id' = mkId name' ty' idinfo'
341 subst_env' = extendVarEnv subst_env2 id id'
343 maybe_external = lookupVarEnv ext_ids id
344 is_external = maybeToBool maybe_external
346 -- Expose an unfolding if ext_ids tells us to
347 show_unfold = maybe_external `orElse` False
348 unfold_info | show_unfold = mkTopUnfolding rhs
349 | otherwise = noUnfolding
351 arity_info = exprArity rhs
354 tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
355 | opt_OmitInterfacePragmas || not is_external
356 -- No IdInfo if the Id isn't external, or if we don't have -O
357 = mkIdInfo new_flavour
358 `setStrictnessInfo` strictnessInfo core_idinfo
359 `setArityInfo` ArityExactly arity_info
360 `setCafInfo` caf_info
361 -- Keep strictness, arity and CAF info; it's used by the code generator
364 = let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
367 `setCprInfo` cprInfo core_idinfo
368 `setStrictnessInfo` strictnessInfo core_idinfo
369 `setInlinePragInfo` inlinePragInfo core_idinfo
370 `setUnfoldingInfo` unfold_info
371 `setWorkerInfo` tidyWorker tidy_env arity_info (workerInfo core_idinfo)
373 `setArityInfo` ArityExactly arity_info
374 `setCafInfo` caf_info
375 -- this is the final IdInfo, it must agree with the
376 -- code finally generated (i.e. NO more transformations
379 core_idinfo = idInfo id
381 -- A DFunId must stay a DFunId, so that we can gather the
382 -- DFunIds up later. Other local things become ConstantIds.
383 new_flavour = case flavourInfo core_idinfo of
384 VanillaId -> ConstantId
385 ExportedId -> ConstantId
386 ConstantId -> ConstantId -- e.g. Default methods
387 DictFunId -> DictFunId
388 flavour -> pprTrace "tidyIdInfo" (ppr id <+> ppFlavourInfo flavour)
392 -- This is where we set names to local/global based on whether they really are
393 -- externally visible (see comment at the top of this module). If the name
394 -- was previously local, we have to give it a unique occurrence name if
395 -- we intend to globalise it.
396 tidyTopName mod orig_env occ_env external name
397 | global && internal = (orig_env, occ_env, localiseName name)
399 | local && internal = (orig_env, occ_env', setNameOcc name occ')
400 -- Even local, internal names must get a unique occurrence, because
401 -- if we do -split-objs we globalise the name later, n the code generator
403 | global && external = (orig_env, occ_env, name)
404 -- Global names are assumed to have been allocated by the renamer,
405 -- so they already have the "right" unique
407 | local && external = case lookupFM orig_env key of
408 Just orig -> (orig_env, occ_env', orig)
409 Nothing -> (addToFM orig_env key global_name, occ_env', global_name)
410 -- If we want to globalise a currently-local name, check
411 -- whether we have already assigned a unique for it.
412 -- If so, use it; if not, extend the table
415 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
416 key = (moduleName mod, occ')
417 global_name = globaliseName (setNameOcc name occ') mod
418 global = isGlobalName name
420 internal = not external
422 ------------ Worker --------------
423 -- We only treat a function as having a worker if
424 -- the exported arity (which is now the number of visible lambdas)
425 -- is the same as the arity at the moment of the w/w split
426 -- If so, we can safely omit the unfolding inside the wrapper, and
427 -- instead re-generate it from the type/arity/strictness info
428 -- But if the arity has changed, we just take the simple path and
429 -- put the unfolding into the interface file, forgetting the fact
430 -- that it's a wrapper.
432 -- How can this happen? Sometimes we get
433 -- f = coerce t (\x y -> $wf x y)
434 -- at the moment of w/w split; but the eta reducer turns it into
436 -- which is perfectly fine except that the exposed arity so far as
437 -- the code generator is concerned (zero) differs from the arity
438 -- when we did the split (2).
440 -- All this arises because we use 'arity' to mean "exactly how many
441 -- top level lambdas are there" in interface files; but during the
442 -- compilation of this module it means "how many things can I apply
444 tidyWorker tidy_env real_arity (HasWorker work_id wrap_arity)
445 | real_arity == wrap_arity
446 = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
447 tidyWorker tidy_env real_arity other
450 ------------ Rules --------------
451 tidyIdRules :: TidyEnv -> [IdCoreRule] -> UniqSM [IdCoreRule]
452 tidyIdRules env [] = returnUs []
453 tidyIdRules env ((fn,rule) : rules)
454 = tidyRule env rule `thenUs` \ rule ->
455 tidyIdRules env rules `thenUs` \ rules ->
456 returnUs ((tidyVarOcc env fn, rule) : rules)
458 tidyRules :: TidyEnv -> CoreRules -> UniqSM CoreRules
459 tidyRules env (Rules rules fvs)
460 = mapUs (tidyRule env) rules `thenUs` \ rules ->
461 returnUs (Rules rules (foldVarSet tidy_set_elem emptyVarSet fvs))
463 tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
465 tidyRule :: TidyEnv -> CoreRule -> UniqSM CoreRule
466 tidyRule env rule@(BuiltinRule _) = returnUs rule
467 tidyRule env (Rule name vars tpl_args rhs)
468 = tidyBndrs env vars `thenUs` \ (env', vars) ->
469 mapUs (tidyExpr env') tpl_args `thenUs` \ tpl_args ->
470 tidyExpr env' rhs `thenUs` \ rhs ->
471 returnUs (Rule name vars tpl_args rhs)
474 %************************************************************************
476 \subsection{Step 2: inner tidying
478 %************************************************************************
483 -> UniqSM (TidyEnv, CoreBind)
484 tidyBind env (NonRec bndr rhs)
485 = tidyBndrWithRhs env (bndr,rhs) `thenUs` \ (env', bndr') ->
486 tidyExpr env' rhs `thenUs` \ rhs' ->
487 returnUs (env', NonRec bndr' rhs')
489 tidyBind env (Rec prs)
490 = mapAccumLUs tidyBndrWithRhs env prs `thenUs` \ (env', bndrs') ->
491 mapUs (tidyExpr env') (map snd prs) `thenUs` \ rhss' ->
492 returnUs (env', Rec (zip bndrs' rhss'))
495 = fiddleCCall v `thenUs` \ v ->
496 returnUs (Var (tidyVarOcc env v))
498 tidyExpr env (Type ty) = returnUs (Type (tidyType env ty))
499 tidyExpr env (Lit lit) = returnUs (Lit lit)
501 tidyExpr env (App f a)
502 = tidyExpr env f `thenUs` \ f ->
503 tidyExpr env a `thenUs` \ a ->
506 tidyExpr env (Note n e)
507 = tidyExpr env e `thenUs` \ e ->
508 returnUs (Note (tidyNote env n) e)
510 tidyExpr env (Let b e)
511 = tidyBind env b `thenUs` \ (env', b') ->
512 tidyExpr env' e `thenUs` \ e ->
515 tidyExpr env (Case e b alts)
516 = tidyExpr env e `thenUs` \ e ->
517 tidyBndr env b `thenUs` \ (env', b) ->
518 mapUs (tidyAlt env') alts `thenUs` \ alts ->
519 returnUs (Case e b alts)
521 tidyExpr env (Lam b e)
522 = tidyBndr env b `thenUs` \ (env', b) ->
523 tidyExpr env' e `thenUs` \ e ->
527 tidyAlt env (con, vs, rhs)
528 = tidyBndrs env vs `thenUs` \ (env', vs) ->
529 tidyExpr env' rhs `thenUs` \ rhs ->
530 returnUs (con, vs, rhs)
532 tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
533 tidyNote env note = note
537 %************************************************************************
539 \subsection{Tidying up non-top-level binders}
541 %************************************************************************
544 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
548 -- tidyBndr is used for lambda and case binders
549 tidyBndr :: TidyEnv -> Var -> UniqSM (TidyEnv, Var)
551 | isTyVar var = returnUs (tidyTyVar env var)
552 | otherwise = tidyId env var (vanillaIdInfo `setCafInfo` NoCafRefs)
554 tidyBndrs :: TidyEnv -> [Var] -> UniqSM (TidyEnv, [Var])
555 tidyBndrs env vars = mapAccumLUs tidyBndr env vars
557 -- tidyBndrWithRhs is used for let binders
558 tidyBndrWithRhs :: TidyEnv -> (Var, CoreExpr) -> UniqSM (TidyEnv, Var)
559 tidyBndrWithRhs env (id,rhs)
560 = tidyId env id idinfo
562 idinfo = vanillaIdInfo `setArityInfo` ArityExactly (exprArity rhs)
563 `setCafInfo` NoCafRefs
564 -- NB: This throws away the IdInfo of the Id, which we
565 -- no longer need. That means we don't need to
566 -- run over it with env, nor renumber it.
568 tidyId :: TidyEnv -> Id -> IdInfo -> UniqSM (TidyEnv, Id)
569 tidyId env@(tidy_env, var_env) id idinfo
570 = -- Non-top-level variables
571 getUniqueUs `thenUs` \ uniq ->
573 -- Give the Id a fresh print-name, *and* rename its type
574 -- The SrcLoc isn't important now,
575 -- though we could extract it from the Id
576 name' = mkLocalName uniq occ' noSrcLoc
577 (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
578 ty' = tidyType (tidy_env,var_env) (idType id)
579 id' = mkId name' ty' idinfo
580 var_env' = extendVarEnv var_env id id'
582 returnUs ((tidy_env', var_env'), id')
586 = case idFlavour id of
587 PrimOpId (CCallOp ccall) ->
588 -- Make a guaranteed unique name for a dynamic ccall.
589 getUniqueUs `thenUs` \ uniq ->
590 returnUs (modifyIdInfo (`setFlavourInfo`
591 PrimOpId (CCallOp (setCCallUnique ccall uniq))) id)
596 %************************************************************************
598 \subsection{Figuring out CafInfo for an expression}
600 %************************************************************************
603 hasCafRefs :: (Id -> Bool) -> CoreExpr -> CafInfo
604 hasCafRefss :: (Id -> Bool) -> [CoreExpr] -> CafInfo
605 -- predicate returns True for a given Id if we look at this Id when
606 -- calculating the result. Used to *avoid* looking at the CafInfo
607 -- field for an Id that is part of the current recursive group.
609 hasCafRefs p expr = if isCAF expr || isFastTrue (cafRefs p expr)
613 hasCafRefss p exprs = if any isCAF exprs || isFastTrue (cafRefss p exprs)
619 = case idCafInfo id of
620 NoCafRefs -> fastBool False
621 MayHaveCafRefs -> fastBool True
625 cafRefs p (Lit l) = fastBool False
626 cafRefs p (App f a) = cafRefs p f `fastOr` cafRefs p a
627 cafRefs p (Lam x e) = cafRefs p e
628 cafRefs p (Let b e) = cafRefss p (rhssOfBind b) `fastOr` cafRefs p e
629 cafRefs p (Case e bndr alts) = cafRefs p e `fastOr` cafRefss p (rhssOfAlts alts)
630 cafRefs p (Note n e) = cafRefs p e
631 cafRefs p (Type t) = fastBool False
633 cafRefss p [] = fastBool False
634 cafRefss p (e:es) = cafRefs p e `fastOr` cafRefss p es
636 -- Decide whether a closure looks like a CAF or not. In an effort to
637 -- keep the number of CAFs (and hence the size of the SRTs) down, we
638 -- would also like to look at the expression and decide whether it
639 -- requires a small bounded amount of heap, so we can ignore it as a CAF.
640 -- In these cases, we need to use an additional CAF list to keep track of
641 -- non-collectable CAFs.
643 -- We mark real CAFs as `MayHaveCafRefs' because this information is used
644 -- to decide whether a particular closure needs to be referenced in an
647 isCAF :: CoreExpr -> Bool
648 -- special case for expressions which are always bottom,
649 -- such as 'error "..."'. We don't need to record it as
650 -- a CAF, since it can only be entered once.
652 | not_function && is_bottom = False
653 | not_function && updatable = True
656 not_function = exprArity e == 0
657 is_bottom = exprIsBottom e
658 updatable = True {- ToDo: check type for onceness? -}