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