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, omitIfaceSigForId,
  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                           OrigNameEnv( origNames ), OrigNameNameEnv
  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 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
 101
 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.
 105
 106 \begin{code}
 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"
 113
 114         ; let ext_ids = findExternalSet binds_in orphans_in
 115
 116         ; us <- mkSplitUniqSupply 't' -- for "tidy"
 117
 118         ; let ((us1, orig_env', occ_env, subst_env), binds_out)
 119                         = mapAccumL (tidyTopBind mod ext_ids)
 120                                     (init_tidy_env us) binds_in
 121
 122         ; let (orphans_out, _)
 123                    = initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in)
 124
 125         ; let prs' = prs { prsOrig = orig { origNames = orig_env' } }
 126               pcs' = pcs { pcs_PRS = prs' }
 127
 128         ; endPass dflags "Tidy Core" Opt_D_dump_simpl binds_out
 129
 130         ; return (pcs', binds_out, orphans_out)
 131         }
 132   where
 133         -- We also make sure to avoid any exported binders.  Consider
 134         --      f{-u1-} = 1     -- Local decl
 135         --      ...
 136         --      f{-u2-} = 2     -- Exported decl
 137         --
 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.
 141     prs              = pcs_PRS pcs
 142     orig             = prsOrig prs
 143     orig_env         = origNames orig
 144
 145     init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv)
 146     avoids           = [getOccName bndr | bndr <- bindersOfBinds binds_in,
 147                                        isGlobalName (idName bndr)]
 148 \end{code}
 149
 150
 151 %************************************************************************
 152 %*                                                                      *
 153 \subsection{Step 1: finding externals}
 154 %*                                                                      *
 155 %************************************************************************
 156
 157 \begin{code}
 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
 163   where
 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.)
 173
 174     find (NonRec id rhs) needed
 175         | need_id needed id = addExternal (id,rhs) needed
 176         | otherwise         = needed
 177     find (Rec prs) needed   = find_prs prs needed
 178
 179         -- For a recursive group we have to look for a fixed point
 180     find_prs prs needed
 181         | null needed_prs = needed
 182         | otherwise       = find_prs other_prs new_needed
 183         where
 184           (needed_prs, other_prs) = partition (need_pr needed) prs
 185           new_needed = foldr addExternal needed needed_prs
 186
 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
 192
 193 isIdAndLocal id = isId id && isLocalId id
 194
 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)
 200                  id show_unfold
 201   where
 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
 205
 206     new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
 207                    | otherwise                = worker_ids      `unionVarSet`
 208                                                 unfold_ids      `unionVarSet`
 209                                                 spec_ids
 210
 211     idinfo         = idInfo id
 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
 217
 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)
 223
 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
 229                   not dont_inline        &&
 230                   not loop_breaker       &&
 231                   rhs_is_small           &&     -- Small enough
 232                   okToUnfoldInHiFile rhs        -- No casms etc
 233
 234     unfold_ids | show_unfold = exprSomeFreeVars isIdAndLocal rhs
 235                | otherwise   = emptyVarSet
 236
 237     worker_ids = case worker_info of
 238                    HasWorker work_id _ -> unitVarSet work_id
 239                    otherwise           -> emptyVarSet
 240 \end{code}
 241
 242
 243 %************************************************************************
 244 %*                                                                      *
 245 \subsection{Step 2: top-level tidying}
 246 %*                                                                      *
 247 %************************************************************************
 248
 249
 250 \begin{code}
 251 type TopTidyEnv = (UniqSupply, OrigNameNameEnv, TidyOccEnv, VarEnv Var)
 252
 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
 260 --
 261 --   * occ_env: The TidyOccEnv, which tells us which local occurrences
 262 --     are 'used'
 263 --
 264 --   * subst_env: A Var->Var mapping that substitutes the new Var for the old
 265 --
 266 --   * uniqsuppy: so we can clone any Ids with non-preordained names.
 267 --
 268 \end{code}
 269
 270
 271 \begin{code}
 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)
 277
 278 tidyTopBind mod ext_ids env (NonRec bndr rhs)
 279   = ((us2,orig,occ,subst) , NonRec bndr' rhs')
 280   where
 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)
 286
 287 tidyTopBind mod ext_ids env (Rec prs)
 288   = (final_env, Rec prs')
 289   where
 290     (final_env@(_,_,occ,subst), prs') = mapAccumL do_one env prs
 291     final_tidy_env = (occ,subst)
 292
 293     do_one env (bndr,rhs)
 294         = ((us',orig,occ,subst), (bndr',rhs'))
 295         where
 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)
 299
 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
 305
 306
 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)
 313
 314 tidyTopBinder mod ext_ids tidy_env rhs caf_info
 315               env@(us, orig_env2, occ_env2, subst_env2) id
 316
 317   | omitIfaceSigForId id        -- Don't mess with constructors,
 318   = (env, id)                   -- record selectors, and the like
 319
 320   | otherwise
 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
 326
 327         -- The rhs is already tidied
 328
 329   = ((us_r, orig_env', occ_env', subst_env'), id')
 330   where
 331     (us_l, us_r)    = splitUniqSupply us
 332
 333     (orig_env', occ_env', name') = tidyTopName mod orig_env2 occ_env2
 334                                                is_external
 335                                                (idName id)
 336     ty'             = tidyTopType (idType id)
 337     idinfo'         = tidyIdInfo us_l tidy_env
 338                          is_external unfold_info arity_info caf_info id
 339
 340     id'        = mkId name' ty' idinfo'
 341     subst_env' = extendVarEnv subst_env2 id id'
 342
 343     maybe_external = lookupVarEnv ext_ids id
 344     is_external    = maybeToBool maybe_external
 345
 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
 350
 351     arity_info = exprArity rhs
 352
 353
 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
 362
 363   | otherwise
 364   =  let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
 365      in
 366      mkIdInfo new_flavour
 367         `setCprInfo`        cprInfo core_idinfo
 368         `setStrictnessInfo` strictnessInfo core_idinfo
 369         `setInlinePragInfo` inlinePragInfo core_idinfo
 370         `setUnfoldingInfo`  unfold_info
 371         `setWorkerInfo`     tidyWorker tidy_env (workerInfo core_idinfo)
 372         `setSpecInfo`       rules'
 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
 377                 -- after this!).
 378   where
 379     core_idinfo = idInfo id
 380
 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)
 389                                   flavour
 390
 391 -- This is where we set names to local/global based on whether they really are
 392 -- externally visible (see comment at the top of this module).  If the name
 393 -- was previously local, we have to give it a unique occurrence name if
 394 -- we intend to globalise it.
 395 tidyTopName mod orig_env occ_env external name
 396   | global && internal = (orig_env, occ_env, localiseName name)
 397
 398   | local  && internal = (orig_env, occ_env', setNameOcc name occ')
 399         -- Even local, internal names must get a unique occurrence, because
 400         -- if we do -split-objs we globalise the name later, n the code generator
 401
 402   | global && external = (orig_env, occ_env, name)
 403         -- Global names are assumed to have been allocated by the renamer,
 404         -- so they already have the "right" unique
 405
 406   | local  && external = case lookupFM orig_env key of
 407                            Just orig -> (orig_env,                         occ_env', orig)
 408                            Nothing   -> (addToFM orig_env key global_name, occ_env', global_name)
 409         -- If we want to globalise a currently-local name, check
 410         -- whether we have already assigned a unique for it.
 411         -- If so, use it; if not, extend the table
 412
 413   where
 414     (occ_env', occ') = tidyOccName occ_env (nameOccName name)
 415     key              = (moduleName mod, occ')
 416     global_name      = globaliseName (setNameOcc name occ') mod
 417     global           = isGlobalName name
 418     local            = not global
 419     internal         = not external
 420
 421 tidyIdRules :: TidyEnv -> [IdCoreRule] -> UniqSM [IdCoreRule]
 422 tidyIdRules env [] = returnUs []
 423 tidyIdRules env ((fn,rule) : rules)
 424   = tidyRule env rule           `thenUs` \ rule ->
 425     tidyIdRules env rules       `thenUs` \ rules ->
 426     returnUs ((tidyVarOcc env fn, rule) : rules)
 427
 428 tidyWorker tidy_env (HasWorker work_id wrap_arity)
 429   = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
 430 tidyWorker tidy_env NoWorker
 431   = NoWorker
 432
 433 tidyRules :: TidyEnv -> CoreRules -> UniqSM CoreRules
 434 tidyRules env (Rules rules fvs)
 435   = mapUs (tidyRule env) rules          `thenUs` \ rules ->
 436     returnUs (Rules rules (foldVarSet tidy_set_elem emptyVarSet fvs))
 437   where
 438     tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
 439
 440 tidyRule :: TidyEnv -> CoreRule -> UniqSM CoreRule
 441 tidyRule env rule@(BuiltinRule _) = returnUs rule
 442 tidyRule env (Rule name vars tpl_args rhs)
 443   = tidyBndrs env vars                  `thenUs` \ (env', vars) ->
 444     mapUs (tidyExpr env') tpl_args      `thenUs` \ tpl_args ->
 445     tidyExpr env' rhs                   `thenUs` \ rhs ->
 446     returnUs (Rule name vars tpl_args rhs)
 447 \end{code}
 448
 449 %************************************************************************
 450 %*                                                                      *
 451 \subsection{Step 2: inner tidying
 452 %*                                                                      *
 453 %************************************************************************
 454
 455 \begin{code}
 456 tidyBind :: TidyEnv
 457          -> CoreBind
 458          -> UniqSM (TidyEnv, CoreBind)
 459 tidyBind env (NonRec bndr rhs)
 460   = tidyBndrWithRhs env (bndr,rhs) `thenUs` \ (env', bndr') ->
 461     tidyExpr env' rhs              `thenUs` \ rhs' ->
 462     returnUs (env', NonRec bndr' rhs')
 463
 464 tidyBind env (Rec prs)
 465   = mapAccumLUs tidyBndrWithRhs env prs         `thenUs` \ (env', bndrs') ->
 466     mapUs (tidyExpr env') (map snd prs)         `thenUs` \ rhss' ->
 467     returnUs (env', Rec (zip bndrs' rhss'))
 468
 469 tidyExpr env (Var v)
 470   = fiddleCCall v  `thenUs` \ v ->
 471     returnUs (Var (tidyVarOcc env v))
 472
 473 tidyExpr env (Type ty) = returnUs (Type (tidyType env ty))
 474 tidyExpr env (Lit lit) = returnUs (Lit lit)
 475
 476 tidyExpr env (App f a)
 477   = tidyExpr env f              `thenUs` \ f ->
 478     tidyExpr env a              `thenUs` \ a ->
 479     returnUs (App f a)
 480
 481 tidyExpr env (Note n e)
 482   = tidyExpr env e              `thenUs` \ e ->
 483     returnUs (Note (tidyNote env n) e)
 484
 485 tidyExpr env (Let b e)
 486   = tidyBind env b              `thenUs` \ (env', b') ->
 487     tidyExpr env' e             `thenUs` \ e ->
 488     returnUs (Let b' e)
 489
 490 tidyExpr env (Case e b alts)
 491   = tidyExpr env e              `thenUs` \ e ->
 492     tidyBndr env b              `thenUs` \ (env', b) ->
 493     mapUs (tidyAlt env') alts   `thenUs` \ alts ->
 494     returnUs (Case e b alts)
 495
 496 tidyExpr env (Lam b e)
 497   = tidyBndr env b              `thenUs` \ (env', b) ->
 498     tidyExpr env' e             `thenUs` \ e ->
 499     returnUs (Lam b e)
 500
 501
 502 tidyAlt env (con, vs, rhs)
 503   = tidyBndrs env vs            `thenUs` \ (env', vs) ->
 504     tidyExpr env' rhs           `thenUs` \ rhs ->
 505     returnUs (con, vs, rhs)
 506
 507 tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
 508 tidyNote env note            = note
 509 \end{code}
 510
 511
 512 %************************************************************************
 513 %*                                                                      *
 514 \subsection{Tidying up non-top-level binders}
 515 %*                                                                      *
 516 %************************************************************************
 517
 518 \begin{code}
 519 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
 520                                   Just v' -> v'
 521                                   Nothing -> v
 522
 523 -- tidyBndr is used for lambda and case binders
 524 tidyBndr :: TidyEnv -> Var -> UniqSM (TidyEnv, Var)
 525 tidyBndr env var
 526   | isTyVar var = returnUs (tidyTyVar env var)
 527   | otherwise   = tidyId env var (vanillaIdInfo `setCafInfo` NoCafRefs)
 528
 529 tidyBndrs :: TidyEnv -> [Var] -> UniqSM (TidyEnv, [Var])
 530 tidyBndrs env vars = mapAccumLUs tidyBndr env vars
 531
 532 -- tidyBndrWithRhs is used for let binders
 533 tidyBndrWithRhs :: TidyEnv -> (Var, CoreExpr) -> UniqSM (TidyEnv, Var)
 534 tidyBndrWithRhs env (id,rhs)
 535    = tidyId env id idinfo
 536    where
 537         idinfo = vanillaIdInfo `setArityInfo` ArityExactly (exprArity rhs)
 538                                `setCafInfo` NoCafRefs
 539                         -- NB: This throws away the IdInfo of the Id, which we
 540                         -- no longer need.  That means we don't need to
 541                         -- run over it with env, nor renumber it.
 542
 543 tidyId :: TidyEnv -> Id -> IdInfo -> UniqSM (TidyEnv, Id)
 544 tidyId env@(tidy_env, var_env) id idinfo
 545   =     -- Non-top-level variables
 546     getUniqueUs   `thenUs` \ uniq ->
 547     let
 548         -- Give the Id a fresh print-name, *and* rename its type
 549         -- The SrcLoc isn't important now,
 550         -- though we could extract it from the Id
 551         name'             = mkLocalName uniq occ' noSrcLoc
 552         (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
 553         ty'               = tidyType (tidy_env,var_env) (idType id)
 554         id'               = mkId name' ty' idinfo
 555         var_env'          = extendVarEnv var_env id id'
 556     in
 557     returnUs ((tidy_env', var_env'), id')
 558
 559
 560 fiddleCCall id
 561   = case idFlavour id of
 562          PrimOpId (CCallOp ccall) ->
 563             -- Make a guaranteed unique name for a dynamic ccall.
 564             getUniqueUs         `thenUs` \ uniq ->
 565             returnUs (modifyIdInfo (`setFlavourInfo`
 566                             PrimOpId (CCallOp (setCCallUnique ccall uniq))) id)
 567          other_flavour ->
 568              returnUs id
 569 \end{code}
 570
 571 %************************************************************************
 572 %*                                                                      *
 573 \subsection{Figuring out CafInfo for an expression}
 574 %*                                                                      *
 575 %************************************************************************
 576
 577 \begin{code}
 578 hasCafRefs  :: (Id -> Bool) -> CoreExpr -> CafInfo
 579 hasCafRefss :: (Id -> Bool) -> [CoreExpr] -> CafInfo
 580         -- predicate returns True for a given Id if we look at this Id when
 581         -- calculating the result.  Used to *avoid* looking at the CafInfo
 582         -- field for an Id that is part of the current recursive group.
 583
 584 hasCafRefs p expr = if isCAF expr || isFastTrue (cafRefs p expr)
 585                         then MayHaveCafRefs
 586                         else NoCafRefs
 587
 588 hasCafRefss p exprs = if any isCAF exprs || isFastTrue (cafRefss p exprs)
 589                         then MayHaveCafRefs
 590                         else NoCafRefs
 591
 592 cafRefs p (Var id)
 593  | p id
 594  = case idCafInfo id of
 595         NoCafRefs      -> fastBool False
 596         MayHaveCafRefs -> fastBool True
 597  | otherwise
 598  = fastBool False
 599
 600 cafRefs p (Lit l)            = fastBool False
 601 cafRefs p (App f a)          = cafRefs p f `fastOr` cafRefs p a
 602 cafRefs p (Lam x e)          = cafRefs p e
 603 cafRefs p (Let b e)          = cafRefss p (rhssOfBind b) `fastOr` cafRefs p e
 604 cafRefs p (Case e bndr alts) = cafRefs p e `fastOr` cafRefss p (rhssOfAlts alts)
 605 cafRefs p (Note n e)         = cafRefs p e
 606 cafRefs p (Type t)           = fastBool False
 607
 608 cafRefss p []     = fastBool False
 609 cafRefss p (e:es) = cafRefs p e `fastOr` cafRefss p es
 610
 611 -- Decide whether a closure looks like a CAF or not.  In an effort to
 612 -- keep the number of CAFs (and hence the size of the SRTs) down, we
 613 -- would also like to look at the expression and decide whether it
 614 -- requires a small bounded amount of heap, so we can ignore it as a CAF.
 615 -- In these cases, we need to use an additional CAF list to keep track of
 616 -- non-collectable CAFs.
 617 --
 618 -- We mark real CAFs as `MayHaveCafRefs' because this information is used
 619 -- to decide whether a particular closure needs to be referenced in an
 620 -- SRT or not.
 621
 622 isCAF :: CoreExpr -> Bool
 623    -- special case for expressions which are always bottom,
 624    -- such as 'error "..."'.  We don't need to record it as
 625    -- a CAF, since it can only be entered once.
 626 isCAF e
 627   | not_function && is_bottom = False
 628   | not_function && updatable = True
 629   | otherwise                 = False
 630   where
 631     not_function = exprArity e == 0
 632     is_bottom    = exprIsBottom e
 633     updatable    = True {- ToDo: check type for onceness? -}
 634 \end{code}