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