TidyPgm.lhs 23.2 KB
 simonpj committed Mar 20, 2002 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section{Tidying up Core} \begin{code} module TidyPgm( tidyCorePgm, tidyCoreExpr ) where #include "HsVersions.h" import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile ) import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars ) import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules ) import PprCore ( pprIdRules ) import CoreLint ( showPass, endPass )  simonmar committed Mar 21, 2003 18 import CoreUtils ( exprArity, rhsIsNonUpd )  simonpj committed Mar 20, 2002 19 20 21 22 import VarEnv import VarSet import Var ( Id, Var ) import Id ( idType, idInfo, idName, idCoreRules,  simonpj committed Apr 01, 2002 23  isExportedId, mkVanillaGlobal, isLocalId,  simonmar committed Mar 21, 2003 24  isImplicitId, idArity, setIdInfo, idCafInfo  simonpj committed Mar 20, 2002 25 26 27  ) import IdInfo {- loads of stuff -} import NewDemand ( isBottomingSig, topSig )  simonmar committed Mar 21, 2003 28 import BasicTypes ( Arity, isNeverActive )  simonmar committed Mar 03, 2003 29 import Name ( getOccName, nameOccName, mkInternalName,  simonpj committed Mar 20, 2002 30 31  localiseName, isExternalName, nameSrcLoc )  simonpj committed Oct 24, 2002 32 import RnEnv ( lookupOrigNameCache, newExternalName )  simonmar committed Mar 03, 2003 33 import NameEnv ( lookupNameEnv, filterNameEnv )  simonpj committed Mar 20, 2002 34 35 import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) import Type ( tidyTopType )  simonpj committed Feb 21, 2003 36 import Module ( Module )  simonpj committed Sep 13, 2002 37 38 import HscTypes ( PersistentCompilerState( pcs_nc ), NameCache( nsNames, nsUniqs ),  simonpj committed Mar 20, 2002 39  TypeEnv, extendTypeEnvList, typeEnvIds,  simonpj committed Sep 13, 2002 40  ModGuts(..), ModGuts, TyThing(..)  simonpj committed Mar 20, 2002 41 42 43 44 45 46 47 48 49  ) import Maybes ( orElse ) import ErrUtils ( showPass, dumpIfSet_core ) import UniqFM ( mapUFM ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) import Util ( mapAccumL ) import Maybe ( isJust ) import Outputable  simonmar committed Mar 21, 2003 50 import FastTypes hiding ( fastOr )  simonpj committed Mar 20, 2002 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 \end{code} %************************************************************************ %* * \subsection{What goes on} %* * %************************************************************************ [SLPJ: 19 Nov 00] The plan is this. Step 1: Figure out external Ids ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ First we figure out which Ids are "external" Ids. An "external" Id is one that is visible from outside the compilation unit. These are a) the user exported ones b) ones mentioned in the unfoldings, workers, or rules of externally-visible ones This exercise takes a sweep of the bindings bottom to top. Actually, in Step 2 we're also going to need to know which Ids should be exported with their unfoldings, so we produce not an IdSet but an IdEnv Bool Step 2: Tidy the program ~~~~~~~~~~~~~~~~~~~~~~~~ Next we traverse the bindings top to bottom. For each *top-level* binder 1. Make it into a GlobalId 2. Give it a system-wide Unique. [Even non-exported things need system-wide Uniques because the byte-code generator builds a single Name->BCO symbol table.]  simonpj committed Sep 13, 2002 89  We use the NameCache kept in the PersistentCompilerState as the  simonpj committed Mar 20, 2002 90 91  source of such system-wide uniques.  simonpj committed Sep 13, 2002 92  For external Ids, use the original-name cache in the NameCache  simonpj committed Mar 20, 2002 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120  to ensure that the unique assigned is the same as the Id had in any previous compilation run. 3. If it's an external Id, make it have a global Name, otherwise make it have a local Name. This is used by the code generator to decide whether to make the label externally visible 4. Give external Ids a "tidy" occurrence name. This means we can print them in interface files without confusing "x" (unique 5) with "x" (unique 10). 5. Give it its UTTERLY FINAL IdInfo; in ptic, * Its IdDetails becomes VanillaGlobal, reflecting the fact that from now on we regard it as a global, not local, Id * its unfolding, if it should have one * its arity, computed from the number of visible lambdas * its CAF info, computed from what is free in its RHS Finally, substitute these new top-level binders consistently throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. \begin{code}  simonpj committed Sep 13, 2002 121 tidyCorePgm :: DynFlags  simonpj committed Mar 20, 2002 122  -> PersistentCompilerState  simonpj committed Sep 13, 2002 123 124  -> ModGuts -> IO (PersistentCompilerState, ModGuts)  simonpj committed Mar 20, 2002 125   simonmar committed Mar 03, 2003 126 tidyCorePgm dflags pcs  simonpj committed Sep 13, 2002 127 128 129  mod_impl@(ModGuts { mg_module = mod, mg_types = env_tc, mg_insts = insts_tc, mg_binds = binds_in, mg_rules = orphans_in })  simonpj committed Mar 20, 2002 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147  = do { showPass dflags "Tidy Core" ; let ext_ids = findExternalSet binds_in orphans_in ; let ext_rules = findExternalRules binds_in orphans_in ext_ids -- findExternalRules filters ext_rules to avoid binders that -- aren't externally visible; but the externally-visible binders -- are computed (by findExternalSet) assuming that all orphan -- rules are exported. So in fact we may export more than we -- need. (It's a sort of mutual recursion.) -- We also make sure to avoid any exported binders. Consider -- f{-u1-} = 1 -- Local decl -- ... -- f{-u2-} = 2 -- Exported decl -- -- The second exported decl must 'get' the name 'f', so we -- have to put 'f' in the avoids list before we get to the first -- decl. tidyTopId then does a no-op on exported binders.  simonpj committed Sep 13, 2002 148  ; let orig_ns = pcs_nc pcs  simonpj committed Mar 20, 2002 149 150 151 152 153 154 155 156 157 158 159 160  init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv) avoids = [getOccName name | bndr <- typeEnvIds env_tc, let name = idName bndr, isExternalName name] -- In computing our "avoids" list, we must include -- all implicit Ids -- all things with global names (assigned once and for -- all by the renamer) -- since their names are "taken". -- The type environment is a convenient source of such things. ; let ((orig_ns', occ_env, subst_env), tidy_binds)  simonmar committed Mar 03, 2003 161  = mapAccumL (tidyTopBind mod ext_ids)  simonpj committed Mar 20, 2002 162 163 164 165  init_tidy_env binds_in ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules  simonpj committed Sep 13, 2002 166  ; let pcs' = pcs { pcs_nc = orig_ns' }  simonpj committed Mar 20, 2002 167   simonmar committed Mar 03, 2003 168  ; let tidy_type_env = mkFinalTypeEnv env_tc tidy_binds  simonpj committed Mar 20, 2002 169 170  -- Dfuns are local Ids that might have  simonmar committed Mar 03, 2003 171 172 173 174 175 176 177 178 179 180 181 182 183  -- changed their unique during tidying. Remember -- to lookup the id in the TypeEnv too, because -- those Ids have had their IdInfo stripped if -- necessary. ; let lookup_dfun_id id = case lookupVarEnv subst_env id of Nothing -> dfun_panic Just id -> case lookupNameEnv tidy_type_env (idName id) of Just (AnId id) -> id _other -> dfun_panic where dfun_panic = pprPanic "lookup_dfun_id" (ppr id)  simonpj committed Mar 20, 2002 184 185 186  tidy_dfun_ids = map lookup_dfun_id insts_tc  simonpj committed Sep 13, 2002 187 188 189 190  ; let tidy_result = mod_impl { mg_types = tidy_type_env, mg_rules = tidy_rules, mg_insts = tidy_dfun_ids, mg_binds = tidy_binds }  simonpj committed Mar 20, 2002 191 192 193 194 195 196  ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds ; dumpIfSet_core dflags Opt_D_dump_simpl "Tidy Core Rules" (pprIdRules tidy_rules)  simonpj committed Sep 13, 2002 197  ; return (pcs', tidy_result)  simonpj committed Mar 20, 2002 198 199 200 201 202 203 204 205 206 207 208 209 210 211  } tidyCoreExpr :: CoreExpr -> IO CoreExpr tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr) \end{code} %************************************************************************ %* * \subsection{Write a new interface file} %* * %************************************************************************ \begin{code}  simonmar committed Mar 03, 2003 212 213 mkFinalTypeEnv :: TypeEnv -- From typechecker -> [CoreBind] -- Final Ids  simonpj committed Mar 20, 2002 214 215  -> TypeEnv  simonmar committed Mar 03, 2003 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 -- The competed type environment is gotten from -- a) keeping the types and classes -- b) removing all Ids, -- c) adding Ids with correct IdInfo, including unfoldings, -- gotten from the bindings -- From (c) we keep only those Ids with Global names; -- the CoreTidy pass makes sure these are all and only -- the externally-accessible ones -- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space -- -- However, we do keep things like constructors, which should not appear -- in interface files, because they are needed by importing modules when -- using the compilation manager mkFinalTypeEnv type_env tidy_binds = extendTypeEnvList (filterNameEnv keep_it type_env) final_ids  simonpj committed Mar 20, 2002 233  where  simonmar committed Mar 03, 2003 234 235 236 237 238 239 240 241 242 243  final_ids = [ AnId (strip_id_info id) | bind <- tidy_binds, id <- bindersOf bind, isExternalName (idName id)] strip_id_info id | opt_OmitInterfacePragmas = id setIdInfo vanillaIdInfo | otherwise = id -- If the interface file has no pragma info then discard all -- info right here.  simonpj committed Mar 20, 2002 244  --  simonmar committed Mar 03, 2003 245 246 247 248 249 250 251 252 253 254 255 256 257 258  -- This is not so important for *this* module, but it's -- vital for ghc --make: -- subsequent compilations must not see (e.g.) the arity if -- the interface file does not contain arity -- If they do, they'll exploit the arity; then the arity might -- change, but the iface file doesn't change => recompilation -- does not happen => disaster -- -- This IdInfo will live long-term in the Id => vanillaIdInfo makes -- a conservative assumption about Caf-hood -- -- We're not worried about occurrences of these Ids in unfoldings, -- because in OmitInterfacePragmas mode we're stripping all the -- unfoldings anyway.  simonpj committed Mar 20, 2002 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396  -- We keep implicit Ids, because they won't appear -- in the bindings from which final_ids are derived! keep_it (AnId id) = isImplicitId id -- Remove all Ids except implicit ones keep_it other = True -- Keep all TyCons and Classes \end{code} \begin{code} findExternalRules :: [CoreBind] -> [IdCoreRule] -- Orphan rules -> IdEnv a -- Ids that are exported, so we need their rules -> [IdCoreRule] -- The complete rules are gotten by combining -- a) the orphan rules -- b) rules embedded in the top-level Ids findExternalRules binds orphan_rules ext_ids | opt_OmitInterfacePragmas = [] | otherwise = filter needed_rule (orphan_rules ++ local_rules) where local_rules = [ rule | id <- bindersOfBinds binds, id elemVarEnv ext_ids, rule <- idCoreRules id ] needed_rule (id, rule) = not (isBuiltinRule rule) -- We can't print builtin rules in interface files -- Since they are built in, an importing module -- will have access to them anyway && not (any internal_id (varSetElems (ruleLhsFreeIds rule))) -- Don't export a rule whose LHS mentions an Id that -- is completely internal (i.e. not visible to an -- importing module) internal_id id = isLocalId id && not (id elemVarEnv ext_ids) \end{code} %************************************************************************ %* * \subsection{Step 1: finding externals} %* * %************************************************************************ \begin{code} findExternalSet :: [CoreBind] -> [IdCoreRule] -> IdEnv Bool -- In domain => external -- Range = True <=> show unfolding -- Step 1 from the notes above findExternalSet binds orphan_rules = foldr find init_needed binds where orphan_rule_ids :: IdSet orphan_rule_ids = unionVarSets [ ruleRhsFreeVars rule | (_, rule) <- orphan_rules] init_needed :: IdEnv Bool init_needed = mapUFM (\_ -> False) orphan_rule_ids -- The mapUFM is a bit cheesy. It is a cheap way -- to turn the set of orphan_rule_ids, which we use to initialise -- the sweep, into a mapping saying 'don't expose unfolding' -- (When we come to the binding site we may change our mind, of course.) find (NonRec id rhs) needed | need_id needed id = addExternal (id,rhs) needed | otherwise = needed find (Rec prs) needed = find_prs prs needed -- For a recursive group we have to look for a fixed point find_prs prs needed | null needed_prs = needed | otherwise = find_prs other_prs new_needed where (needed_prs, other_prs) = partition (need_pr needed) prs new_needed = foldr addExternal needed needed_prs -- The 'needed' set contains the Ids that are needed by earlier -- interface file emissions. If the Id isn't in this set, and isn't -- exported, there's no need to emit anything need_id needed_set id = id elemVarEnv needed_set || isExportedId id need_pr needed_set (id,rhs) = need_id needed_set id addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool -- The Id is needed; extend the needed set -- with it and its dependents (free vars etc) addExternal (id,rhs) needed = extendVarEnv (foldVarSet add_occ needed new_needed_ids) id show_unfold where add_occ id needed = extendVarEnv needed id False -- "False" because we don't know we need the Id's unfolding -- We'll override it later when we find the binding site new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet | otherwise = worker_ids unionVarSet unfold_ids unionVarSet spec_ids idinfo = idInfo id dont_inline = isNeverActive (inlinePragInfo idinfo) loop_breaker = isLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (newStrictnessInfo idinfo orElse topSig) spec_ids = rulesRhsFreeVars (specInfo idinfo) worker_info = workerInfo idinfo -- Stuff to do with the Id's unfolding -- The simplifier has put an up-to-date unfolding -- in the IdInfo, but the RHS will do just as well unfolding = unfoldingInfo idinfo rhs_is_small = not (neverUnfold unfolding) -- We leave the unfolding there even if there is a worker -- In GHCI the unfolding is used by importers -- When writing an interface file, we omit the unfolding -- if there is a worker show_unfold = not bottoming_fn && -- Not necessary not dont_inline && not loop_breaker && rhs_is_small && -- Small enough okToUnfoldInHiFile rhs -- No casms etc unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs | otherwise = emptyVarSet worker_ids = case worker_info of HasWorker work_id _ -> unitVarSet work_id otherwise -> emptyVarSet \end{code} %************************************************************************ %* * \subsection{Step 2: top-level tidying} %* * %************************************************************************ \begin{code}  simonpj committed Sep 13, 2002 397 type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var)  simonpj committed Mar 20, 2002 398 399  -- TopTidyEnv: when tidying we need to know  simonpj committed Sep 13, 2002 400 -- * ns: The NameCache, containing a unique supply and any pre-ordained Names.  simonpj committed Mar 20, 2002 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 -- These may have arisen because the -- renamer read in an interface file mentioning M.$wf, say, -- and assigned it unique r77. If, on this compilation, we've -- invented an Id whose name is$wf (but with a different unique) -- we want to rename it to have unique r77, so that we can do easy -- comparisons with stuff from the interface file -- -- * occ_env: The TidyOccEnv, which tells us which local occurrences -- are 'used' -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old \end{code} \begin{code} tidyTopBind :: Module -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too -> TopTidyEnv -> CoreBind -> (TopTidyEnv, CoreBind)  simonmar committed Mar 21, 2003 422 tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (NonRec bndr rhs)  simonpj committed Mar 20, 2002 423 424 425  = ((orig,occ,subst) , NonRec bndr' rhs') where ((orig,occ,subst), bndr')  simonmar committed Mar 03, 2003 426  = tidyTopBinder mod ext_ids caf_info  simonpj committed Mar 20, 2002 427 428 429  rec_tidy_env rhs rhs' top_tidy_env bndr rec_tidy_env = (occ,subst) rhs' = tidyExpr rec_tidy_env rhs  simonmar committed Mar 21, 2003 430  caf_info = hasCafRefs subst1 (idArity bndr') rhs'  simonpj committed Mar 20, 2002 431   simonmar committed Mar 21, 2003 432 tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (Rec prs)  simonpj committed Mar 20, 2002 433 434 435 436 437 438 439 440 441  = (final_env, Rec prs') where (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs rec_tidy_env = (occ,subst) do_one top_tidy_env (bndr,rhs) = ((orig,occ,subst), (bndr',rhs')) where ((orig,occ,subst), bndr')  simonmar committed Mar 03, 2003 442  = tidyTopBinder mod ext_ids caf_info  simonpj committed Mar 20, 2002 443 444 445 446  rec_tidy_env rhs rhs' top_tidy_env bndr rhs' = tidyExpr rec_tidy_env rhs  simonmar committed Mar 03, 2003 447 448 449  -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). caf_info  simonmar committed Mar 21, 2003 450 451  | or [ mayHaveCafRefs (hasCafRefs subst1 (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs  simonmar committed Mar 03, 2003 452 453 454  | otherwise = NoCafRefs tidyTopBinder :: Module -> IdEnv Bool -> CafInfo  simonpj committed Mar 20, 2002 455 456 457 458 459 460 461 462  -> TidyEnv -- The TidyEnv is used to tidy the IdInfo -> CoreExpr -- RHS *before* tidying -> CoreExpr -- RHS *after* tidying -- The TidyEnv and the after-tidying RHS are -- both are knot-tied: don't look at them! -> TopTidyEnv -> Id -> (TopTidyEnv, Id) -- NB: tidyTopBinder doesn't affect the unique supply  simonmar committed Mar 03, 2003 463 tidyTopBinder mod ext_ids caf_info rec_tidy_env rhs tidy_rhs  simonpj committed Mar 20, 2002 464 465 466 467 468 469 470 471  env@(ns2, occ_env2, subst_env2) id -- This function is the heart of Step 2 -- The rec_tidy_env is the one to use for the IdInfo -- It's necessary because when we are dealing with a recursive -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group -- The rhs is already tidied  simonmar committed Apr 11, 2003 472 473 474 475  = ASSERT(isLocalId id) -- "all Ids defined in this module are local -- until the CoreTidy phase" --GHC comentary ((orig_env', occ_env', subst_env'), id')  simonpj committed Mar 20, 2002 476 477 478 479 480 481 482  where (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2 is_external (idName id) ty' = tidyTopType (idType id) idinfo = tidyTopIdInfo rec_tidy_env is_external (idInfo id) unfold_info arity  simonmar committed Mar 03, 2003 483  caf_info  simonpj committed Mar 20, 2002 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514  id' = mkVanillaGlobal name' ty' idinfo subst_env' = extendVarEnv subst_env2 id id' maybe_external = lookupVarEnv ext_ids id is_external = isJust maybe_external -- Expose an unfolding if ext_ids tells us to -- Remember that ext_ids maps an Id to a Bool: -- True to show the unfolding, False to hide it show_unfold = maybe_external orElse False unfold_info | show_unfold = mkTopUnfolding tidy_rhs | otherwise = noUnfolding -- Usually the Id will have an accurate arity on it, because -- the simplifier has just run, but not always. -- One case I found was when the last thing the simplifier -- did was to let-bind a non-atomic argument and then float -- it to the top level. So it seems more robust just to -- fix it here. arity = exprArity rhs -- tidyTopIdInfo creates the final IdInfo for top-level -- binders. There are two delicate pieces: -- -- * Arity. After CoreTidy, this arity must not change any more. -- Indeed, CorePrep must eta expand where necessary to make -- the manifest arity equal to the claimed arity. --  simonmar committed Mar 03, 2003 515 516 -- * CAF info. This must also remain valid through to code generation. -- We add the info here so that it propagates to all  simonpj committed Mar 20, 2002 517 518 -- occurrences of the binders in RHSs, and hence to occurrences in -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES.  simonmar committed Mar 03, 2003 519 -- CoreToStg makes use of this when constructing SRTs.  simonpj committed Jul 29, 2002 520   simonmar committed Mar 03, 2003 521 tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info  simonpj committed Jul 29, 2002 522 523 524 525  | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; -- c.f. CoreTidy.tidyLetBndr  simonmar committed Mar 03, 2003 526  setCafInfo caf_info  simonpj committed Jul 29, 2002 527 528 529 530 531  setArityInfo arity setAllStrictnessInfo newStrictnessInfo idinfo | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo  simonmar committed Mar 03, 2003 532  setCafInfo caf_info  simonpj committed Jul 29, 2002 533 534  setArityInfo arity setAllStrictnessInfo newStrictnessInfo idinfo  simonpj committed Mar 20, 2002 535 536 537 538 539 540  setInlinePragInfo inlinePragInfo idinfo setUnfoldingInfo unfold_info setWorkerInfo tidyWorker tidy_env (workerInfo idinfo) -- NB: we throw away the Rules -- They have already been extracted by findExternalRules  simonmar committed Mar 03, 2003 541   simonpj committed Mar 20, 2002 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 -- This is where we set names to local/global based on whether they really are -- externally visible (see comment at the top of this module). If the name -- was previously local, we have to give it a unique occurrence name if -- we intend to externalise it. tidyTopName mod ns occ_env external name | global && internal = (ns, occ_env, localiseName name) | global && external = (ns, occ_env, name) -- Global names are assumed to have been allocated by the renamer, -- so they already have the "right" unique -- And it's a system-wide unique too | local && internal = (ns_w_local, occ_env', new_local_name) -- Even local, internal names must get a unique occurrence, because -- if we do -split-objs we externalise the name later, in the code generator -- -- Similarly, we must make sure it has a system-wide Unique, because -- the byte-code generator builds a system-wide Name->BCO symbol table  simonpj committed Oct 24, 2002 561  | local && external = case lookupOrigNameCache ns_names mod occ' of  simonpj committed Mar 20, 2002 562 563 564 565 566 567 568 569 570 571 572 573  Just orig -> (ns, occ_env', orig) Nothing -> (ns_w_global, occ_env', new_external_name) -- If we want to externalise a currently-local name, check -- whether we have already assigned a unique for it. -- If so, use it; if not, extend the table (ns_w_global). -- This is needed when *re*-compiling a module in GHCi; we want to -- use the same name for externally-visible things as we did before. where global = isExternalName name local = not global internal = not external  simonpj committed Oct 24, 2002 574  loc = nameSrcLoc name  simonpj committed Mar 20, 2002 575 576  (occ_env', occ') = tidyOccName occ_env (nameOccName name)  simonpj committed Oct 24, 2002 577   simonpj committed Mar 20, 2002 578  ns_names = nsNames ns  simonpj committed Oct 24, 2002 579  (us1, us2) = splitUniqSupply (nsUniqs ns)  simonpj committed Mar 20, 2002 580  uniq = uniqFromSupply us1  simonpj committed Oct 24, 2002 581  new_local_name = mkInternalName uniq occ' loc  simonpj committed Mar 20, 2002 582  ns_w_local = ns { nsUniqs = us2 }  simonpj committed Oct 24, 2002 583 584  (ns_w_global, new_external_name) = newExternalName ns mod occ' loc  simonpj committed Mar 20, 2002 585 586 587 588 589 590 591  ------------ Worker -------------- tidyWorker tidy_env (HasWorker work_id wrap_arity) = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity tidyWorker tidy_env other = NoWorker  simonmar committed Mar 03, 2003 592 \end{code}  simonmar committed Mar 21, 2003 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651  %************************************************************************ %* * \subsection{Figuring out CafInfo for an expression} %* * %************************************************************************ hasCafRefs decides whether a top-level closure can point into the dynamic heap. We mark such things as MayHaveCafRefs' because this information is used to decide whether a particular closure needs to be referenced in an SRT or not. There are two reasons for setting MayHaveCafRefs: a) The RHS is a CAF: a top-level updatable thunk. b) The RHS refers to something that MayHaveCafRefs Possible improvement: In an effort to keep the number of CAFs (and hence the size of the SRTs) down, we could also look at the expression and decide whether it requires a small bounded amount of heap, so we can ignore it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. \begin{code} hasCafRefs :: VarEnv Var -> Arity -> CoreExpr -> CafInfo hasCafRefs p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefs p expr) is_caf = not (arity > 0 || rhsIsNonUpd expr) -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity -- knows how much eta expansion is going to be done by -- CorePrep later on, and we don't want to duplicate that -- knowledge in rhsIsNonUpd below. cafRefs p (Var id) -- imported Ids first: | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id)) -- now Ids local to this module: | otherwise = case lookupVarEnv p id of Just id' -> fastBool (mayHaveCafRefs (idCafInfo id')) Nothing -> fastBool False cafRefs p (Lit l) = fastBool False cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a cafRefs p (Lam x e) = cafRefs p e cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts) cafRefs p (Note n e) = cafRefs p e cafRefs p (Type t) = fastBool False cafRefss p [] = fastBool False cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es -- hack for lazy-or over FastBool. fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x)) \end{code}`