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