ghc/compiler/simplCore/SimplVar.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[SimplVar]{Simplifier stuff related to variables}
   5
   6 \begin{code}
   7 module SimplVar (
   8         completeVar,
   9         simplBinder, simplBinders, simplTyBinder, simplTyBinders
  10     ) where
  11
  12 #include "HsVersions.h"
  13
  14 import {-# SOURCE #-} Simplify ( simplExpr )
  15
  16 import CmdLineOpts      ( switchIsOn, SimplifierSwitch(..) )
  17 import CoreSyn
  18 import CoreUnfold       ( Unfolding(..), UnfoldingGuidance(..),
  19                           FormSummary, whnfOrBottom, okToInline,
  20                           smallEnoughToInline )
  21 import CoreUtils        ( coreExprCc )
  22 import BinderInfo       ( BinderInfo, noBinderInfo )
  23
  24 import CostCentre       ( CostCentre, noCostCentreAttached, isCurrentCostCentre )
  25 import Id               ( idType, getIdUnfolding,
  26                           getIdSpecialisation, setIdSpecialisation,
  27                           idMustBeINLINEd, idHasNoFreeTyVars,
  28                           mkIdWithNewUniq, mkIdWithNewType,
  29                           IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv
  30                         )
  31 import SpecEnv          ( lookupSpecEnv )
  32 import OccurAnal        ( occurAnalyseGlobalExpr )
  33 import Literal          ( isNoRepLit )
  34 import MagicUFs         ( applyMagicUnfoldingFun, MagicUnfoldingFun )
  35 import SimplEnv
  36 import SimplMonad
  37 import Type             ( instantiateTy, mkTyVarTy )
  38 import TyCon            ( tyConFamilySize )
  39 import TyVar            ( TyVar, cloneTyVar,
  40                           isEmptyTyVarEnv, addToTyVarEnv, delFromTyVarEnv,
  41                           addOneToTyVarSet, elementOfTyVarSet
  42                         )
  43 import Maybes           ( maybeToBool )
  44 import Outputable
  45 \end{code}
  46
  47 %************************************************************************
  48 %*                                                                      *
  49 \subsection[Simplify-var]{Completing variables}
  50 %*                                                                      *
  51 %************************************************************************
  52
  53 This where all the heavy-duty unfolding stuff comes into its own.
  54
  55 \begin{code}
  56 completeVar env inline_call var args result_ty
  57
  58   | maybeToBool maybe_magic_result
  59   = tick MagicUnfold    `thenSmpl_`
  60     magic_result
  61
  62         -- Look for existing specialisations before
  63         -- trying inlining
  64   | maybeToBool maybe_specialisation
  65   = tick SpecialisationDone     `thenSmpl_`
  66     simplExpr (bindTyVars env spec_bindings)
  67               (occurAnalyseGlobalExpr spec_template)
  68               remaining_args
  69               result_ty
  70
  71
  72         -- Look for an unfolding. There's a binding for the
  73         -- thing, but perhaps we want to inline it anyway
  74   |    has_unfolding
  75     && (idMustBeINLINEd var ||
  76         (not essential_unfoldings_only
  77                 -- If "essential_unfoldings_only" is true we do no inlinings at all,
  78                 -- EXCEPT for things that absolutely have to be done
  79                 -- (see comments with idMustBeINLINEd)
  80          && (inline_call || ok_to_inline)
  81          && costCentreOk (getEnclosingCC env) (coreExprCc unf_template)))
  82   =
  83 {-
  84     pprTrace "Unfolding" (ppr var) $
  85     simplCount          `thenSmpl` \ n ->
  86     (if n > 1000 then
  87         pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var])
  88     else
  89         id
  90     )
  91     (if n>4000 then
  92        returnSmpl (mkGenApp (Var var) args)
  93     else
  94 -}
  95     tickUnfold var              `thenSmpl_`
  96     simplExpr unf_env unf_template args result_ty
  97
  98   | inline_call         -- There was an InlineCall note, but we didn't inline!
  99   = returnSmpl (mkGenApp (Note InlineCall (Var var')) args)
 100
 101   | otherwise
 102   = returnSmpl (mkGenApp (Var var') args)
 103
 104   where
 105     (var', occ_info, unfolding) = case lookupOutIdEnv env var of
 106                                         Just stuff -> stuff
 107                                         Nothing    -> (var, noBinderInfo, getIdUnfolding var)
 108
 109         ---------- Magic unfolding stuff
 110     maybe_magic_result  = case unfolding of
 111                                 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
 112                                                                                     env args
 113                                 other                     -> Nothing
 114     Just magic_result = maybe_magic_result
 115
 116         ---------- Unfolding stuff
 117     has_unfolding = case unfolding of
 118                         CoreUnfolding _ _ _ -> True
 119                         other               -> False
 120
 121     CoreUnfolding form guidance unf_template = unfolding
 122     unf_env = zapSubstEnvs env
 123                 -- The template is already simplified, so don't re-substitute.
 124                 -- This is VITAL.  Consider
 125                 --      let x = e in
 126                 --      let y = \z -> ...x... in
 127                 --      \ x -> ...y...
 128                 -- We'll clone the inner \x, adding x->x' in the id_subst
 129                 -- Then when we inline y, we must *not* replace x by x' in
 130                 -- the inlined copy!!
 131
 132         ---------- Specialisation stuff
 133     (ty_args, remaining_args) = initialTyArgs args
 134     maybe_specialisation      = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
 135     Just (spec_bindings, spec_template) = maybe_specialisation
 136
 137
 138         ---------- Switches
 139     sw_chkr                   = getSwitchChecker env
 140     essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
 141     is_case_scrutinee         = switchIsOn sw_chkr SimplCaseScrutinee
 142     ok_to_inline              = okToInline var (whnfOrBottom form) small_enough occ_info
 143     small_enough              = smallEnoughToInline var arg_evals is_case_scrutinee guidance
 144     arg_evals                 = [is_evald arg | arg <- args, isValArg arg]
 145
 146     is_evald (VarArg v) = isEvaluated (lookupUnfolding env v)
 147     is_evald (LitArg l) = True
 148
 149
 150
 151
 152 -- costCentreOk checks that it's ok to inline this thing
 153 -- The time it *isn't* is this:
 154 --
 155 --      f x = let y = E in
 156 --            scc "foo" (...y...)
 157 --
 158 -- Here y has a "current cost centre", and we can't inline it inside "foo",
 159 -- regardless of whether E is a WHNF or not.
 160
 161 costCentreOk cc_encl cc_rhs
 162   = isCurrentCostCentre cc_encl || not (noCostCentreAttached cc_rhs)
 163 \end{code}
 164
 165
 166 %************************************************************************
 167 %*                                                                      *
 168 \section{Dealing with a single binder}
 169 %*                                                                      *
 170 %************************************************************************
 171
 172 When we hit a binder we may need to
 173   (a) apply the the type envt (if non-empty) to its type
 174   (b) apply the type envt and id envt to its SpecEnv (if it has one)
 175   (c) give it a new unique to avoid name clashes
 176
 177 \begin{code}
 178 simplBinder :: SimplEnv -> InBinder -> SmplM (SimplEnv, OutId)
 179 simplBinder env (id, occ_info)
 180   |  not_in_scope               -- Not in scope, so no need to clone
 181   && empty_ty_subst             -- No type substitution to do inside the Id
 182   && isNullIdEnv id_subst       -- No id substitution to do inside the Id
 183   = let
 184         env'          = setIdEnv env (new_in_scope_ids id, id_subst)
 185     in
 186     returnSmpl (env', id)
 187
 188   | otherwise
 189   =
 190 #if DEBUG
 191     -- I  reckon the empty-env thing should catch
 192     -- most no-free-tyvars things, so this test should be redundant
 193 --    (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x))
 194 #endif
 195     (let
 196        -- id1 has its type zapped
 197        id1 | empty_ty_subst = id
 198            | otherwise      = mkIdWithNewType id ty'
 199     in
 200     if not_in_scope then
 201         -- No need to clone, but we *must* zap any current substitution
 202         -- for the variable.  For example:
 203         --      (\x.e) with id_subst = [x |-> e']
 204         -- Here we must simply zap the substitution for x
 205         let
 206             env' = setIdEnv env (new_in_scope_ids id1,
 207                                  delOneFromIdEnv id_subst id)
 208         in
 209         returnSmpl (env', id1)
 210     else
 211         -- Must clone
 212         getUniqueSmpl         `thenSmpl` \ uniq ->
 213         let
 214             id2 = mkIdWithNewUniq id1 uniq
 215             env' = setIdEnv env (new_in_scope_ids id2,
 216                                  addOneToIdEnv id_subst id (SubstVar id2))
 217         in
 218         returnSmpl (env', id2)
 219     )
 220   where
 221     ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
 222
 223     empty_ty_subst       = isEmptyTyVarEnv ty_subst
 224     not_in_scope         = not (id `elemIdEnv` in_scope_ids)
 225
 226     new_in_scope_ids id' = addOneToIdEnv in_scope_ids id' (id', occ_info, NoUnfolding)
 227
 228     ty                   = idType id
 229     ty'                  = instantiateTy ty_subst ty
 230
 231 simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId])
 232 simplBinders env binders = mapAccumLSmpl simplBinder env binders
 233 \end{code}
 234
 235 \begin{code}
 236 simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar)
 237 simplTyBinder env tyvar
 238   | not (tyvar `elementOfTyVarSet` tyvars)
 239   =     -- No need to clone; but must zap any binding for tyvar
 240         -- see comments with simplBinder above
 241     let
 242         env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar,
 243                              delFromTyVarEnv ty_subst tyvar)
 244     in
 245     returnSmpl (env', tyvar)
 246
 247   | otherwise                                   -- Need to clone
 248   = getUniqueSmpl         `thenSmpl` \ uniq ->
 249     let
 250         tyvar' = cloneTyVar tyvar uniq
 251         env'   = setTyEnv env (tyvars `addOneToTyVarSet` tyvar',
 252                                addToTyVarEnv ty_subst tyvar (mkTyVarTy tyvar'))
 253     in
 254     returnSmpl (env', tyvar')
 255   where
 256     ((tyvars, ty_subst), (ids, id_subst)) = getEnvs env
 257
 258 simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
 259 simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
 260 \end{code}
 261