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, tidyCoreExpr,
   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 CoreFVs          ( ruleSomeFreeVars, exprSomeFreeVars )
  18 import PprCore          ( pprIdCoreRule )
  19 import CoreLint         ( showPass, endPass )
  20 import VarEnv
  21 import VarSet
  22 import Var              ( Id, Var )
  23 import Id               ( idType, idInfo, idName, isExportedId,
  24                           idSpecialisation, idUnique, isDataConWrapId,
  25                           mkVanillaGlobal, mkGlobalId, isLocalId,
  26                           isDataConId, mkUserLocal, isGlobalId, globalIdDetails,
  27                           idNewDemandInfo, setIdNewDemandInfo, setIdCgInfo,
  28                           idNewStrictness, setIdNewStrictness
  29                         )
  30 import IdInfo           {- loads of stuff -}
  31 import NewDemand        ( isBottomingSig, topSig )
  32 import BasicTypes       ( isNeverActive )
  33 import Name             ( getOccName, nameOccName, globaliseName, setNameOcc,
  34                           localiseName, isGlobalName, setNameUnique
  35                         )
  36 import NameEnv          ( filterNameEnv )
  37 import OccName          ( TidyOccEnv, initTidyOccEnv, tidyOccName )
  38 import Type             ( tidyTopType, tidyType, tidyTyVarBndr )
  39 import Module           ( Module, moduleName )
  40 import HscTypes         ( PersistentCompilerState( pcs_PRS ),
  41                           PersistentRenamerState( prsOrig ),
  42                           NameSupply( nsNames, nsUniqs ),
  43                           TypeEnv, extendTypeEnvList,
  44                           ModDetails(..), TyThing(..)
  45                         )
  46 import FiniteMap        ( lookupFM, addToFM )
  47 import Maybes           ( orElse )
  48 import ErrUtils         ( showPass, dumpIfSet_core )
  49 import SrcLoc           ( noSrcLoc )
  50 import UniqFM           ( mapUFM )
  51 import UniqSupply       ( splitUniqSupply, uniqFromSupply )
  52 import List             ( partition )
  53 import Util             ( mapAccumL )
  54 import Maybe            ( isJust )
  55 import Outputable
  56 \end{code}
  57
  58
  59
  60 %************************************************************************
  61 %*                                                                      *
  62 \subsection{What goes on}
  63 %*                                                                      *
  64 %************************************************************************
  65
  66 [SLPJ: 19 Nov 00]
  67
  68 The plan is this.
  69
  70 Step 1: Figure out external Ids
  71 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  72 First we figure out which Ids are "external" Ids.  An
  73 "external" Id is one that is visible from outside the compilation
  74 unit.  These are
  75         a) the user exported ones
  76         b) ones mentioned in the unfoldings, workers,
  77            or rules of externally-visible ones
  78 This exercise takes a sweep of the bindings bottom to top.  Actually,
  79 in Step 2 we're also going to need to know which Ids should be
  80 exported with their unfoldings, so we produce not an IdSet but an
  81 IdEnv Bool
  82
  83
  84 Step 2: Tidy the program
  85 ~~~~~~~~~~~~~~~~~~~~~~~~
  86 Next we traverse the bindings top to bottom.  For each *top-level*
  87 binder
  88
  89  1. Make it into a GlobalId
  90
  91  2. Give it a system-wide Unique.
  92     [Even non-exported things need system-wide Uniques because the
  93     byte-code generator builds a single Name->BCO symbol table.]
  94
  95     We use the NameSupply kept in the PersistentRenamerState as the
  96     source of such system-wide uniques.
  97
  98     For external Ids, use the original-name cache in the NameSupply
  99     to ensure that the unique assigned is the same as the Id had
 100     in any previous compilation run.
 101
 102  3. If it's an external Id, make it have a global Name, otherwise
 103     make it have a local Name.
 104     This is used by the code generator to decide whether
 105     to make the label externally visible
 106
 107  4. Give external Ids a "tidy" occurrence name.  This means
 108     we can print them in interface files without confusing
 109     "x" (unique 5) with "x" (unique 10).
 110
 111  5. Give it its UTTERLY FINAL IdInfo; in ptic,
 112         * Its IdDetails becomes VanillaGlobal, reflecting the fact that
 113           from now on we regard it as a global, not local, Id
 114
 115         * its unfolding, if it should have one
 116
 117         * its arity, computed from the number of visible lambdas
 118
 119         * its CAF info, computed from what is free in its RHS
 120
 121
 122 Finally, substitute these new top-level binders consistently
 123 throughout, including in unfoldings.  We also tidy binders in
 124 RHSs, so that they print nicely in interfaces.
 125
 126 \begin{code}
 127 tidyCorePgm :: DynFlags -> Module
 128             -> PersistentCompilerState
 129             -> CgInfoEnv                -- Information from the back end,
 130                                         -- to be splatted into the IdInfo
 131             -> ModDetails
 132             -> IO (PersistentCompilerState, ModDetails)
 133
 134 tidyCorePgm dflags mod pcs cg_info_env
 135             (ModDetails { md_types = env_tc, md_insts = insts_tc,
 136                           md_binds = binds_in, md_rules = orphans_in })
 137   = do  { showPass dflags "Tidy Core"
 138
 139         ; let ext_ids   = findExternalSet   binds_in orphans_in
 140         ; let ext_rules = findExternalRules binds_in orphans_in ext_ids
 141
 142         -- We also make sure to avoid any exported binders.  Consider
 143         --      f{-u1-} = 1     -- Local decl
 144         --      ...
 145         --      f{-u2-} = 2     -- Exported decl
 146         --
 147         -- The second exported decl must 'get' the name 'f', so we
 148         -- have to put 'f' in the avoids list before we get to the first
 149         -- decl.  tidyTopId then does a no-op on exported binders.
 150         ; let   prs           = pcs_PRS pcs
 151                 orig_ns       = prsOrig prs
 152
 153                 init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv)
 154                 avoids        = [getOccName bndr | bndr <- bindersOfBinds binds_in,
 155                                                    isGlobalName (idName bndr)]
 156
 157         ; let ((orig_ns', occ_env, subst_env), tidy_binds)
 158                         = mapAccumL (tidyTopBind mod ext_ids)
 159                                     init_tidy_env binds_in
 160
 161         ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
 162
 163         ; let prs' = prs { prsOrig = orig_ns' }
 164               pcs' = pcs { pcs_PRS = prs' }
 165
 166         ; let final_ids  = [ addCgInfo cg_info_env id
 167                            | bind <- tidy_binds
 168                            , id <- bindersOf bind
 169                            , isGlobalName (idName id)]
 170
 171                 -- Dfuns are local Ids that might have
 172                 -- changed their unique during tidying
 173         ; let lookup_dfun_id id = lookupVarEnv subst_env id `orElse`
 174                                   pprPanic "lookup_dfun_id" (ppr id)
 175
 176
 177         ; let tidy_type_env = mkFinalTypeEnv env_tc final_ids
 178               tidy_dfun_ids = map lookup_dfun_id insts_tc
 179
 180         ; let tidy_details = ModDetails { md_types = tidy_type_env,
 181                                           md_rules = tidy_rules,
 182                                           md_insts = tidy_dfun_ids,
 183                                           md_binds = tidy_binds }
 184
 185         ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
 186         ; dumpIfSet_core dflags Opt_D_dump_simpl
 187                 "Tidy Core Rules"
 188                 (vcat (map pprIdCoreRule tidy_rules))
 189
 190         ; return (pcs', tidy_details)
 191         }
 192
 193 addCgInfo :: CgInfoEnv -> Id -> Id
 194 -- Pin on the info that comes from the code generator
 195 -- This doesn't make its way into the *bindings* that
 196 -- go on to the code generator (that might give black holes etc)
 197 -- Rather, it's pinned onto the Id in the type environment
 198 -- that (a) generates the interface file
 199 --      (b) in GHCi goes into subsequent compilations
 200 addCgInfo cg_info_env id
 201   = id `setIdCgInfo` lookupCgInfo cg_info_env (idName id)
 202
 203 tidyCoreExpr :: CoreExpr -> IO CoreExpr
 204 tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr)
 205 \end{code}
 206
 207
 208 %************************************************************************
 209 %*                                                                      *
 210 \subsection{Write a new interface file}
 211 %*                                                                      *
 212 %************************************************************************
 213
 214 \begin{code}
 215 mkFinalTypeEnv :: TypeEnv       -- From typechecker
 216                -> [Id]          -- Final Ids
 217                -> TypeEnv
 218
 219 mkFinalTypeEnv type_env final_ids
 220   = extendTypeEnvList (filterNameEnv keep_it type_env)
 221                       (map AnId final_ids)
 222   where
 223         -- The competed type environment is gotten from
 224         --      a) keeping the types and classes
 225         --      b) removing all Ids,
 226         --      c) adding Ids with correct IdInfo, including unfoldings,
 227         --              gotten from the bindings
 228         -- From (c) we keep only those Ids with Global names;
 229         --          the CoreTidy pass makes sure these are all and only
 230         --          the externally-accessible ones
 231         -- This truncates the type environment to include only the
 232         -- exported Ids and things needed from them, which saves space
 233         --
 234         -- However, we do keep things like constructors, which should not appear
 235         -- in interface files, because they are needed by importing modules when
 236         -- using the compilation manager
 237
 238         -- We keep constructor workers,
 239         -- because they won't appear in the bindings from which final_ids are derived!
 240     keep_it (AnId id) = isDataConId id  -- Remove all Ids except constructor workers
 241     keep_it other     = True            -- Keep all TyCons and Classes
 242 \end{code}
 243
 244 \begin{code}
 245 findExternalRules :: [CoreBind]
 246                   -> [IdCoreRule] -- Orphan rules
 247                   -> IdEnv a      -- Ids that are exported, so we need their rules
 248                   -> [IdCoreRule]
 249   -- The complete rules are gotten by combining
 250   --    a) the orphan rules
 251   --    b) rules embedded in the top-level Ids
 252 findExternalRules binds orphan_rules ext_ids
 253   | opt_OmitInterfacePragmas = []
 254   | otherwise
 255   = orphan_rules ++ local_rules
 256   where
 257     local_rules  = [ (id, rule)
 258                    | id <- bindersOfBinds binds,
 259                      id `elemVarEnv` ext_ids,
 260                      rule <- rulesRules (idSpecialisation id),
 261                      not (isBuiltinRule rule)
 262                         -- We can't print builtin rules in interface files
 263                         -- Since they are built in, an importing module
 264                         -- will have access to them anyway
 265                  ]
 266 \end{code}
 267
 268 %************************************************************************
 269 %*                                                                      *
 270 \subsection{Step 1: finding externals}
 271 %*                                                                      *
 272 %************************************************************************
 273
 274 \begin{code}
 275 findExternalSet :: [CoreBind] -> [IdCoreRule]
 276                 -> IdEnv Bool   -- In domain => external
 277                                 -- Range = True <=> show unfolding
 278         -- Step 1 from the notes above
 279 findExternalSet binds orphan_rules
 280   = foldr find init_needed binds
 281   where
 282     orphan_rule_ids :: IdSet
 283     orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isLocalId rule
 284                                    | (_, rule) <- orphan_rules]
 285     init_needed :: IdEnv Bool
 286     init_needed = mapUFM (\_ -> False) orphan_rule_ids
 287         -- The mapUFM is a bit cheesy.  It is a cheap way
 288         -- to turn the set of orphan_rule_ids, which we use to initialise
 289         -- the sweep, into a mapping saying 'don't expose unfolding'
 290         -- (When we come to the binding site we may change our mind, of course.)
 291
 292     find (NonRec id rhs) needed
 293         | need_id needed id = addExternal (id,rhs) needed
 294         | otherwise         = needed
 295     find (Rec prs) needed   = find_prs prs needed
 296
 297         -- For a recursive group we have to look for a fixed point
 298     find_prs prs needed
 299         | null needed_prs = needed
 300         | otherwise       = find_prs other_prs new_needed
 301         where
 302           (needed_prs, other_prs) = partition (need_pr needed) prs
 303           new_needed = foldr addExternal needed needed_prs
 304
 305         -- The 'needed' set contains the Ids that are needed by earlier
 306         -- interface file emissions.  If the Id isn't in this set, and isn't
 307         -- exported, there's no need to emit anything
 308     need_id needed_set id       = id `elemVarEnv` needed_set || isExportedId id
 309     need_pr needed_set (id,rhs) = need_id needed_set id
 310
 311 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
 312 -- The Id is needed; extend the needed set
 313 -- with it and its dependents (free vars etc)
 314 addExternal (id,rhs) needed
 315   = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
 316                  id show_unfold
 317   where
 318     add_occ id needed = extendVarEnv needed id False
 319         -- "False" because we don't know we need the Id's unfolding
 320         -- We'll override it later when we find the binding site
 321
 322     new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
 323                    | otherwise                = worker_ids      `unionVarSet`
 324                                                 unfold_ids      `unionVarSet`
 325                                                 spec_ids
 326
 327     idinfo         = idInfo id
 328     dont_inline    = isNeverActive (inlinePragInfo idinfo)
 329     loop_breaker   = isLoopBreaker (occInfo idinfo)
 330     bottoming_fn   = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
 331     spec_ids       = rulesRhsFreeVars (specInfo idinfo)
 332     worker_info    = workerInfo idinfo
 333
 334         -- Stuff to do with the Id's unfolding
 335         -- The simplifier has put an up-to-date unfolding
 336         -- in the IdInfo, but the RHS will do just as well
 337     unfolding    = unfoldingInfo idinfo
 338     rhs_is_small = not (neverUnfold unfolding)
 339
 340         -- We leave the unfolding there even if there is a worker
 341         -- In GHCI the unfolding is used by importers
 342         -- When writing an interface file, we omit the unfolding
 343         -- if there is a worker
 344     show_unfold = not bottoming_fn       &&     -- Not necessary
 345                   not dont_inline        &&
 346                   not loop_breaker       &&
 347                   rhs_is_small           &&     -- Small enough
 348                   okToUnfoldInHiFile rhs        -- No casms etc
 349
 350     unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
 351                | otherwise   = emptyVarSet
 352
 353     worker_ids = case worker_info of
 354                    HasWorker work_id _ -> unitVarSet work_id
 355                    otherwise           -> emptyVarSet
 356 \end{code}
 357
 358
 359 %************************************************************************
 360 %*                                                                      *
 361 \subsection{Step 2: top-level tidying}
 362 %*                                                                      *
 363 %************************************************************************
 364
 365
 366 \begin{code}
 367 type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var)
 368
 369 -- TopTidyEnv: when tidying we need to know
 370 --   * ns: The NameSupply, containing a unique supply and any pre-ordained Names.
 371 --        These may have arisen because the
 372 --        renamer read in an interface file mentioning M.$wf, say,
 373 --        and assigned it unique r77.  If, on this compilation, we've
 374 --        invented an Id whose name is $wf (but with a different unique)
 375 --        we want to rename it to have unique r77, so that we can do easy
 376 --        comparisons with stuff from the interface file
 377 --
 378 --   * occ_env: The TidyOccEnv, which tells us which local occurrences
 379 --     are 'used'
 380 --
 381 --   * subst_env: A Var->Var mapping that substitutes the new Var for the old
 382 \end{code}
 383
 384
 385 \begin{code}
 386 tidyTopBind :: Module
 387             -> IdEnv Bool       -- Domain = Ids that should be external
 388                                 -- True <=> their unfolding is external too
 389             -> TopTidyEnv -> CoreBind
 390             -> (TopTidyEnv, CoreBind)
 391
 392 tidyTopBind mod ext_ids top_tidy_env (NonRec bndr rhs)
 393   = ((orig,occ,subst) , NonRec bndr' rhs')
 394   where
 395     ((orig,occ,subst), bndr')
 396          = tidyTopBinder mod ext_ids rec_tidy_env rhs' top_tidy_env bndr
 397     rec_tidy_env = (occ,subst)
 398     rhs' = tidyExpr rec_tidy_env rhs
 399
 400 tidyTopBind mod ext_ids top_tidy_env (Rec prs)
 401   = (final_env, Rec prs')
 402   where
 403     (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
 404     rec_tidy_env = (occ,subst)
 405
 406     do_one top_tidy_env (bndr,rhs)
 407         = ((orig,occ,subst), (bndr',rhs'))
 408         where
 409         ((orig,occ,subst), bndr')
 410            = tidyTopBinder mod ext_ids
 411                 rec_tidy_env rhs' top_tidy_env bndr
 412
 413         rhs' = tidyExpr rec_tidy_env rhs
 414
 415 tidyTopBinder :: Module -> IdEnv Bool
 416               -> TidyEnv -> CoreExpr
 417                         -- The TidyEnv is used to tidy the IdInfo
 418                         -- The expr is the already-tided RHS
 419                         -- Both are knot-tied: don't look at them!
 420               -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
 421   -- NB: tidyTopBinder doesn't affect the unique supply
 422
 423 tidyTopBinder mod ext_ids tidy_env rhs
 424               env@(ns2, occ_env2, subst_env2) id
 425
 426   | isDataConWrapId id  -- Don't tidy constructor wrappers
 427   = (env, id)           -- The Id is stored in the TyCon, so it would be bad
 428                         -- if anything changed
 429
 430 -- HACK ALERT: we *do* tidy record selectors.  Reason: they mention error
 431 -- messages, which may be floated out:
 432 --      x_field pt = case pt of
 433 --                      Rect x y -> y
 434 --                      Pol _ _  -> error "buggle wuggle"
 435 -- The error message will be floated out so we'll get
 436 --      lvl5 = error "buggle wuggle"
 437 --      x_field pt = case pt of
 438 --                      Rect x y -> y
 439 --                      Pol _ _  -> lvl5
 440 --
 441 -- When this happens, it's vital that the Id exposed to importing modules
 442 -- (by ghci) mentions lvl5 in its unfolding, not the un-tidied version.
 443 --
 444 -- What about the Id in the TyCon?  It probably shouldn't be in the TyCon at
 445 -- all, but in any case it will have the error message inline so it won't matter.
 446
 447
 448   | otherwise
 449         -- This function is the heart of Step 2
 450         -- The second env is the one to use for the IdInfo
 451         -- It's necessary because when we are dealing with a recursive
 452         -- group, a variable late in the group might be mentioned
 453         -- in the IdInfo of one early in the group
 454
 455         -- The rhs is already tidied
 456
 457   = ((orig_env', occ_env', subst_env'), id')
 458   where
 459     (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2
 460                                                is_external
 461                                                (idName id)
 462     ty'     = tidyTopType (idType id)
 463     idinfo' = tidyIdInfo tidy_env is_external unfold_info id
 464
 465     id' | isGlobalId id = mkGlobalId (globalIdDetails id) name' ty' idinfo'
 466         | otherwise     = mkVanillaGlobal                 name' ty' idinfo'
 467         -- The test ensures that record selectors (which must be tidied; see above)
 468         -- retain their details.  If it's forgotten, importing modules get confused.
 469
 470     subst_env' = extendVarEnv subst_env2 id id'
 471
 472     maybe_external = lookupVarEnv ext_ids id
 473     is_external    = isJust maybe_external
 474
 475     -- Expose an unfolding if ext_ids tells us to
 476     show_unfold = maybe_external `orElse` False
 477     unfold_info | show_unfold = mkTopUnfolding rhs
 478                 | otherwise   = noUnfolding
 479
 480
 481 tidyIdInfo tidy_env is_external unfold_info id
 482   | opt_OmitInterfacePragmas || not is_external
 483         -- No IdInfo if the Id isn't external, or if we don't have -O
 484   = vanillaIdInfo
 485         `setArityInfo`         arityInfo core_idinfo
 486         `setNewStrictnessInfo` newStrictnessInfo core_idinfo
 487         -- Keep strictness and arity; both are used by CorePrep
 488
 489   | otherwise
 490   =  vanillaIdInfo
 491         `setArityInfo`         arityInfo core_idinfo
 492         `setNewStrictnessInfo` newStrictnessInfo core_idinfo
 493         `setInlinePragInfo`    inlinePragInfo core_idinfo
 494         `setUnfoldingInfo`     unfold_info
 495         `setWorkerInfo`        tidyWorker tidy_env (workerInfo core_idinfo)
 496         -- NB: we throw away the Rules
 497         -- They have already been extracted by findExternalRules
 498   where
 499     core_idinfo = idInfo id
 500
 501
 502 -- This is where we set names to local/global based on whether they really are
 503 -- externally visible (see comment at the top of this module).  If the name
 504 -- was previously local, we have to give it a unique occurrence name if
 505 -- we intend to globalise it.
 506 tidyTopName mod ns occ_env external name
 507   | global && internal = (ns, occ_env, localiseName name)
 508
 509   | global && external = (ns, occ_env, name)
 510         -- Global names are assumed to have been allocated by the renamer,
 511         -- so they already have the "right" unique
 512         -- And it's a system-wide unique too
 513
 514   | local  && internal = (ns { nsUniqs = us2 }, occ_env', unique_name)
 515         -- Even local, internal names must get a unique occurrence, because
 516         -- if we do -split-objs we globalise the name later, in the code generator
 517         --
 518         -- Similarly, we must make sure it has a system-wide Unique, because
 519         -- the byte-code generator builds a system-wide Name->BCO symbol table
 520
 521   | local  && external = case lookupFM ns_names key of
 522                            Just orig -> (ns,                                        occ_env', orig)
 523                            Nothing   -> (ns { nsUniqs = us2, nsNames = ns_names' }, occ_env', global_name)
 524         -- If we want to globalise a currently-local name, check
 525         -- whether we have already assigned a unique for it.
 526         -- If so, use it; if not, extend the table
 527
 528   where
 529     global           = isGlobalName name
 530     local            = not global
 531     internal         = not external
 532
 533     (occ_env', occ') = tidyOccName occ_env (nameOccName name)
 534     key              = (moduleName mod, occ')
 535     ns_names         = nsNames ns
 536     ns_uniqs         = nsUniqs ns
 537     (us1, us2)       = splitUniqSupply ns_uniqs
 538     unique_name      = setNameUnique (setNameOcc name occ') (uniqFromSupply us1)
 539     global_name      = globaliseName unique_name mod
 540     ns_names'        = addToFM ns_names key global_name
 541
 542
 543 ------------  Worker  --------------
 544 tidyWorker tidy_env (HasWorker work_id wrap_arity)
 545   = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
 546 tidyWorker tidy_env other
 547   = NoWorker
 548
 549 ------------  Rules  --------------
 550 tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
 551 tidyIdRules env [] = []
 552 tidyIdRules env ((fn,rule) : rules)
 553   = tidyRule env rule           =: \ rule ->
 554     tidyIdRules env rules       =: \ rules ->
 555      ((tidyVarOcc env fn, rule) : rules)
 556
 557 tidyRule :: TidyEnv -> CoreRule -> CoreRule
 558 tidyRule env rule@(BuiltinRule _ _) = rule
 559 tidyRule env (Rule name act vars tpl_args rhs)
 560   = tidyBndrs env vars                  =: \ (env', vars) ->
 561     map (tidyExpr env') tpl_args        =: \ tpl_args ->
 562      (Rule name act vars tpl_args (tidyExpr env' rhs))
 563 \end{code}
 564
 565 %************************************************************************
 566 %*                                                                      *
 567 \subsection{Step 2: inner tidying
 568 %*                                                                      *
 569 %************************************************************************
 570
 571 \begin{code}
 572 tidyBind :: TidyEnv
 573          -> CoreBind
 574          ->  (TidyEnv, CoreBind)
 575
 576 tidyBind env (NonRec bndr rhs)
 577   = tidyLetBndr env (bndr,rhs)          =: \ (env', bndr') ->
 578     (env', NonRec bndr' (tidyExpr env' rhs))
 579
 580 tidyBind env (Rec prs)
 581   = mapAccumL tidyLetBndr env prs       =: \ (env', bndrs') ->
 582     map (tidyExpr env') (map snd prs)   =: \ rhss' ->
 583     (env', Rec (zip bndrs' rhss'))
 584
 585
 586 tidyExpr env (Var v)    =  Var (tidyVarOcc env v)
 587 tidyExpr env (Type ty)  =  Type (tidyType env ty)
 588 tidyExpr env (Lit lit)  =  Lit lit
 589 tidyExpr env (App f a)  =  App (tidyExpr env f) (tidyExpr env a)
 590 tidyExpr env (Note n e) =  Note (tidyNote env n) (tidyExpr env e)
 591
 592 tidyExpr env (Let b e)
 593   = tidyBind env b      =: \ (env', b') ->
 594     Let b' (tidyExpr env' e)
 595
 596 tidyExpr env (Case e b alts)
 597   = tidyBndr env b      =: \ (env', b) ->
 598     Case (tidyExpr env e) b (map (tidyAlt env') alts)
 599
 600 tidyExpr env (Lam b e)
 601   = tidyBndr env b      =: \ (env', b) ->
 602     Lam b (tidyExpr env' e)
 603
 604
 605 tidyAlt env (con, vs, rhs)
 606   = tidyBndrs env vs    =: \ (env', vs) ->
 607     (con, vs, tidyExpr env' rhs)
 608
 609 tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
 610 tidyNote env note            = note
 611 \end{code}
 612
 613
 614 %************************************************************************
 615 %*                                                                      *
 616 \subsection{Tidying up non-top-level binders}
 617 %*                                                                      *
 618 %************************************************************************
 619
 620 \begin{code}
 621 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
 622                                   Just v' -> v'
 623                                   Nothing -> v
 624
 625 -- tidyBndr is used for lambda and case binders
 626 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
 627 tidyBndr env var
 628   | isTyVar var = tidyTyVarBndr env var
 629   | otherwise   = tidyIdBndr env var
 630
 631 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
 632 tidyBndrs env vars = mapAccumL tidyBndr env vars
 633
 634 tidyLetBndr :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var)
 635 -- Used for local (non-top-level) let(rec)s
 636 tidyLetBndr env (id,rhs)
 637   = ((tidy_env,new_var_env), final_id)
 638   where
 639     ((tidy_env,var_env), new_id) = tidyIdBndr env id
 640
 641         -- We need to keep around any interesting strictness and demand info
 642         -- because later on we may need to use it when converting to A-normal form.
 643         -- eg.
 644         --      f (g x),  where f is strict in its argument, will be converted
 645         --      into  case (g x) of z -> f z  by CorePrep, but only if f still
 646         --      has its strictness info.
 647         --
 648         -- Similarly for the demand info - on a let binder, this tells
 649         -- CorePrep to turn the let into a case.
 650     final_id = new_id `setIdNewDemandInfo` idNewDemandInfo id
 651                       `setIdNewStrictness` idNewStrictness id
 652
 653     -- Override the env we get back from tidyId with the new IdInfo
 654     -- so it gets propagated to the usage sites.
 655     new_var_env = extendVarEnv var_env id final_id
 656
 657 tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
 658 tidyIdBndr env@(tidy_env, var_env) id
 659   =     -- Non-top-level variables
 660     let
 661         -- Give the Id a fresh print-name, *and* rename its type
 662         -- The SrcLoc isn't important now,
 663         -- though we could extract it from the Id
 664         --
 665         -- All local Ids now have the same IdInfo, which should save some
 666         -- space.
 667         (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
 668         ty'               = tidyType env (idType id)
 669         id'               = mkUserLocal occ' (idUnique id) ty' noSrcLoc
 670         var_env'          = extendVarEnv var_env id id'
 671     in
 672      ((tidy_env', var_env'), id')
 673 \end{code}
 674
 675 \begin{code}
 676 m =: k = m `seq` k m
 677 \end{code}