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      ( opt_D_dump_simpl, opt_D_verbose_core2core, opt_UsageSPOn )
  15 import CoreSyn
  16 import CoreUnfold       ( noUnfolding )
  17 import CoreLint         ( beginPass, endPass )
  18 import Rules            ( ProtoCoreRule(..) )
  19 import VarEnv
  20 import VarSet
  21 import Var              ( Id, IdOrTyVar )
  22 import Id               ( idType, idInfo, idName,
  23                           mkVanillaId, mkId, isUserExportedId,
  24                           getIdStrictness, setIdStrictness,
  25                           getIdDemandInfo, setIdDemandInfo,
  26                         )
  27 import IdInfo           ( specInfo, setSpecInfo,
  28                           inlinePragInfo, setInlinePragInfo, InlinePragInfo(..),
  29                           setUnfoldingInfo, setDemandInfo
  30                         )
  31 import Demand           ( wwLazy )
  32 import Name             ( getOccName, tidyTopName, mkLocalName, isLocallyDefined )
  33 import OccName          ( initTidyOccEnv, tidyOccName )
  34 import Type             ( tidyTopType, tidyType, tidyTypes, tidyTyVar, tidyTyVars )
  35 import Class            ( Class, classSelIds )
  36 import Module           ( Module )
  37 import UniqSupply       ( UniqSupply )
  38 import Unique           ( Uniquable(..) )
  39 import SrcLoc           ( noSrcLoc )
  40 import Util             ( mapAccumL )
  41 import Outputable
  42
  43 doUsageSPInf = panic "doUsageSpInf"
  44 \end{code}
  45
  46
  47
  48 %************************************************************************
  49 %*                                                                      *
  50 \subsection{Tidying core}
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 Several tasks are done by @tidyCorePgm@
  55
  56 1.  Make certain top-level bindings into Globals. The point is that
  57     Global things get externally-visible labels at code generation
  58     time
  59
  60
  61 2. Give all binders a nice print-name.  Their uniques aren't changed;
  62    rather we give them lexically unique occ-names, so that we can
  63    safely print the OccNae only in the interface file.  [Bad idea to
  64    change the uniques, because the code generator makes global labels
  65    from the uniques for local thunks etc.]
  66
  67
  68 3. If @opt_UsageSPOn@ then compute usage information (which is
  69    needed by Core2Stg).  ** NOTE _scc_ HERE **
  70
  71 \begin{code}
  72 tidyCorePgm :: UniqSupply -> Module -> [CoreBind] -> [ProtoCoreRule]
  73             -> IO ([CoreBind], [ProtoCoreRule])
  74 tidyCorePgm us module_name binds_in rules
  75   = do
  76         beginPass "Tidy Core"
  77
  78         let (tidy_env1, binds_tidy) = mapAccumL (tidyBind (Just module_name)) init_tidy_env binds_in
  79             rules_out               = tidyProtoRules tidy_env1 rules
  80
  81         binds_out <- if opt_UsageSPOn
  82                      then _scc_ "CoreUsageSPInf" doUsageSPInf us binds_tidy
  83                      else return binds_tidy
  84
  85         endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
  86         return (binds_out, rules_out)
  87   where
  88         -- We also make sure to avoid any exported binders.  Consider
  89         --      f{-u1-} = 1     -- Local decl
  90         --      ...
  91         --      f{-u2-} = 2     -- Exported decl
  92         --
  93         -- The second exported decl must 'get' the name 'f', so we
  94         -- have to put 'f' in the avoids list before we get to the first
  95         -- decl.  tidyTopId then does a no-op on exported binders.
  96     init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv)
  97     avoids        = [getOccName bndr | bndr <- bindersOfBinds binds_in,
  98                                        isUserExportedId bndr]
  99
 100 tidyBind :: Maybe Module                -- (Just m) for top level, Nothing for nested
 101          -> TidyEnv
 102          -> CoreBind
 103          -> (TidyEnv, CoreBind)
 104 tidyBind maybe_mod env (NonRec bndr rhs)
 105   = let
 106         (env', bndr') = tidy_bndr maybe_mod env bndr
 107         rhs'          = tidyExpr env rhs
 108     in
 109     (env', NonRec bndr' rhs')
 110
 111 tidyBind maybe_mod env (Rec pairs)
 112   = let
 113         -- We use env' when tidying the rhss
 114         -- When tidying the binder itself we may tidy it's
 115         -- specialisations; if any of these mention other binders
 116         -- in the group we should really feed env' to them too;
 117         -- but that seems (a) unlikely and (b) a bit tiresome.
 118         -- So I left it out for now
 119
 120         (bndrs, rhss)  = unzip pairs
 121         (env', bndrs') = mapAccumL (tidy_bndr maybe_mod) env bndrs
 122         rhss'          = map (tidyExpr env') rhss
 123   in
 124   (env', Rec (zip bndrs' rhss'))
 125
 126 tidyExpr env (Type ty)       = Type (tidyType env ty)
 127 tidyExpr env (Con con args)  = Con con (map (tidyExpr env) args)
 128 tidyExpr env (App f a)       = App (tidyExpr env f) (tidyExpr env a)
 129 tidyExpr env (Note n e)      = Note (tidyNote env n) (tidyExpr env e)
 130
 131 tidyExpr env (Let b e)       = Let b' (tidyExpr env' e)
 132                              where
 133                                (env', b') = tidyBind Nothing env b
 134
 135 tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
 136                              where
 137                                (env', b') = tidyBndr env b
 138
 139 tidyExpr env (Var v)         = Var (tidyVarOcc env v)
 140
 141 tidyExpr env (Lam b e)       = Lam b' (tidyExpr env' e)
 142                              where
 143                                (env', b') = tidyBndr env b
 144
 145 tidyAlt env (con, vs, rhs)   = (con, vs', tidyExpr env' rhs)
 146                              where
 147                                (env', vs') = tidyBndrs env vs
 148
 149 tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
 150
 151 tidyNote env note            = note
 152
 153 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
 154                                   Just v' -> v'
 155                                   Nothing -> v
 156 \end{code}
 157
 158 \begin{code}
 159 tidy_bndr (Just mod) env id  = tidyTopId mod env id
 160 tidy_bndr Nothing    env var = tidyBndr  env var
 161 \end{code}
 162
 163
 164
 165 %************************************************************************
 166 %*                                                                      *
 167 \subsection{Tidying up a binder}
 168 %*                                                                      *
 169 %************************************************************************
 170
 171 \begin{code}
 172 tidyBndr :: TidyEnv -> IdOrTyVar -> (TidyEnv, IdOrTyVar)
 173 tidyBndr env var | isTyVar var = tidyTyVar env var
 174                  | otherwise   = tidyId    env var
 175
 176 tidyBndrs :: TidyEnv -> [IdOrTyVar] -> (TidyEnv, [IdOrTyVar])
 177 tidyBndrs env vars = mapAccumL tidyBndr env vars
 178
 179 tidyId :: TidyEnv -> Id -> (TidyEnv, Id)
 180 tidyId env@(tidy_env, var_env) id
 181   =     -- Non-top-level variables
 182     let
 183         -- Give the Id a fresh print-name, *and* rename its type
 184         -- The SrcLoc isn't important now, though we could extract it from the Id
 185         name'             = mkLocalName (getUnique id) occ' noSrcLoc
 186         (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
 187         ty'               = tidyType env (idType id)
 188         id'               = mkVanillaId name' ty'
 189                             `setIdStrictness` getIdStrictness id
 190                             `setIdDemandInfo` getIdDemandInfo id
 191                         -- NB: This throws away the IdInfo of the Id, which we
 192                         -- no longer need.  That means we don't need to
 193                         -- run over it with env, nor renumber it.
 194                         --
 195                         -- The exception is strictness and demand info, which
 196                         -- is used to decide whether to use let or case for
 197                         -- function arguments and let bindings
 198
 199         var_env'          = extendVarEnv var_env id id'
 200     in
 201     ((tidy_env', var_env'), id')
 202
 203 tidyTopId :: Module -> TidyEnv -> Id -> (TidyEnv, Id)
 204 tidyTopId mod env@(tidy_env, var_env) id
 205   =     -- Top level variables
 206     let
 207         (tidy_env', name') | isUserExportedId id = (tidy_env, idName id)
 208                            | otherwise           = tidyTopName mod tidy_env (idName id)
 209         ty'                = tidyTopType (idType id)
 210         idinfo'            = tidyIdInfo env (idInfo id)
 211         id'                = mkId name' ty' idinfo'
 212         var_env'           = extendVarEnv var_env id id'
 213     in
 214     ((tidy_env', var_env'), id')
 215 \end{code}
 216
 217 \begin{code}
 218 -- tidyIdInfo does these things:
 219 --      a) tidy the specialisation info (if any)
 220 --      b) zap a complicated ICanSafelyBeINLINEd pragma,
 221 --      c) zap the unfolding
 222 -- The latter two are to avoid space leaks
 223
 224 tidyIdInfo env info
 225   = info4
 226   where
 227     rules = specInfo info
 228
 229     info1 | isEmptyCoreRules rules = info
 230           | otherwise              = info `setSpecInfo` tidyRules env rules
 231
 232     info2 = case inlinePragInfo info of
 233                 ICanSafelyBeINLINEd _ _ -> info1 `setInlinePragInfo` NoInlinePragInfo
 234                 other                   -> info1
 235
 236     info3 = info2 `setUnfoldingInfo` noUnfolding
 237     info4 = info3 `setDemandInfo`    wwLazy             -- I don't understand why...
 238
 239 tidyProtoRules :: TidyEnv -> [ProtoCoreRule] -> [ProtoCoreRule]
 240 tidyProtoRules env rules
 241   = [ ProtoCoreRule is_local (tidyVarOcc env fn) (tidyRule env rule)
 242     | ProtoCoreRule is_local fn rule <- rules
 243     ]
 244
 245 tidyRules :: TidyEnv -> CoreRules -> CoreRules
 246 tidyRules env (Rules rules fvs)
 247   = Rules (map (tidyRule env) rules)
 248           (foldVarSet tidy_set_elem emptyVarSet fvs)
 249   where
 250     tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
 251
 252 tidyRule :: TidyEnv -> CoreRule -> CoreRule
 253 tidyRule env (Rule name vars tpl_args rhs)
 254   = (Rule name vars' (map (tidyExpr env') tpl_args) (tidyExpr env' rhs))
 255   where
 256     (env', vars') = tidyBndrs env vars
 257 \end{code}