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, dopt )
  15 import CoreSyn
  16 import CoreUnfold       ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
  17 import CoreFVs          ( ruleSomeFreeVars, exprSomeFreeVars )
  18 import CoreLint         ( showPass, endPass )
  19 import VarEnv
  20 import VarSet
  21 import Var              ( Id, Var )
  22 import Id               ( idType, idInfo, idName, isExportedId,
  23                           mkVanillaId, mkId, isLocalId,
  24                           setIdStrictness, setIdDemandInfo,
  25                         )
  26 import IdInfo           ( constantIdInfo,
  27                           specInfo, setSpecInfo,
  28                           cprInfo, setCprInfo,
  29                           inlinePragInfo, setInlinePragInfo, isNeverInlinePrag,
  30                           strictnessInfo, setStrictnessInfo, isBottomingStrictness,
  31                           unfoldingInfo, setUnfoldingInfo,
  32                           demandInfo,
  33                           occInfo, isLoopBreaker,
  34                           workerInfo, setWorkerInfo, WorkerInfo(..)
  35                         )
  36 import Name             ( getOccName, nameOccName, globaliseName, setNameOcc,
  37                           localiseName, mkLocalName, isGlobalName
  38                         )
  39 import OccName          ( TidyOccEnv, initTidyOccEnv, tidyOccName )
  40 import Type             ( tidyTopType, tidyType, tidyTyVar )
  41 import Module           ( Module, moduleName )
  42 import HscTypes         ( PersistentCompilerState( pcs_PRS ), PersistentRenamerState( prsOrig ),
  43                           OrigNameEnv( origNames ), OrigNameNameEnv
  44                         )
  45 import Unique           ( Uniquable(..) )
  46 import FiniteMap        ( lookupFM, addToFM )
  47 import Maybes           ( maybeToBool, orElse )
  48 import ErrUtils         ( showPass )
  49 import SrcLoc           ( noSrcLoc )
  50 import UniqFM           ( mapUFM )
  51 import Outputable
  52 import List             ( partition )
  53 import Util             ( mapAccumL )
  54 \end{code}
  55
  56
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection{What goes on}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 [SLPJ: 19 Nov 00]
  65
  66 The plan is this.
  67
  68 Step 1: Figure out external Ids
  69 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  70 First we figure out which Ids are "external" Ids.  An
  71 "external" Id is one that is visible from outside the compilation
  72 unit.  These are
  73         a) the user exported ones
  74         b) ones mentioned in the unfoldings, workers,
  75            or rules of externally-visible ones
  76 This exercise takes a sweep of the bindings bottom to top.  Actually,
  77 in Step 2 we're also going to need to know which Ids should be
  78 exported with their unfoldings, so we produce not an IdSet but an
  79 IdEnv Bool
  80
  81
  82
  83 Step 2: Tidy the program
  84 ~~~~~~~~~~~~~~~~~~~~~~~~
  85 Next we traverse the bindings top to bottom.  For each top-level
  86 binder
  87
  88   - Make all external Ids have Global names and vice versa
  89     This is used by the code generator to decide whether
  90     to make the label externally visible
  91
  92   - Give external ids a "tidy" occurrence name.  This means
  93     we can print them in interface files without confusing
  94     "x" (unique 5) with "x" (unique 10).
  95
  96   - Give external Ids the same Unique as they had before
  97     if the name is in the renamer's name cache
  98
  99   - Give the Id its final IdInfo; in ptic,
 100         * Its flavour becomes ConstantId, reflecting the fact that
 101           from now on we regard it as a constant, not local, Id
 102         * its unfolding, if it should have one
 103
 104 Finally, substitute these new top-level binders consistently
 105 throughout, including in unfoldings.  We also tidy binders in
 106 RHSs, so that they print nicely in interfaces.
 107
 108 \begin{code}
 109 tidyCorePgm :: DynFlags -> Module
 110             -> PersistentCompilerState
 111             -> [CoreBind] -> [IdCoreRule]
 112             -> IO (PersistentCompilerState, [CoreBind], [IdCoreRule])
 113 tidyCorePgm dflags mod pcs binds_in orphans_in
 114   = do  { showPass dflags "Tidy Core"
 115
 116         ; let ext_ids = findExternalSet binds_in orphans_in
 117
 118         ; let ((orig_env', occ_env, subst_env), binds_out)
 119                   = mapAccumL (tidyTopBind mod ext_ids) init_tidy_env binds_in
 120
 121         ; let orphans_out = tidyIdRules (occ_env,subst_env) orphans_in
 122
 123         ; let pcs' = pcs { pcs_PRS = prs { prsOrig = orig { origNames = orig_env' }}}
 124
 125         ; endPass dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags ||
 126                                       dopt Opt_D_verbose_core2core dflags)
 127                   binds_out
 128
 129         ; return (pcs', binds_out, orphans_out)
 130         }
 131   where
 132         -- We also make sure to avoid any exported binders.  Consider
 133         --      f{-u1-} = 1     -- Local decl
 134         --      ...
 135         --      f{-u2-} = 2     -- Exported decl
 136         --
 137         -- The second exported decl must 'get' the name 'f', so we
 138         -- have to put 'f' in the avoids list before we get to the first
 139         -- decl.  tidyTopId then does a no-op on exported binders.
 140     prs           = pcs_PRS pcs
 141     orig          = prsOrig prs
 142     orig_env      = origNames orig
 143
 144     init_tidy_env = (orig_env, initTidyOccEnv avoids, emptyVarEnv)
 145     avoids        = [getOccName bndr | bndr <- bindersOfBinds binds_in,
 146                                        isGlobalName (idName bndr)]
 147 \end{code}
 148
 149
 150 %************************************************************************
 151 %*                                                                      *
 152 \subsection{Step 1: finding externals}
 153 %*                                                                      *
 154 %************************************************************************
 155
 156 \begin{code}
 157 findExternalSet :: [CoreBind] -> [IdCoreRule]
 158                 -> IdEnv Bool   -- True <=> show unfolding
 159         -- Step 1 from the notes above
 160 findExternalSet binds orphan_rules
 161   = foldr find init_needed binds
 162   where
 163     orphan_rule_ids :: IdSet
 164     orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isIdAndLocal rule
 165                                    | (_, rule) <- orphan_rules]
 166     init_needed :: IdEnv Bool
 167     init_needed = mapUFM (\_ -> False) orphan_rule_ids
 168         -- The mapUFM is a bit cheesy.  It is a cheap way
 169         -- to turn the set of orphan_rule_ids, which we use to initialise
 170         -- the sweep, into a mapping saying 'don't expose unfolding'
 171         -- (When we come to the binding site we may change our mind, of course.)
 172
 173     find (NonRec id rhs) needed
 174         | need_id needed id = addExternal (id,rhs) needed
 175         | otherwise         = needed
 176     find (Rec prs) needed   = find_prs prs needed
 177
 178         -- For a recursive group we have to look for a fixed point
 179     find_prs prs needed
 180         | null needed_prs = needed
 181         | otherwise       = find_prs other_prs new_needed
 182         where
 183           (needed_prs, other_prs) = partition (need_pr needed) prs
 184           new_needed = foldr addExternal needed needed_prs
 185
 186         -- The 'needed' set contains the Ids that are needed by earlier
 187         -- interface file emissions.  If the Id isn't in this set, and isn't
 188         -- exported, there's no need to emit anything
 189     need_id needed_set id       = id `elemVarEnv` needed_set || isExportedId id
 190     need_pr needed_set (id,rhs) = need_id needed_set id
 191
 192 isIdAndLocal id = isId id && isLocalId id
 193
 194 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
 195 -- The Id is needed; extend the needed set
 196 -- with it and its dependents (free vars etc)
 197 addExternal (id,rhs) needed
 198   = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
 199                  id show_unfold
 200   where
 201     add_occ id needed = extendVarEnv needed id False
 202         -- "False" because we don't know we need the Id's unfolding
 203         -- We'll override it later when we find the binding site
 204
 205     new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
 206                    | otherwise                = worker_ids      `unionVarSet`
 207                                                 unfold_ids      `unionVarSet`
 208                                                 spec_ids
 209
 210     idinfo         = idInfo id
 211     dont_inline    = isNeverInlinePrag (inlinePragInfo idinfo)
 212     loop_breaker   = isLoopBreaker (occInfo idinfo)
 213     bottoming_fn   = isBottomingStrictness (strictnessInfo idinfo)
 214     spec_ids       = rulesRhsFreeVars (specInfo idinfo)
 215     worker_info    = workerInfo idinfo
 216
 217         -- Stuff to do with the Id's unfolding
 218         -- The simplifier has put an up-to-date unfolding
 219         -- in the IdInfo, but the RHS will do just as well
 220     unfolding    = unfoldingInfo idinfo
 221     rhs_is_small = not (neverUnfold unfolding)
 222
 223         -- We leave the unfolding there even if there is a worker
 224         -- In GHCI the unfolding is used by importers
 225         -- When writing an interface file, we omit the unfolding
 226         -- if there is a worker
 227     show_unfold = not bottoming_fn       &&     -- Not necessary
 228                   not dont_inline        &&
 229                   not loop_breaker       &&
 230                   rhs_is_small           &&     -- Small enough
 231                   okToUnfoldInHiFile rhs        -- No casms etc
 232
 233     unfold_ids | show_unfold = exprSomeFreeVars isIdAndLocal rhs
 234                | otherwise   = emptyVarSet
 235
 236     worker_ids = case worker_info of
 237                    HasWorker work_id _ -> unitVarSet work_id
 238                    otherwise           -> emptyVarSet
 239 \end{code}
 240
 241
 242 %************************************************************************
 243 %*                                                                      *
 244 \subsection{Step 2: top-level tidying}
 245 %*                                                                      *
 246 %************************************************************************
 247
 248
 249 \begin{code}
 250 type TopTidyEnv = (OrigNameNameEnv, TidyOccEnv, VarEnv Var)
 251
 252 -- TopTidyEnv: when tidying we need to know
 253 --   * orig_env: Any pre-ordained Names.  These may have arisen because the
 254 --        renamer read in an interface file mentioning M.$wf, say,
 255 --        and assigned it unique r77.  If, on this compilation, we've
 256 --        invented an Id whose name is $wf (but with a different unique)
 257 --        we want to rename it to have unique r77, so that we can do easy
 258 --        comparisons with stuff from the interface file
 259
 260 --   * occ_env: The TidyOccEnv, which tells us which local occurrences are 'used'
 261
 262 --   * subst_env: A Var->Var mapping that substitutes the new Var for the old
 263 \end{code}
 264
 265
 266 \begin{code}
 267 tidyTopBind :: Module
 268             -> IdEnv Bool       -- Domain = Ids that should be exernal
 269                                 -- True <=> their unfolding is external too
 270             -> TopTidyEnv -> CoreBind
 271             -> (TopTidyEnv, CoreBind)
 272
 273 tidyTopBind mod ext_ids env (NonRec bndr rhs)
 274   = (env', NonRec bndr' rhs')
 275   where
 276     rhs'          = tidyTopRhs env rhs
 277     (env', bndr') = tidyTopBinder mod ext_ids env rhs' env bndr
 278
 279 tidyTopBind mod ext_ids env (Rec prs)
 280   = (final_env, Rec prs')
 281   where
 282     (final_env, prs')     = mapAccumL do_one env prs
 283     do_one env (bndr,rhs) = (env', (bndr', rhs'))
 284                           where
 285                             rhs'          = tidyTopRhs final_env rhs
 286                             (env', bndr') = tidyTopBinder mod ext_ids final_env
 287                                                           rhs env bndr
 288
 289 tidyTopRhs :: TopTidyEnv -> CoreExpr -> CoreExpr
 290         -- Just an impedence matcher
 291 tidyTopRhs (_, occ_env, subst_env) rhs = tidyExpr (occ_env, subst_env) rhs
 292
 293 tidyTopBinder :: Module -> IdEnv Bool
 294               -> TopTidyEnv -> CoreExpr
 295               -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
 296 tidyTopBinder mod ext_ids env_idinfo rhs (orig_env, occ_env, subst_env) id
 297         -- This function is the heart of Step 2
 298         -- The second env is the one to use for the IdInfo
 299         -- It's necessary because when we are dealing with a recursive
 300         -- group, a variable late in the group might be mentioned
 301         -- in the IdInfo of one early in the group
 302
 303         -- The rhs is already tidied
 304
 305   = ((orig_env', occ_env', subst_env'), id')
 306   where
 307     (orig_env', occ_env', name') = tidyTopName mod orig_env occ_env
 308                                                is_external
 309                                                (idName id)
 310     ty'        = tidyTopType (idType id)
 311     idinfo'    = tidyIdInfo env_idinfo is_external unfold_info id
 312     id'        = mkId name' ty' idinfo'
 313     subst_env' = extendVarEnv subst_env id id'
 314
 315     maybe_external = lookupVarEnv ext_ids id
 316     is_external    = maybeToBool maybe_external
 317
 318     -- Expose an unfolding if ext_ids tells us to
 319     show_unfold = maybe_external `orElse` False
 320     unfold_info | show_unfold = mkTopUnfolding rhs
 321                 | otherwise   = noUnfolding
 322
 323 tidyIdInfo (_, occ_env, subst_env) is_external unfold_info id
 324
 325   | opt_OmitInterfacePragmas || not is_external
 326         -- No IdInfo if the Id isn't
 327   = constantIdInfo
 328
 329   | otherwise
 330   = constantIdInfo `setCprInfo`          cprInfo core_idinfo
 331                    `setStrictnessInfo`   strictnessInfo core_idinfo
 332                    `setInlinePragInfo`   inlinePragInfo core_idinfo
 333                    `setUnfoldingInfo`    unfold_info
 334                    `setWorkerInfo`       tidyWorker tidy_env (workerInfo core_idinfo)
 335                    `setSpecInfo`         tidyRules tidy_env (specInfo core_idinfo)
 336   where
 337     tidy_env    = (occ_env, subst_env)
 338     core_idinfo = idInfo id
 339
 340 tidyTopName mod orig_env occ_env external name
 341   | global && internal = (orig_env, occ_env,  localiseName name)
 342   | local  && internal = (orig_env, occ_env', setNameOcc name occ')
 343   | global && external = (orig_env, occ_env,  name)
 344   | local  && external = globalise
 345   where
 346         -- If we want to globalise a currently-local name, check
 347         -- whether we have already assigned a unique for it.
 348         -- If so, use it; if not, extend the table
 349     globalise = case lookupFM orig_env key of
 350                   Just orig -> (orig_env,                         occ_env', orig)
 351                   Nothing   -> (addToFM orig_env key global_name, occ_env', global_name)
 352
 353     (occ_env', occ') = tidyOccName occ_env (nameOccName name)
 354     key              = (moduleName mod, occ')
 355     global_name      = globaliseName (setNameOcc name occ') mod
 356     global           = isGlobalName name
 357     local            = not global
 358     internal         = not external
 359
 360 tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
 361 tidyIdRules env rules
 362   = [ (tidyVarOcc env fn, tidyRule env rule) | (fn,rule) <- rules  ]
 363
 364
 365 tidyWorker tidy_env (HasWorker work_id wrap_arity)
 366   = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
 367 tidyWorker tidy_env NoWorker
 368   = NoWorker
 369
 370 tidyRules :: TidyEnv -> CoreRules -> CoreRules
 371 tidyRules env (Rules rules fvs)
 372   = Rules (map (tidyRule env) rules)
 373           (foldVarSet tidy_set_elem emptyVarSet fvs)
 374   where
 375     tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
 376
 377 tidyRule :: TidyEnv -> CoreRule -> CoreRule
 378 tidyRule env rule@(BuiltinRule _) = rule
 379 tidyRule env (Rule name vars tpl_args rhs)
 380   = (Rule name vars' (map (tidyExpr env') tpl_args) (tidyExpr env' rhs))
 381   where
 382     (env', vars') = tidyBndrs env vars
 383 \end{code}
 384
 385
 386 %************************************************************************
 387 %*                                                                      *
 388 \subsection{Step 2: inner tidying
 389 %*                                                                      *
 390 %************************************************************************
 391
 392 \begin{code}
 393 tidyBind :: TidyEnv
 394          -> CoreBind
 395          -> (TidyEnv, CoreBind)
 396 tidyBind env (NonRec bndr rhs)
 397   = let
 398         (env', bndr') = tidyBndr env bndr
 399         rhs'          = tidyExpr env' rhs
 400         -- We use env' when tidying the RHS even though it's not
 401         -- strictly necessary; it makes the tidied code pretty
 402         -- hard to read if we don't!
 403     in
 404     (env', NonRec bndr' rhs')
 405
 406 tidyBind env (Rec prs)
 407   = (final_env, Rec prs')
 408   where
 409     (final_env, prs')     = mapAccumL do_one env prs
 410     do_one env (bndr,rhs) = (env', (bndr', rhs'))
 411                           where
 412                             (env', bndr') = tidyBndr env bndr
 413                             rhs'          = tidyExpr final_env rhs
 414
 415 tidyExpr env (Type ty)       = Type (tidyType env ty)
 416 tidyExpr env (Lit lit)       = Lit lit
 417 tidyExpr env (App f a)       = App (tidyExpr env f) (tidyExpr env a)
 418 tidyExpr env (Note n e)      = Note (tidyNote env n) (tidyExpr env e)
 419
 420 tidyExpr env (Let b e)       = Let b' (tidyExpr env' e)
 421                              where
 422                                (env', b') = tidyBind env b
 423
 424 tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
 425                              where
 426                                (env', b') = tidyBndr env b
 427
 428 tidyExpr env (Var v)         = Var (tidyVarOcc env v)
 429
 430 tidyExpr env (Lam b e)       = Lam b' (tidyExpr env' e)
 431                              where
 432                                (env', b') = tidyBndr env b
 433
 434 tidyAlt env (con, vs, rhs)   = (con, vs', tidyExpr env' rhs)
 435                              where
 436                                (env', vs') = tidyBndrs env vs
 437
 438 tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
 439
 440 tidyNote env note            = note
 441 \end{code}
 442
 443
 444 %************************************************************************
 445 %*                                                                      *
 446 \subsection{Tidying up non-top-level binders}
 447 %*                                                                      *
 448 %************************************************************************
 449
 450 \begin{code}
 451 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
 452                                   Just v' -> v'
 453                                   Nothing -> v
 454
 455 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
 456 tidyBndr env var | isTyVar var = tidyTyVar env var
 457                  | otherwise   = tidyId    env var
 458
 459 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
 460 tidyBndrs env vars = mapAccumL tidyBndr env vars
 461
 462 tidyId :: TidyEnv -> Id -> (TidyEnv, Id)
 463 tidyId env@(tidy_env, var_env) id
 464   =     -- Non-top-level variables
 465     let
 466         -- Give the Id a fresh print-name, *and* rename its type
 467         -- The SrcLoc isn't important now, though we could extract it from the Id
 468         name'             = mkLocalName (getUnique id) occ' noSrcLoc
 469         (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
 470         ty'               = tidyType env (idType id)
 471         idinfo            = idInfo id
 472         id'               = mkVanillaId name' ty'
 473                             `setIdStrictness` strictnessInfo idinfo
 474                             `setIdDemandInfo` demandInfo idinfo
 475                         -- NB: This throws away the IdInfo of the Id, which we
 476                         -- no longer need.  That means we don't need to
 477                         -- run over it with env, nor renumber it.
 478                         --
 479                         -- The exception is strictness and demand info, which
 480                         -- is used to decide whether to use let or case for
 481                         -- function arguments and let bindings
 482
 483         var_env'          = extendVarEnv var_env id id'
 484     in
 485     ((tidy_env', var_env'), id')
 486 \end{code}