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 CoreUtils ( exprArity )
18 import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars, ruleSomeLhsFreeVars )
19 import CoreLint ( showPass, endPass )
22 import Var ( Id, Var, varName, globalIdDetails, setGlobalIdDetails )
23 import Id ( idType, idInfo, idName, isExportedId, idSpecialisation,
24 idCafInfo, mkVanillaGlobal, isLocalId, isImplicitId,
25 modifyIdInfo, idArity, hasNoBinding, mkLocalIdWithInfo
27 import IdInfo {- loads of stuff -}
28 import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
29 localiseName, mkLocalName, isGlobalName, isDllName, isLocalName
31 import NameEnv ( filterNameEnv )
32 import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
33 import Type ( tidyTopType, tidyType, tidyTyVar )
34 import Module ( Module, moduleName )
35 import PrimOp ( PrimOp(..), setCCallUnique )
36 import HscTypes ( PersistentCompilerState( pcs_PRS ),
37 PersistentRenamerState( prsOrig ),
38 NameSupply( nsNames ), OrigNameCache,
39 TypeEnv, extendTypeEnvList,
40 DFunId, ModDetails(..), TyThing(..)
43 import DataCon ( DataCon, dataConName )
44 import Literal ( isLitLitLit )
45 import FiniteMap ( lookupFM, addToFM )
46 import Maybes ( maybeToBool, orElse )
47 import ErrUtils ( showPass )
48 import PprCore ( pprIdCoreRule )
49 import SrcLoc ( noSrcLoc )
50 import UniqFM ( mapUFM )
53 import List ( partition )
54 import Util ( mapAccumL )
59 %************************************************************************
61 \subsection{What goes on}
63 %************************************************************************
69 Step 1: Figure out external Ids
70 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
71 First we figure out which Ids are "external" Ids. An
72 "external" Id is one that is visible from outside the compilation
74 a) the user exported ones
75 b) ones mentioned in the unfoldings, workers,
76 or rules of externally-visible ones
77 This exercise takes a sweep of the bindings bottom to top. Actually,
78 in Step 2 we're also going to need to know which Ids should be
79 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 - Clone all local Ids. This means that Tidy Core has the property
100 that all Ids are unique, rather than the weaker guarantee of
101 no clashes which the simplifier provides.
103 - Give each dynamic CCall occurrence a fresh unique; this is
104 rather like the cloning step above.
106 - Give the Id its UTTERLY FINAL IdInfo; in ptic,
107 * Its IdDetails becomes VanillaGlobal, reflecting the fact that
108 from now on we regard it as a global, not local, Id
110 * its unfolding, if it should have one
112 * its arity, computed from the number of visible lambdas
114 * its CAF info, computed from what is free in its RHS
117 Finally, substitute these new top-level binders consistently
118 throughout, including in unfoldings. We also tidy binders in
119 RHSs, so that they print nicely in interfaces.
122 tidyCorePgm :: DynFlags -> Module
123 -> PersistentCompilerState
124 -> TypeEnv -> [DFunId]
125 -> [CoreBind] -> [IdCoreRule]
126 -> IO (PersistentCompilerState, [CoreBind], ModDetails)
128 tidyCorePgm dflags mod pcs env_tc insts_tc binds_in orphans_in
129 = do { showPass dflags "Tidy Core"
131 ; let ext_ids = findExternalSet binds_in orphans_in
133 ; us <- mkSplitUniqSupply 't' -- for "tidy"
135 ; let ((us1, orig_env', occ_env, subst_env), tidy_binds)
136 = mapAccumL (tidyTopBind mod ext_ids)
137 (init_tidy_env us) binds_in
139 ; let (orphans_out, _)
140 = initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in)
142 ; let prs' = prs { prsOrig = orig { nsNames = orig_env' } }
143 pcs' = pcs { pcs_PRS = prs' }
145 ; let final_ids = [ id | bind <- tidy_binds
146 , id <- bindersOf bind
147 , isGlobalName (idName id)]
149 -- Dfuns are local Ids that might have
150 -- changed their unique during tidying
151 ; let lookup_dfun_id id = lookupVarEnv subst_env id `orElse`
152 pprPanic "lookup_dfun_id" (ppr id)
155 ; let final_rules = mkFinalRules orphans_out final_ids
156 final_type_env = mkFinalTypeEnv env_tc final_ids
157 final_dfun_ids = map lookup_dfun_id insts_tc
159 ; let new_details = ModDetails { md_types = final_type_env,
160 md_rules = final_rules,
161 md_insts = final_dfun_ids }
163 ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
165 ; return (pcs', tidy_binds, new_details)
168 -- We also make sure to avoid any exported binders. Consider
169 -- f{-u1-} = 1 -- Local decl
171 -- f{-u2-} = 2 -- Exported decl
173 -- The second exported decl must 'get' the name 'f', so we
174 -- have to put 'f' in the avoids list before we get to the first
175 -- decl. tidyTopId then does a no-op on exported binders.
178 orig_env = nsNames orig
180 init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv)
181 avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
182 isGlobalName (idName bndr)]
185 tidyCoreExpr :: CoreExpr -> IO CoreExpr
187 = do { us <- mkSplitUniqSupply 't' -- for "tidy"
188 ; let (expr',_) = initUs us (tidyExpr emptyTidyEnv expr)
194 %************************************************************************
196 \subsection{Write a new interface file}
198 %************************************************************************
201 mkFinalTypeEnv :: TypeEnv -- From typechecker
205 mkFinalTypeEnv type_env final_ids
206 = extendTypeEnvList (filterNameEnv keep_it type_env)
209 -- The competed type environment is gotten from
210 -- a) keeping the types and classes
211 -- b) removing all Ids,
212 -- c) adding Ids with correct IdInfo, including unfoldings,
213 -- gotten from the bindings
214 -- From (c) we keep only those Ids with Global names;
215 -- the CoreTidy pass makes sure these are all and only
216 -- the externally-accessible ones
217 -- This truncates the type environment to include only the
218 -- exported Ids and things needed from them, which saves space
220 -- However, we do keep things like constructors, which should not appear
221 -- in interface files, because they are needed by importing modules when
222 -- using the compilation manager
224 -- We keep constructor workers, because they won't appear
225 -- in the bindings from which final_ids are derived!
226 keep_it (AnId id) = hasNoBinding id -- Remove all Ids except constructor workers
227 keep_it other = True -- Keep all TyCons and Classes
231 mkFinalRules :: [IdCoreRule] -- Orphan rules
232 -> [Id] -- Ids that are exported, so we need their rules
234 -- The complete rules are gotten by combining
235 -- a) the orphan rules
236 -- b) rules embedded in the top-level Ids
237 mkFinalRules orphan_rules emitted
238 | opt_OmitInterfacePragmas = []
240 = orphan_rules ++ local_rules
242 local_rules = [ (fn, rule)
244 rule <- rulesRules (idSpecialisation fn),
245 not (isBuiltinRule rule),
246 -- We can't print builtin rules in interface files
247 -- Since they are built in, an importing module
248 -- will have access to them anyway
250 -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
251 -- from coming out, and to make it work properly we need to add ????
252 -- (put it back in for now)
253 isEmptyVarSet (ruleSomeLhsFreeVars (isLocalName . varName) rule)
254 -- Spit out a rule only if none of its LHS free vars are
255 -- LocalName things i.e. things that aren't visible to importing modules
256 -- This is a good reason not to do it when we emit the Id itself
261 %************************************************************************
263 \subsection{Step 1: finding externals}
265 %************************************************************************
268 findExternalSet :: [CoreBind] -> [IdCoreRule]
269 -> IdEnv Bool -- True <=> show unfolding
270 -- Step 1 from the notes above
271 findExternalSet binds orphan_rules
272 = foldr find init_needed binds
274 orphan_rule_ids :: IdSet
275 orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isLocalId rule
276 | (_, rule) <- orphan_rules]
277 init_needed :: IdEnv Bool
278 init_needed = mapUFM (\_ -> False) orphan_rule_ids
279 -- The mapUFM is a bit cheesy. It is a cheap way
280 -- to turn the set of orphan_rule_ids, which we use to initialise
281 -- the sweep, into a mapping saying 'don't expose unfolding'
282 -- (When we come to the binding site we may change our mind, of course.)
284 find (NonRec id rhs) needed
285 | need_id needed id = addExternal (id,rhs) needed
287 find (Rec prs) needed = find_prs prs needed
289 -- For a recursive group we have to look for a fixed point
291 | null needed_prs = needed
292 | otherwise = find_prs other_prs new_needed
294 (needed_prs, other_prs) = partition (need_pr needed) prs
295 new_needed = foldr addExternal needed needed_prs
297 -- The 'needed' set contains the Ids that are needed by earlier
298 -- interface file emissions. If the Id isn't in this set, and isn't
299 -- exported, there's no need to emit anything
300 need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
301 need_pr needed_set (id,rhs) = need_id needed_set id
303 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
304 -- The Id is needed; extend the needed set
305 -- with it and its dependents (free vars etc)
306 addExternal (id,rhs) needed
307 = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
310 add_occ id needed = extendVarEnv needed id False
311 -- "False" because we don't know we need the Id's unfolding
312 -- We'll override it later when we find the binding site
314 new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
315 | otherwise = worker_ids `unionVarSet`
316 unfold_ids `unionVarSet`
320 dont_inline = isNeverInlinePrag (inlinePragInfo idinfo)
321 loop_breaker = isLoopBreaker (occInfo idinfo)
322 bottoming_fn = isBottomingStrictness (strictnessInfo idinfo)
323 spec_ids = rulesRhsFreeVars (specInfo idinfo)
324 worker_info = workerInfo idinfo
326 -- Stuff to do with the Id's unfolding
327 -- The simplifier has put an up-to-date unfolding
328 -- in the IdInfo, but the RHS will do just as well
329 unfolding = unfoldingInfo idinfo
330 rhs_is_small = not (neverUnfold unfolding)
332 -- We leave the unfolding there even if there is a worker
333 -- In GHCI the unfolding is used by importers
334 -- When writing an interface file, we omit the unfolding
335 -- if there is a worker
336 show_unfold = not bottoming_fn && -- Not necessary
339 rhs_is_small && -- Small enough
340 okToUnfoldInHiFile rhs -- No casms etc
342 unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
343 | otherwise = emptyVarSet
345 worker_ids = case worker_info of
346 HasWorker work_id _ -> unitVarSet work_id
347 otherwise -> emptyVarSet
351 %************************************************************************
353 \subsection{Step 2: top-level tidying}
355 %************************************************************************
359 type TopTidyEnv = (UniqSupply, OrigNameCache, TidyOccEnv, VarEnv Var)
361 -- TopTidyEnv: when tidying we need to know
362 -- * orig_env: Any pre-ordained Names. These may have arisen because the
363 -- renamer read in an interface file mentioning M.$wf, say,
364 -- and assigned it unique r77. If, on this compilation, we've
365 -- invented an Id whose name is $wf (but with a different unique)
366 -- we want to rename it to have unique r77, so that we can do easy
367 -- comparisons with stuff from the interface file
369 -- * occ_env: The TidyOccEnv, which tells us which local occurrences
372 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
374 -- * uniqsuppy: so we can clone any Ids with non-preordained names.
380 tidyTopBind :: Module
381 -> IdEnv Bool -- Domain = Ids that should be external
382 -- True <=> their unfolding is external too
383 -> TopTidyEnv -> CoreBind
384 -> (TopTidyEnv, CoreBind)
386 tidyTopBind mod ext_ids env (NonRec bndr rhs)
387 = ((us2,orig,occ,subst) , NonRec bndr' rhs')
389 ((us1,orig,occ,subst), bndr')
390 = tidyTopBinder mod ext_ids tidy_env rhs' caf_info env bndr
391 tidy_env = (occ,subst)
392 caf_info = hasCafRefs (const True) rhs'
393 (rhs',us2) = initUs us1 (tidyExpr tidy_env rhs)
395 tidyTopBind mod ext_ids env (Rec prs)
396 = (final_env, Rec prs')
398 (final_env@(_,_,occ,subst), prs') = mapAccumL do_one env prs
399 final_tidy_env = (occ,subst)
401 do_one env (bndr,rhs)
402 = ((us',orig,occ,subst), (bndr',rhs'))
404 ((us,orig,occ,subst), bndr')
405 = tidyTopBinder mod ext_ids final_tidy_env rhs' caf_info env bndr
406 (rhs', us') = initUs us (tidyExpr final_tidy_env rhs)
408 -- the CafInfo for a recursive group says whether *any* rhs in
409 -- the group may refer indirectly to a CAF (because then, they all do).
410 (bndrs, rhss) = unzip prs'
411 caf_info = hasCafRefss pred rhss
412 pred v = v `notElem` bndrs
415 tidyTopBinder :: Module -> IdEnv Bool
416 -> TidyEnv -> CoreExpr -> CafInfo
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)
422 tidyTopBinder mod ext_ids tidy_env rhs caf_info
423 env@(us, orig_env2, occ_env2, subst_env2) id
425 | isImplicitId id -- Don't mess with constructors,
426 = (env, id) -- record selectors, and the like
429 -- This function is the heart of Step 2
430 -- The second env is the one to use for the IdInfo
431 -- It's necessary because when we are dealing with a recursive
432 -- group, a variable late in the group might be mentioned
433 -- in the IdInfo of one early in the group
435 -- The rhs is already tidied
437 = ((us_r, orig_env', occ_env', subst_env'), id')
439 (us_l, us_r) = splitUniqSupply us
441 (orig_env', occ_env', name') = tidyTopName mod orig_env2 occ_env2
444 ty' = tidyTopType (idType id)
445 idinfo' = tidyIdInfo us_l tidy_env
446 is_external unfold_info arity_info caf_info id
448 id' = mkVanillaGlobal name' ty' idinfo'
449 subst_env' = extendVarEnv subst_env2 id id'
451 maybe_external = lookupVarEnv ext_ids id
452 is_external = maybeToBool maybe_external
454 -- Expose an unfolding if ext_ids tells us to
455 show_unfold = maybe_external `orElse` False
456 unfold_info | show_unfold = mkTopUnfolding rhs
457 | otherwise = noUnfolding
459 arity_info = exprArity rhs
462 tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
463 | opt_OmitInterfacePragmas || not is_external
464 -- No IdInfo if the Id isn't external, or if we don't have -O
466 `setCafInfo` caf_info
467 `setStrictnessInfo` strictnessInfo core_idinfo
468 `setArityInfo` ArityExactly arity_info
469 -- Keep strictness, arity and CAF info; it's used by the code generator
472 = let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
475 `setCafInfo` caf_info
476 `setCprInfo` cprInfo core_idinfo
477 `setStrictnessInfo` strictnessInfo core_idinfo
478 `setInlinePragInfo` inlinePragInfo core_idinfo
479 `setUnfoldingInfo` unfold_info
480 `setWorkerInfo` tidyWorker tidy_env arity_info (workerInfo core_idinfo)
482 `setArityInfo` ArityExactly arity_info
483 -- this is the final IdInfo, it must agree with the
484 -- code finally generated (i.e. NO more transformations
487 core_idinfo = idInfo id
489 -- This is where we set names to local/global based on whether they really are
490 -- externally visible (see comment at the top of this module). If the name
491 -- was previously local, we have to give it a unique occurrence name if
492 -- we intend to globalise it.
493 tidyTopName mod orig_env occ_env external name
494 | global && internal = (orig_env, occ_env, localiseName name)
496 | local && internal = (orig_env, occ_env', setNameOcc name occ')
497 -- Even local, internal names must get a unique occurrence, because
498 -- if we do -split-objs we globalise the name later, n the code generator
500 | global && external = (orig_env, occ_env, name)
501 -- Global names are assumed to have been allocated by the renamer,
502 -- so they already have the "right" unique
504 | local && external = case lookupFM orig_env key of
505 Just orig -> (orig_env, occ_env', orig)
506 Nothing -> (addToFM orig_env key global_name, occ_env', global_name)
507 -- If we want to globalise a currently-local name, check
508 -- whether we have already assigned a unique for it.
509 -- If so, use it; if not, extend the table
512 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
513 key = (moduleName mod, occ')
514 global_name = globaliseName (setNameOcc name occ') mod
515 global = isGlobalName name
517 internal = not external
519 ------------ Worker --------------
520 -- We only treat a function as having a worker if
521 -- the exported arity (which is now the number of visible lambdas)
522 -- is the same as the arity at the moment of the w/w split
523 -- If so, we can safely omit the unfolding inside the wrapper, and
524 -- instead re-generate it from the type/arity/strictness info
525 -- But if the arity has changed, we just take the simple path and
526 -- put the unfolding into the interface file, forgetting the fact
527 -- that it's a wrapper.
529 -- How can this happen? Sometimes we get
530 -- f = coerce t (\x y -> $wf x y)
531 -- at the moment of w/w split; but the eta reducer turns it into
533 -- which is perfectly fine except that the exposed arity so far as
534 -- the code generator is concerned (zero) differs from the arity
535 -- when we did the split (2).
537 -- All this arises because we use 'arity' to mean "exactly how many
538 -- top level lambdas are there" in interface files; but during the
539 -- compilation of this module it means "how many things can I apply
541 tidyWorker tidy_env real_arity (HasWorker work_id wrap_arity)
542 | real_arity == wrap_arity
543 = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
544 tidyWorker tidy_env real_arity other
547 ------------ Rules --------------
548 tidyIdRules :: TidyEnv -> [IdCoreRule] -> UniqSM [IdCoreRule]
549 tidyIdRules env [] = returnUs []
550 tidyIdRules env ((fn,rule) : rules)
551 = tidyRule env rule `thenUs` \ rule ->
552 tidyIdRules env rules `thenUs` \ rules ->
553 returnUs ((tidyVarOcc env fn, rule) : rules)
555 tidyRules :: TidyEnv -> CoreRules -> UniqSM CoreRules
556 tidyRules env (Rules rules fvs)
557 = mapUs (tidyRule env) rules `thenUs` \ rules ->
558 returnUs (Rules rules (foldVarSet tidy_set_elem emptyVarSet fvs))
560 tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
562 tidyRule :: TidyEnv -> CoreRule -> UniqSM CoreRule
563 tidyRule env rule@(BuiltinRule _) = returnUs rule
564 tidyRule env (Rule name vars tpl_args rhs)
565 = tidyBndrs env vars `thenUs` \ (env', vars) ->
566 mapUs (tidyExpr env') tpl_args `thenUs` \ tpl_args ->
567 tidyExpr env' rhs `thenUs` \ rhs ->
568 returnUs (Rule name vars tpl_args rhs)
571 %************************************************************************
573 \subsection{Step 2: inner tidying
575 %************************************************************************
580 -> UniqSM (TidyEnv, CoreBind)
581 tidyBind env (NonRec bndr rhs)
582 = tidyBndrWithRhs env (bndr,rhs) `thenUs` \ (env', bndr') ->
583 tidyExpr env' rhs `thenUs` \ rhs' ->
584 returnUs (env', NonRec bndr' rhs')
586 tidyBind env (Rec prs)
587 = mapAccumLUs tidyBndrWithRhs env prs `thenUs` \ (env', bndrs') ->
588 mapUs (tidyExpr env') (map snd prs) `thenUs` \ rhss' ->
589 returnUs (env', Rec (zip bndrs' rhss'))
592 = fiddleCCall v `thenUs` \ v ->
593 returnUs (Var (tidyVarOcc env v))
595 tidyExpr env (Type ty) = returnUs (Type (tidyType env ty))
596 tidyExpr env (Lit lit) = returnUs (Lit lit)
598 tidyExpr env (App f a)
599 = tidyExpr env f `thenUs` \ f ->
600 tidyExpr env a `thenUs` \ a ->
603 tidyExpr env (Note n e)
604 = tidyExpr env e `thenUs` \ e ->
605 returnUs (Note (tidyNote env n) e)
607 tidyExpr env (Let b e)
608 = tidyBind env b `thenUs` \ (env', b') ->
609 tidyExpr env' e `thenUs` \ e ->
612 tidyExpr env (Case e b alts)
613 = tidyExpr env e `thenUs` \ e ->
614 tidyBndr env b `thenUs` \ (env', b) ->
615 mapUs (tidyAlt env') alts `thenUs` \ alts ->
616 returnUs (Case e b alts)
618 tidyExpr env (Lam b e)
619 = tidyBndr env b `thenUs` \ (env', b) ->
620 tidyExpr env' e `thenUs` \ e ->
624 tidyAlt env (con, vs, rhs)
625 = tidyBndrs env vs `thenUs` \ (env', vs) ->
626 tidyExpr env' rhs `thenUs` \ rhs ->
627 returnUs (con, vs, rhs)
629 tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
630 tidyNote env note = note
634 %************************************************************************
636 \subsection{Tidying up non-top-level binders}
638 %************************************************************************
641 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
645 -- tidyBndr is used for lambda and case binders
646 tidyBndr :: TidyEnv -> Var -> UniqSM (TidyEnv, Var)
648 | isTyVar var = returnUs (tidyTyVar env var)
649 | otherwise = tidyId env var noCafIdInfo
651 tidyBndrs :: TidyEnv -> [Var] -> UniqSM (TidyEnv, [Var])
652 tidyBndrs env vars = mapAccumLUs tidyBndr env vars
654 -- tidyBndrWithRhs is used for let binders
655 tidyBndrWithRhs :: TidyEnv -> (Var, CoreExpr) -> UniqSM (TidyEnv, Var)
656 tidyBndrWithRhs env (id,rhs)
657 = tidyId env id idinfo
659 idinfo = noCafIdInfo `setArityInfo` ArityExactly (exprArity rhs)
660 -- NB: This throws away the IdInfo of the Id, which we
661 -- no longer need. That means we don't need to
662 -- run over it with env, nor renumber it.
664 tidyId :: TidyEnv -> Id -> IdInfo -> UniqSM (TidyEnv, Id)
665 tidyId env@(tidy_env, var_env) id idinfo
666 = -- Non-top-level variables
667 getUniqueUs `thenUs` \ uniq ->
669 -- Give the Id a fresh print-name, *and* rename its type
670 -- The SrcLoc isn't important now,
671 -- though we could extract it from the Id
672 name' = mkLocalName uniq occ' noSrcLoc
673 (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
674 ty' = tidyType (tidy_env,var_env) (idType id)
675 id' = mkLocalIdWithInfo name' ty' idinfo
676 var_env' = extendVarEnv var_env id id'
678 returnUs ((tidy_env', var_env'), id')
682 = case globalIdDetails id of
683 PrimOpId (CCallOp ccall) ->
684 -- Make a guaranteed unique name for a dynamic ccall.
685 getUniqueUs `thenUs` \ uniq ->
686 returnUs (setGlobalIdDetails id
687 (PrimOpId (CCallOp (setCCallUnique ccall uniq))))
691 %************************************************************************
693 \subsection{Figuring out CafInfo for an expression}
695 %************************************************************************
697 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
698 We mark such things as `MayHaveCafRefs' because this information is
699 used to decide whether a particular closure needs to be referenced
702 There are two reasons for setting MayHaveCafRefs:
703 a) The RHS is a CAF: a top-level updatable thunk.
704 b) The RHS refers to something that MayHaveCafRefs
706 Possible improvement: In an effort to keep the number of CAFs (and
707 hence the size of the SRTs) down, we could also look at the expression and
708 decide whether it requires a small bounded amount of heap, so we can ignore
709 it as a CAF. In these cases however, we would need to use an additional
710 CAF list to keep track of non-collectable CAFs.
713 hasCafRefs :: (Id -> Bool) -> CoreExpr -> CafInfo
714 -- Only called for the RHS of top-level lets
715 hasCafRefss :: (Id -> Bool) -> [CoreExpr] -> CafInfo
716 -- predicate returns True for a given Id if we look at this Id when
717 -- calculating the result. Used to *avoid* looking at the CafInfo
718 -- field for an Id that is part of the current recursive group.
720 hasCafRefs p expr = if isCAF expr || isFastTrue (cafRefs p expr)
724 -- used for recursive groups. The whole group is set to
725 -- "MayHaveCafRefs" if at least one of the group is a CAF or
726 -- refers to any CAFs.
727 hasCafRefss p exprs = if any isCAF exprs || isFastTrue (cafRefss p exprs)
733 = case idCafInfo id of
734 NoCafRefs -> fastBool False
735 MayHaveCafRefs -> fastBool True
739 cafRefs p (Lit l) = fastBool False
740 cafRefs p (App f a) = cafRefs p f `fastOr` cafRefs p a
741 cafRefs p (Lam x e) = cafRefs p e
742 cafRefs p (Let b e) = cafRefss p (rhssOfBind b) `fastOr` cafRefs p e
743 cafRefs p (Case e bndr alts) = cafRefs p e `fastOr` cafRefss p (rhssOfAlts alts)
744 cafRefs p (Note n e) = cafRefs p e
745 cafRefs p (Type t) = fastBool False
747 cafRefss p [] = fastBool False
748 cafRefss p (e:es) = cafRefs p e `fastOr` cafRefss p es
751 isCAF :: CoreExpr -> Bool
752 -- Only called for the RHS of top-level lets
753 isCAF e = not (rhsIsNonUpd e)
754 {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
756 rhsIsNonUpd :: CoreExpr -> Bool
757 -- True => Value-lambda, constructor, PAP
758 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
759 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
761 -- b) (C x xs), where C is a contructors is updatable if the application is
762 -- dynamic: see isDynConApp
764 -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
766 rhsIsNonUpd (Lam b e) = isId b || rhsIsNonUpd e
767 rhsIsNonUpd (Note (SCC _) e) = False
768 rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
769 rhsIsNonUpd other_expr
772 go (Var f) n_args args = idAppIsNonUpd f n_args args
774 go (App f a) n_args args
775 | isTypeArg a = go f n_args args
776 | otherwise = go f (n_args + 1) (a:args)
778 go (Note (SCC _) f) n_args args = False
779 go (Note _ f) n_args args = go f n_args args
781 go other n_args args = False
783 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
784 idAppIsNonUpd id n_val_args args
785 = case globalIdDetails id of
786 DataConId con | not (isDynConApp con args) -> True
787 other -> n_val_args < idArity id
789 isDynConApp :: DataCon -> [CoreExpr] -> Bool
790 isDynConApp con args = isDllName (dataConName con) || any isDynArg args
791 -- Top-level constructor applications can usually be allocated
792 -- statically, but they can't if
793 -- a) the constructor, or any of the arguments, come from another DLL
794 -- b) any of the arguments are LitLits
795 -- (because we can't refer to static labels in other DLLs).
796 -- If this happens we simply make the RHS into an updatable thunk,
797 -- and 'exectute' it rather than allocating it statically.
798 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
801 isDynArg :: CoreExpr -> Bool
802 isDynArg (Var v) = isDllName (idName v)
803 isDynArg (Note _ e) = isDynArg e
804 isDynArg (Lit lit) = isLitLitLit lit
805 isDynArg (App e _) = isDynArg e -- must be a type app
806 isDynArg (Lam _ e) = isDynArg e -- must be a type lam