ghc/compiler/coreSyn/CoreTidy.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section{Tidying up Core}
   5
   6 \begin{code}
   7 module CoreTidy (
   8         tidyCorePgm, tidyExpr,
   9         tidyBndr, tidyBndrs
  10     ) where
  11
  12 #include "HsVersions.h"
  13
  14 import CmdLineOpts      ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
  15 import CoreSyn
  16 import CoreUnfold       ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
  17 import CoreUtils        ( exprArity, exprIsBottom )
  18 import CoreFVs          ( ruleSomeFreeVars, exprSomeFreeVars )
  19 import CoreLint         ( showPass, endPass )
  20 import VarEnv
  21 import VarSet
  22 import Var              ( Id, Var )
  23 import Id               ( idType, idInfo, idName, isExportedId,
  24                           idCafInfo, mkId, isLocalId, isImplicitId,
  25                           idFlavour, modifyIdInfo
  26                         )
  27 import IdInfo           {- loads of stuff -}
  28 import Name             ( getOccName, nameOccName, globaliseName, setNameOcc,
  29                           localiseName, mkLocalName, isGlobalName
  30                         )
  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                           NameSupply( nsNames ), OrigNameCache
  38                         )
  39 import UniqSupply
  40 import FiniteMap        ( lookupFM, addToFM )
  41 import Maybes           ( maybeToBool, orElse )
  42 import ErrUtils         ( showPass )
  43 import SrcLoc           ( noSrcLoc )
  44 import UniqFM           ( mapUFM )
  45 import Outputable
  46 import FastTypes
  47 import List             ( partition )
  48 import Util             ( mapAccumL )
  49 \end{code}
  50
  51
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection{What goes on}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 [SLPJ: 19 Nov 00]
  60
  61 The plan is this.
  62
  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
  67 unit.  These are
  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
  74 IdEnv Bool
  75
  76
  77 Step 2: Tidy the program
  78 ~~~~~~~~~~~~~~~~~~~~~~~~
  79 Next we traverse the bindings top to bottom.  For each top-level
  80 binder
  81
  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
  85
  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).
  89
  90   - Give external Ids the same Unique as they had before
  91     if the name is in the renamer's name cache
  92
  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.
  96
  97   - Give each dynamic CCall occurrence a fresh unique; this is
  98     rather like the cloning step above.
  99
 100   - Give the Id its UTTERLY FINAL IdInfo; in ptic,
 101         * Its flavour becomes ConstantId, reflecting the fact that
 102           from now on we regard it as a constant, not local, Id
 103
 104         * its unfolding, if it should have one
 105
 106         * its arity, computed from the number of visible lambdas
 107
 108         * its CAF info, computed from what is free in its RHS
 109
 110
 111 Finally, substitute these new top-level binders consistently
 112 throughout, including in unfoldings.  We also tidy binders in
 113 RHSs, so that they print nicely in interfaces.
 114
 115 \begin{code}
 116 tidyCorePgm :: DynFlags -> Module
 117             -> PersistentCompilerState
 118             -> [CoreBind] -> [IdCoreRule]
 119             -> IO (PersistentCompilerState, [CoreBind], [IdCoreRule])
 120 tidyCorePgm dflags mod pcs binds_in orphans_in
 121   = do  { showPass dflags "Tidy Core"
 122
 123         ; let ext_ids = findExternalSet binds_in orphans_in
 124
 125         ; us <- mkSplitUniqSupply 't' -- for "tidy"
 126
 127         ; let ((us1, orig_env', occ_env, subst_env), binds_out)
 128                         = mapAccumL (tidyTopBind mod ext_ids)
 129                                     (init_tidy_env us) binds_in
 130
 131         ; let (orphans_out, _)
 132                    = initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in)
 133
 134         ; let prs' = prs { prsOrig = orig { nsNames = orig_env' } }
 135               pcs' = pcs { pcs_PRS = prs' }
 136
 137         ; endPass dflags "Tidy Core" Opt_D_dump_simpl binds_out
 138
 139         ; return (pcs', binds_out, orphans_out)
 140         }
 141   where
 142         -- We also make sure to avoid any exported binders.  Consider
 143         --      f{-u1-} = 1     -- Local decl
 144         --      ...
 145         --      f{-u2-} = 2     -- Exported decl
 146         --
 147         -- The second exported decl must 'get' the name 'f', so we
 148         -- have to put 'f' in the avoids list before we get to the first
 149         -- decl.  tidyTopId then does a no-op on exported binders.
 150     prs              = pcs_PRS pcs
 151     orig             = prsOrig prs
 152     orig_env         = nsNames orig
 153
 154     init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv)
 155     avoids           = [getOccName bndr | bndr <- bindersOfBinds binds_in,
 156                                        isGlobalName (idName bndr)]
 157 \end{code}
 158
 159
 160 %************************************************************************
 161 %*                                                                      *
 162 \subsection{Step 1: finding externals}
 163 %*                                                                      *
 164 %************************************************************************
 165
 166 \begin{code}
 167 findExternalSet :: [CoreBind] -> [IdCoreRule]
 168                 -> IdEnv Bool   -- True <=> show unfolding
 169         -- Step 1 from the notes above
 170 findExternalSet binds orphan_rules
 171   = foldr find init_needed binds
 172   where
 173     orphan_rule_ids :: IdSet
 174     orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isIdAndLocal rule
 175                                    | (_, rule) <- orphan_rules]
 176     init_needed :: IdEnv Bool
 177     init_needed = mapUFM (\_ -> False) orphan_rule_ids
 178         -- The mapUFM is a bit cheesy.  It is a cheap way
 179         -- to turn the set of orphan_rule_ids, which we use to initialise
 180         -- the sweep, into a mapping saying 'don't expose unfolding'
 181         -- (When we come to the binding site we may change our mind, of course.)
 182
 183     find (NonRec id rhs) needed
 184         | need_id needed id = addExternal (id,rhs) needed
 185         | otherwise         = needed
 186     find (Rec prs) needed   = find_prs prs needed
 187
 188         -- For a recursive group we have to look for a fixed point
 189     find_prs prs needed
 190         | null needed_prs = needed
 191         | otherwise       = find_prs other_prs new_needed
 192         where
 193           (needed_prs, other_prs) = partition (need_pr needed) prs
 194           new_needed = foldr addExternal needed needed_prs
 195
 196         -- The 'needed' set contains the Ids that are needed by earlier
 197         -- interface file emissions.  If the Id isn't in this set, and isn't
 198         -- exported, there's no need to emit anything
 199     need_id needed_set id       = id `elemVarEnv` needed_set || isExportedId id
 200     need_pr needed_set (id,rhs) = need_id needed_set id
 201
 202 isIdAndLocal id = isId id && isLocalId id
 203
 204 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
 205 -- The Id is needed; extend the needed set
 206 -- with it and its dependents (free vars etc)
 207 addExternal (id,rhs) needed
 208   = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
 209                  id show_unfold
 210   where
 211     add_occ id needed = extendVarEnv needed id False
 212         -- "False" because we don't know we need the Id's unfolding
 213         -- We'll override it later when we find the binding site
 214
 215     new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
 216                    | otherwise                = worker_ids      `unionVarSet`
 217                                                 unfold_ids      `unionVarSet`
 218                                                 spec_ids
 219
 220     idinfo         = idInfo id
 221     dont_inline    = isNeverInlinePrag (inlinePragInfo idinfo)
 222     loop_breaker   = isLoopBreaker (occInfo idinfo)
 223     bottoming_fn   = isBottomingStrictness (strictnessInfo idinfo)
 224     spec_ids       = rulesRhsFreeVars (specInfo idinfo)
 225     worker_info    = workerInfo idinfo
 226
 227         -- Stuff to do with the Id's unfolding
 228         -- The simplifier has put an up-to-date unfolding
 229         -- in the IdInfo, but the RHS will do just as well
 230     unfolding    = unfoldingInfo idinfo
 231     rhs_is_small = not (neverUnfold unfolding)
 232
 233         -- We leave the unfolding there even if there is a worker
 234         -- In GHCI the unfolding is used by importers
 235         -- When writing an interface file, we omit the unfolding
 236         -- if there is a worker
 237     show_unfold = not bottoming_fn       &&     -- Not necessary
 238                   not dont_inline        &&
 239                   not loop_breaker       &&
 240                   rhs_is_small           &&     -- Small enough
 241                   okToUnfoldInHiFile rhs        -- No casms etc
 242
 243     unfold_ids | show_unfold = exprSomeFreeVars isIdAndLocal rhs
 244                | otherwise   = emptyVarSet
 245
 246     worker_ids = case worker_info of
 247                    HasWorker work_id _ -> unitVarSet work_id
 248                    otherwise           -> emptyVarSet
 249 \end{code}
 250
 251
 252 %************************************************************************
 253 %*                                                                      *
 254 \subsection{Step 2: top-level tidying}
 255 %*                                                                      *
 256 %************************************************************************
 257
 258
 259 \begin{code}
 260 type TopTidyEnv = (UniqSupply, OrigNameCache, TidyOccEnv, VarEnv Var)
 261
 262 -- TopTidyEnv: when tidying we need to know
 263 --   * orig_env: Any pre-ordained Names.  These may have arisen because the
 264 --        renamer read in an interface file mentioning M.$wf, say,
 265 --        and assigned it unique r77.  If, on this compilation, we've
 266 --        invented an Id whose name is $wf (but with a different unique)
 267 --        we want to rename it to have unique r77, so that we can do easy
 268 --        comparisons with stuff from the interface file
 269 --
 270 --   * occ_env: The TidyOccEnv, which tells us which local occurrences
 271 --     are 'used'
 272 --
 273 --   * subst_env: A Var->Var mapping that substitutes the new Var for the old
 274 --
 275 --   * uniqsuppy: so we can clone any Ids with non-preordained names.
 276 --
 277 \end{code}
 278
 279
 280 \begin{code}
 281 tidyTopBind :: Module
 282             -> IdEnv Bool       -- Domain = Ids that should be external
 283                                 -- True <=> their unfolding is external too
 284             -> TopTidyEnv -> CoreBind
 285             -> (TopTidyEnv, CoreBind)
 286
 287 tidyTopBind mod ext_ids env (NonRec bndr rhs)
 288   = ((us2,orig,occ,subst) , NonRec bndr' rhs')
 289   where
 290     ((us1,orig,occ,subst), bndr')
 291          = tidyTopBinder mod ext_ids tidy_env rhs' caf_info env bndr
 292     tidy_env    = (occ,subst)
 293     caf_info    = hasCafRefs (const True) rhs'
 294     (rhs',us2)  = initUs us1 (tidyExpr tidy_env rhs)
 295
 296 tidyTopBind mod ext_ids env (Rec prs)
 297   = (final_env, Rec prs')
 298   where
 299     (final_env@(_,_,occ,subst), prs') = mapAccumL do_one env prs
 300     final_tidy_env = (occ,subst)
 301
 302     do_one env (bndr,rhs)
 303         = ((us',orig,occ,subst), (bndr',rhs'))
 304         where
 305         ((us,orig,occ,subst), bndr')
 306            = tidyTopBinder mod ext_ids final_tidy_env rhs' caf_info env bndr
 307         (rhs', us')   = initUs us (tidyExpr final_tidy_env rhs)
 308
 309         -- the CafInfo for a recursive group says whether *any* rhs in
 310         -- the group may refer indirectly to a CAF (because then, they all do).
 311     (bndrs, rhss) = unzip prs'
 312     caf_info = hasCafRefss pred rhss
 313     pred v = v `notElem` bndrs
 314
 315
 316 tidyTopBinder :: Module -> IdEnv Bool
 317               -> TidyEnv -> CoreExpr -> CafInfo
 318                         -- The TidyEnv is used to tidy the IdInfo
 319                         -- The expr is the already-tided RHS
 320                         -- Both are knot-tied: don't look at them!
 321               -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
 322
 323 tidyTopBinder mod ext_ids tidy_env rhs caf_info
 324               env@(us, orig_env2, occ_env2, subst_env2) id
 325
 326   | isImplicitId id     -- Don't mess with constructors,
 327   = (env, id)           -- record selectors, and the like
 328
 329   | otherwise
 330         -- This function is the heart of Step 2
 331         -- The second env is the one to use for the IdInfo
 332         -- It's necessary because when we are dealing with a recursive
 333         -- group, a variable late in the group might be mentioned
 334         -- in the IdInfo of one early in the group
 335
 336         -- The rhs is already tidied
 337
 338   = ((us_r, orig_env', occ_env', subst_env'), id')
 339   where
 340     (us_l, us_r)    = splitUniqSupply us
 341
 342     (orig_env', occ_env', name') = tidyTopName mod orig_env2 occ_env2
 343                                                is_external
 344                                                (idName id)
 345     ty'             = tidyTopType (idType id)
 346     idinfo'         = tidyIdInfo us_l tidy_env
 347                          is_external unfold_info arity_info caf_info id
 348
 349     id'        = mkId name' ty' idinfo'
 350     subst_env' = extendVarEnv subst_env2 id id'
 351
 352     maybe_external = lookupVarEnv ext_ids id
 353     is_external    = maybeToBool maybe_external
 354
 355     -- Expose an unfolding if ext_ids tells us to
 356     show_unfold = maybe_external `orElse` False
 357     unfold_info | show_unfold = mkTopUnfolding rhs
 358                 | otherwise   = noUnfolding
 359
 360     arity_info = exprArity rhs
 361
 362
 363 tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
 364   | opt_OmitInterfacePragmas || not is_external
 365         -- No IdInfo if the Id isn't external, or if we don't have -O
 366   = mkIdInfo new_flavour caf_info
 367         `setStrictnessInfo` strictnessInfo core_idinfo
 368         `setArityInfo`      ArityExactly arity_info
 369         -- Keep strictness, arity and CAF info; it's used by the code generator
 370
 371   | otherwise
 372   =  let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
 373      in
 374      mkIdInfo new_flavour caf_info
 375         `setCprInfo`        cprInfo core_idinfo
 376         `setStrictnessInfo` strictnessInfo core_idinfo
 377         `setInlinePragInfo` inlinePragInfo core_idinfo
 378         `setUnfoldingInfo`  unfold_info
 379         `setWorkerInfo`     tidyWorker tidy_env arity_info (workerInfo core_idinfo)
 380         `setSpecInfo`       rules'
 381         `setArityInfo`      ArityExactly arity_info
 382                 -- this is the final IdInfo, it must agree with the
 383                 -- code finally generated (i.e. NO more transformations
 384                 -- after this!).
 385   where
 386     core_idinfo = idInfo id
 387
 388         -- A DFunId must stay a DFunId, so that we can gather the
 389         -- DFunIds up later.  Other local things become ConstantIds.
 390     new_flavour = case flavourInfo core_idinfo of
 391                     VanillaId  -> ConstantId
 392                     ExportedId -> ConstantId
 393                     ConstantId -> ConstantId    -- e.g. Default methods
 394                     DictFunId  -> DictFunId
 395                     flavour    -> pprTrace "tidyIdInfo" (ppr id <+> ppFlavourInfo flavour)
 396                                   flavour
 397
 398
 399 -- This is where we set names to local/global based on whether they really are
 400 -- externally visible (see comment at the top of this module).  If the name
 401 -- was previously local, we have to give it a unique occurrence name if
 402 -- we intend to globalise it.
 403 tidyTopName mod orig_env occ_env external name
 404   | global && internal = (orig_env, occ_env, localiseName name)
 405
 406   | local  && internal = (orig_env, occ_env', setNameOcc name occ')
 407         -- Even local, internal names must get a unique occurrence, because
 408         -- if we do -split-objs we globalise the name later, n the code generator
 409
 410   | global && external = (orig_env, occ_env, name)
 411         -- Global names are assumed to have been allocated by the renamer,
 412         -- so they already have the "right" unique
 413
 414   | local  && external = case lookupFM orig_env key of
 415                            Just orig -> (orig_env,                         occ_env', orig)
 416                            Nothing   -> (addToFM orig_env key global_name, occ_env', global_name)
 417         -- If we want to globalise a currently-local name, check
 418         -- whether we have already assigned a unique for it.
 419         -- If so, use it; if not, extend the table
 420
 421   where
 422     (occ_env', occ') = tidyOccName occ_env (nameOccName name)
 423     key              = (moduleName mod, occ')
 424     global_name      = globaliseName (setNameOcc name occ') mod
 425     global           = isGlobalName name
 426     local            = not global
 427     internal         = not external
 428
 429 ------------  Worker  --------------
 430 -- We only treat a function as having a worker if
 431 -- the exported arity (which is now the number of visible lambdas)
 432 -- is the same as the arity at the moment of the w/w split
 433 -- If so, we can safely omit the unfolding inside the wrapper, and
 434 -- instead re-generate it from the type/arity/strictness info
 435 -- But if the arity has changed, we just take the simple path and
 436 -- put the unfolding into the interface file, forgetting the fact
 437 -- that it's a wrapper.
 438 --
 439 -- How can this happen?  Sometimes we get
 440 --      f = coerce t (\x y -> $wf x y)
 441 -- at the moment of w/w split; but the eta reducer turns it into
 442 --      f = coerce t $wf
 443 -- which is perfectly fine except that the exposed arity so far as
 444 -- the code generator is concerned (zero) differs from the arity
 445 -- when we did the split (2).
 446 --
 447 -- All this arises because we use 'arity' to mean "exactly how many
 448 -- top level lambdas are there" in interface files; but during the
 449 -- compilation of this module it means "how many things can I apply
 450 -- this to".
 451 tidyWorker tidy_env real_arity (HasWorker work_id wrap_arity)
 452   | real_arity == wrap_arity
 453   = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
 454 tidyWorker tidy_env real_arity other
 455   = NoWorker
 456
 457 ------------  Rules  --------------
 458 tidyIdRules :: TidyEnv -> [IdCoreRule] -> UniqSM [IdCoreRule]
 459 tidyIdRules env [] = returnUs []
 460 tidyIdRules env ((fn,rule) : rules)
 461   = tidyRule env rule           `thenUs` \ rule ->
 462     tidyIdRules env rules       `thenUs` \ rules ->
 463     returnUs ((tidyVarOcc env fn, rule) : rules)
 464
 465 tidyRules :: TidyEnv -> CoreRules -> UniqSM CoreRules
 466 tidyRules env (Rules rules fvs)
 467   = mapUs (tidyRule env) rules          `thenUs` \ rules ->
 468     returnUs (Rules rules (foldVarSet tidy_set_elem emptyVarSet fvs))
 469   where
 470     tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
 471
 472 tidyRule :: TidyEnv -> CoreRule -> UniqSM CoreRule
 473 tidyRule env rule@(BuiltinRule _) = returnUs rule
 474 tidyRule env (Rule name vars tpl_args rhs)
 475   = tidyBndrs env vars                  `thenUs` \ (env', vars) ->
 476     mapUs (tidyExpr env') tpl_args      `thenUs` \ tpl_args ->
 477     tidyExpr env' rhs                   `thenUs` \ rhs ->
 478     returnUs (Rule name vars tpl_args rhs)
 479 \end{code}
 480
 481 %************************************************************************
 482 %*                                                                      *
 483 \subsection{Step 2: inner tidying
 484 %*                                                                      *
 485 %************************************************************************
 486
 487 \begin{code}
 488 tidyBind :: TidyEnv
 489          -> CoreBind
 490          -> UniqSM (TidyEnv, CoreBind)
 491 tidyBind env (NonRec bndr rhs)
 492   = tidyBndrWithRhs env (bndr,rhs) `thenUs` \ (env', bndr') ->
 493     tidyExpr env' rhs              `thenUs` \ rhs' ->
 494     returnUs (env', NonRec bndr' rhs')
 495
 496 tidyBind env (Rec prs)
 497   = mapAccumLUs tidyBndrWithRhs env prs         `thenUs` \ (env', bndrs') ->
 498     mapUs (tidyExpr env') (map snd prs)         `thenUs` \ rhss' ->
 499     returnUs (env', Rec (zip bndrs' rhss'))
 500
 501 tidyExpr env (Var v)
 502   = fiddleCCall v  `thenUs` \ v ->
 503     returnUs (Var (tidyVarOcc env v))
 504
 505 tidyExpr env (Type ty) = returnUs (Type (tidyType env ty))
 506 tidyExpr env (Lit lit) = returnUs (Lit lit)
 507
 508 tidyExpr env (App f a)
 509   = tidyExpr env f              `thenUs` \ f ->
 510     tidyExpr env a              `thenUs` \ a ->
 511     returnUs (App f a)
 512
 513 tidyExpr env (Note n e)
 514   = tidyExpr env e              `thenUs` \ e ->
 515     returnUs (Note (tidyNote env n) e)
 516
 517 tidyExpr env (Let b e)
 518   = tidyBind env b              `thenUs` \ (env', b') ->
 519     tidyExpr env' e             `thenUs` \ e ->
 520     returnUs (Let b' e)
 521
 522 tidyExpr env (Case e b alts)
 523   = tidyExpr env e              `thenUs` \ e ->
 524     tidyBndr env b              `thenUs` \ (env', b) ->
 525     mapUs (tidyAlt env') alts   `thenUs` \ alts ->
 526     returnUs (Case e b alts)
 527
 528 tidyExpr env (Lam b e)
 529   = tidyBndr env b              `thenUs` \ (env', b) ->
 530     tidyExpr env' e             `thenUs` \ e ->
 531     returnUs (Lam b e)
 532
 533
 534 tidyAlt env (con, vs, rhs)
 535   = tidyBndrs env vs            `thenUs` \ (env', vs) ->
 536     tidyExpr env' rhs           `thenUs` \ rhs ->
 537     returnUs (con, vs, rhs)
 538
 539 tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
 540 tidyNote env note            = note
 541 \end{code}
 542
 543
 544 %************************************************************************
 545 %*                                                                      *
 546 \subsection{Tidying up non-top-level binders}
 547 %*                                                                      *
 548 %************************************************************************
 549
 550 \begin{code}
 551 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
 552                                   Just v' -> v'
 553                                   Nothing -> v
 554
 555 -- tidyBndr is used for lambda and case binders
 556 tidyBndr :: TidyEnv -> Var -> UniqSM (TidyEnv, Var)
 557 tidyBndr env var
 558   | isTyVar var = returnUs (tidyTyVar env var)
 559   | otherwise   = tidyId env var vanillaIdInfo
 560
 561 tidyBndrs :: TidyEnv -> [Var] -> UniqSM (TidyEnv, [Var])
 562 tidyBndrs env vars = mapAccumLUs tidyBndr env vars
 563
 564 -- tidyBndrWithRhs is used for let binders
 565 tidyBndrWithRhs :: TidyEnv -> (Var, CoreExpr) -> UniqSM (TidyEnv, Var)
 566 tidyBndrWithRhs env (id,rhs)
 567    = tidyId env id idinfo
 568    where
 569         idinfo = vanillaIdInfo `setArityInfo` ArityExactly (exprArity rhs)
 570                         -- NB: This throws away the IdInfo of the Id, which we
 571                         -- no longer need.  That means we don't need to
 572                         -- run over it with env, nor renumber it.
 573
 574 tidyId :: TidyEnv -> Id -> IdInfo -> UniqSM (TidyEnv, Id)
 575 tidyId env@(tidy_env, var_env) id idinfo
 576   =     -- Non-top-level variables
 577     getUniqueUs   `thenUs` \ uniq ->
 578     let
 579         -- Give the Id a fresh print-name, *and* rename its type
 580         -- The SrcLoc isn't important now,
 581         -- though we could extract it from the Id
 582         name'             = mkLocalName uniq occ' noSrcLoc
 583         (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
 584         ty'               = tidyType (tidy_env,var_env) (idType id)
 585         id'               = mkId name' ty' idinfo
 586         var_env'          = extendVarEnv var_env id id'
 587     in
 588     returnUs ((tidy_env', var_env'), id')
 589
 590
 591 fiddleCCall id
 592   = case idFlavour id of
 593          PrimOpId (CCallOp ccall) ->
 594             -- Make a guaranteed unique name for a dynamic ccall.
 595             getUniqueUs         `thenUs` \ uniq ->
 596             returnUs (modifyIdInfo (`setFlavourInfo`
 597                             PrimOpId (CCallOp (setCCallUnique ccall uniq))) id)
 598          other_flavour ->
 599              returnUs id
 600 \end{code}
 601
 602 %************************************************************************
 603 %*                                                                      *
 604 \subsection{Figuring out CafInfo for an expression}
 605 %*                                                                      *
 606 %************************************************************************
 607
 608 \begin{code}
 609 hasCafRefs  :: (Id -> Bool) -> CoreExpr -> CafInfo
 610 hasCafRefss :: (Id -> Bool) -> [CoreExpr] -> CafInfo
 611         -- predicate returns True for a given Id if we look at this Id when
 612         -- calculating the result.  Used to *avoid* looking at the CafInfo
 613         -- field for an Id that is part of the current recursive group.
 614
 615 hasCafRefs p expr = if isCAF expr || isFastTrue (cafRefs p expr)
 616                         then MayHaveCafRefs
 617                         else NoCafRefs
 618
 619         -- used for recursive groups.  The whole group is set to
 620         -- "MayHaveCafRefs" if at least one of the group is a CAF or
 621         -- refers to any CAFs.
 622 hasCafRefss p exprs = if any isCAF exprs || isFastTrue (cafRefss p exprs)
 623                         then MayHaveCafRefs
 624                         else NoCafRefs
 625
 626 cafRefs p (Var id)
 627  | p id
 628  = case idCafInfo id of
 629         NoCafRefs      -> fastBool False
 630         MayHaveCafRefs -> fastBool True
 631  | otherwise
 632  = fastBool False
 633
 634 cafRefs p (Lit l)            = fastBool False
 635 cafRefs p (App f a)          = cafRefs p f `fastOr` cafRefs p a
 636 cafRefs p (Lam x e)          = cafRefs p e
 637 cafRefs p (Let b e)          = cafRefss p (rhssOfBind b) `fastOr` cafRefs p e
 638 cafRefs p (Case e bndr alts) = cafRefs p e `fastOr` cafRefss p (rhssOfAlts alts)
 639 cafRefs p (Note n e)         = cafRefs p e
 640 cafRefs p (Type t)           = fastBool False
 641
 642 cafRefss p []     = fastBool False
 643 cafRefss p (e:es) = cafRefs p e `fastOr` cafRefss p es
 644
 645 -- Decide whether a closure looks like a CAF or not.  In an effort to
 646 -- keep the number of CAFs (and hence the size of the SRTs) down, we
 647 -- would also like to look at the expression and decide whether it
 648 -- requires a small bounded amount of heap, so we can ignore it as a
 649 -- CAF.  In these cases however, we would need to use an additional
 650 -- CAF list to keep track of non-collectable CAFs.
 651
 652 -- We mark real CAFs as `MayHaveCafRefs' because this information is
 653 -- used to decide whether a particular closure needs to be referenced
 654 -- in an SRT or not.
 655
 656 isCAF :: CoreExpr -> Bool
 657    -- special case for expressions which are always bottom,
 658    -- such as 'error "..."'.  We don't need to record it as
 659    -- a CAF, since it can only be entered once.
 660 isCAF e
 661   | not_function && is_bottom = False
 662   | not_function && updatable = True
 663   | otherwise                 = False
 664   where
 665     not_function = exprArity e == 0
 666     is_bottom    = exprIsBottom e
 667     updatable    = True {- ToDo: check type for onceness? -}
 668 \end{code}