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