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