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, omitIfaceSigForId,
  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 env@(orig_env, occ_env, subst_env) id
 297   | omitIfaceSigForId id        -- Don't mess with constructors,
 298   = (env, id)                   -- record selectors, and the like
 299
 300   | otherwise
 301         -- This function is the heart of Step 2
 302         -- The second env is the one to use for the IdInfo
 303         -- It's necessary because when we are dealing with a recursive
 304         -- group, a variable late in the group might be mentioned
 305         -- in the IdInfo of one early in the group
 306
 307         -- The rhs is already tidied
 308
 309   = ((orig_env', occ_env', subst_env'), id')
 310   where
 311     (orig_env', occ_env', name') = tidyTopName mod orig_env occ_env
 312                                                is_external
 313                                                (idName id)
 314     ty'        = tidyTopType (idType id)
 315     idinfo'    = tidyIdInfo env_idinfo is_external unfold_info id
 316     id'        = mkId name' ty' idinfo'
 317     subst_env' = extendVarEnv subst_env id id'
 318
 319     maybe_external = lookupVarEnv ext_ids id
 320     is_external    = maybeToBool maybe_external
 321
 322     -- Expose an unfolding if ext_ids tells us to
 323     show_unfold = maybe_external `orElse` False
 324     unfold_info | show_unfold = mkTopUnfolding rhs
 325                 | otherwise   = noUnfolding
 326
 327 tidyIdInfo (_, occ_env, subst_env) is_external unfold_info id
 328   | opt_OmitInterfacePragmas || not is_external
 329         -- No IdInfo if the Id isn't
 330   = constantIdInfo
 331
 332   | otherwise
 333   = constantIdInfo `setCprInfo`          cprInfo core_idinfo
 334                    `setStrictnessInfo`   strictnessInfo core_idinfo
 335                    `setInlinePragInfo`   inlinePragInfo core_idinfo
 336                    `setUnfoldingInfo`    unfold_info
 337                    `setWorkerInfo`       tidyWorker tidy_env (workerInfo core_idinfo)
 338                    `setSpecInfo`         tidyRules tidy_env (specInfo core_idinfo)
 339   where
 340     tidy_env    = (occ_env, subst_env)
 341     core_idinfo = idInfo id
 342
 343 tidyTopName mod orig_env occ_env external name
 344   | global && internal = (orig_env, occ_env,  localiseName name)
 345   | local  && internal = (orig_env, occ_env', setNameOcc name occ')
 346   | global && external = (orig_env, occ_env,  name)
 347   | local  && external = globalise
 348   where
 349         -- If we want to globalise a currently-local name, check
 350         -- whether we have already assigned a unique for it.
 351         -- If so, use it; if not, extend the table
 352     globalise = case lookupFM orig_env key of
 353                   Just orig -> (orig_env,                         occ_env', orig)
 354                   Nothing   -> (addToFM orig_env key global_name, occ_env', global_name)
 355
 356     (occ_env', occ') = tidyOccName occ_env (nameOccName name)
 357     key              = (moduleName mod, occ')
 358     global_name      = globaliseName (setNameOcc name occ') mod
 359     global           = isGlobalName name
 360     local            = not global
 361     internal         = not external
 362
 363 tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
 364 tidyIdRules env rules
 365   = [ (tidyVarOcc env fn, tidyRule env rule) | (fn,rule) <- rules  ]
 366
 367
 368 tidyWorker tidy_env (HasWorker work_id wrap_arity)
 369   = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
 370 tidyWorker tidy_env NoWorker
 371   = NoWorker
 372
 373 tidyRules :: TidyEnv -> CoreRules -> CoreRules
 374 tidyRules env (Rules rules fvs)
 375   = Rules (map (tidyRule env) rules)
 376           (foldVarSet tidy_set_elem emptyVarSet fvs)
 377   where
 378     tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
 379
 380 tidyRule :: TidyEnv -> CoreRule -> CoreRule
 381 tidyRule env rule@(BuiltinRule _) = rule
 382 tidyRule env (Rule name vars tpl_args rhs)
 383   = (Rule name vars' (map (tidyExpr env') tpl_args) (tidyExpr env' rhs))
 384   where
 385     (env', vars') = tidyBndrs env vars
 386 \end{code}
 387
 388
 389 %************************************************************************
 390 %*                                                                      *
 391 \subsection{Step 2: inner tidying
 392 %*                                                                      *
 393 %************************************************************************
 394
 395 \begin{code}
 396 tidyBind :: TidyEnv
 397          -> CoreBind
 398          -> (TidyEnv, CoreBind)
 399 tidyBind env (NonRec bndr rhs)
 400   = let
 401         (env', bndr') = tidyBndr env bndr
 402         rhs'          = tidyExpr env' rhs
 403         -- We use env' when tidying the RHS even though it's not
 404         -- strictly necessary; it makes the tidied code pretty
 405         -- hard to read if we don't!
 406     in
 407     (env', NonRec bndr' rhs')
 408
 409 tidyBind env (Rec prs)
 410   = (final_env, Rec prs')
 411   where
 412     (final_env, prs')     = mapAccumL do_one env prs
 413     do_one env (bndr,rhs) = (env', (bndr', rhs'))
 414                           where
 415                             (env', bndr') = tidyBndr env bndr
 416                             rhs'          = tidyExpr final_env rhs
 417
 418 tidyExpr env (Type ty)       = Type (tidyType env ty)
 419 tidyExpr env (Lit lit)       = Lit lit
 420 tidyExpr env (App f a)       = App (tidyExpr env f) (tidyExpr env a)
 421 tidyExpr env (Note n e)      = Note (tidyNote env n) (tidyExpr env e)
 422
 423 tidyExpr env (Let b e)       = Let b' (tidyExpr env' e)
 424                              where
 425                                (env', b') = tidyBind env b
 426
 427 tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
 428                              where
 429                                (env', b') = tidyBndr env b
 430
 431 tidyExpr env (Var v)         = Var (tidyVarOcc env v)
 432
 433 tidyExpr env (Lam b e)       = Lam b' (tidyExpr env' e)
 434                              where
 435                                (env', b') = tidyBndr env b
 436
 437 tidyAlt env (con, vs, rhs)   = (con, vs', tidyExpr env' rhs)
 438                              where
 439                                (env', vs') = tidyBndrs env vs
 440
 441 tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
 442
 443 tidyNote env note            = note
 444 \end{code}
 445
 446
 447 %************************************************************************
 448 %*                                                                      *
 449 \subsection{Tidying up non-top-level binders}
 450 %*                                                                      *
 451 %************************************************************************
 452
 453 \begin{code}
 454 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
 455                                   Just v' -> v'
 456                                   Nothing -> v
 457
 458 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
 459 tidyBndr env var | isTyVar var = tidyTyVar env var
 460                  | otherwise   = tidyId    env var
 461
 462 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
 463 tidyBndrs env vars = mapAccumL tidyBndr env vars
 464
 465 tidyId :: TidyEnv -> Id -> (TidyEnv, Id)
 466 tidyId env@(tidy_env, var_env) id
 467   =     -- Non-top-level variables
 468     let
 469         -- Give the Id a fresh print-name, *and* rename its type
 470         -- The SrcLoc isn't important now, though we could extract it from the Id
 471         name'             = mkLocalName (getUnique id) occ' noSrcLoc
 472         (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
 473         ty'               = tidyType env (idType id)
 474         idinfo            = idInfo id
 475         id'               = mkVanillaId name' ty'
 476                             `setIdStrictness` strictnessInfo idinfo
 477                             `setIdDemandInfo` demandInfo idinfo
 478                         -- NB: This throws away the IdInfo of the Id, which we
 479                         -- no longer need.  That means we don't need to
 480                         -- run over it with env, nor renumber it.
 481                         --
 482                         -- The exception is strictness and demand info, which
 483                         -- is used to decide whether to use let or case for
 484                         -- function arguments and let bindings
 485
 486         var_env'          = extendVarEnv var_env id id'
 487     in
 488     ((tidy_env', var_env'), id')
 489 \end{code}