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, externallyVisibleId,
  26                           getIdSpecialisation, setIdSpecialisation,
  27                           idMustBeINLINEd, idHasNoFreeTyVars,
  28                           mkIdWithNewUniq, mkIdWithNewType,
  29                           IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv
  30                         )
  31 import SpecEnv          ( lookupSpecEnv, isEmptySpecEnv, emptySpecEnv )
  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   |  no_need_to_clone           -- Not in scope (or cloning disabled), 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        -- id2 has its SpecEnv zapped (see comment inside Simplify.completeBind)
 200        id2 | empty_spec_env = id1
 201            | otherwise      = setIdSpecialisation id1 emptySpecEnv
 202     in
 203     if no_need_to_clone then
 204         -- No need to clone, but we *must* zap any current substitution
 205         -- for the variable.  For example:
 206         --      (\x.e) with id_subst = [x |-> e']
 207         -- Here we must simply zap the substitution for x
 208         let
 209             new_id_subst = delOneFromIdEnv id_subst id
 210             new_env      = setIdEnv env (new_in_scope_ids id2, new_id_subst)
 211         in
 212         returnSmpl (new_env, id2)
 213     else
 214         -- Must clone
 215         getUniqueSmpl         `thenSmpl` \ uniq ->
 216         let
 217             id3     = mkIdWithNewUniq id2 uniq
 218             new_env = setIdEnv env (new_in_scope_ids id3,
 219                                     addOneToIdEnv id_subst id (SubstVar id3))
 220         in
 221         returnSmpl (new_env, id3)
 222     )
 223   where
 224     ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
 225
 226     empty_ty_subst    = isEmptyTyVarEnv ty_subst
 227     empty_spec_env    = isEmptySpecEnv (getIdSpecialisation id)
 228
 229     no_need_to_clone  = not need_to_clone
 230     need_to_clone     = not (externallyVisibleId id) &&
 231                         ( elemIdEnv id in_scope_ids || clone_binds_please)
 232      {-
 233        The SimplCloneBinds option isn't just here as another simplifier knob we can
 234        twiddle. Prior to floating bindings outwards, we have to make sure that no
 235        duplicate bindings exist as floating may cause bindings with identical
 236        uniques to come into scope, with disastrous consequences.
 237
 238        To avoid this situation, we make sure that cloning is turned *on* in the
 239        simplifier pass prior to running an outward floating pass.
 240      -}
 241     clone_binds_please = switchIsOn sw_chkr SimplCloneBinds
 242
 243     new_in_scope_ids id' = addOneToIdEnv in_scope_ids id' (id', occ_info, NoUnfolding)
 244
 245     ty                   = idType id
 246     ty'                  = instantiateTy ty_subst ty
 247
 248     sw_chkr              = getSwitchChecker env
 249
 250
 251 simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId])
 252 simplBinders env binders = mapAccumLSmpl simplBinder env binders
 253 \end{code}
 254
 255 \begin{code}
 256 simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar)
 257 simplTyBinder env tyvar
 258   | no_need_to_clone
 259   =     -- No need to clone; but must zap any binding for tyvar
 260         -- see comments with simplBinder above
 261     let
 262         env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar,
 263                              delFromTyVarEnv ty_subst tyvar)
 264     in
 265     returnSmpl (env', tyvar)
 266
 267   | otherwise                                   -- Need to clone
 268   = getUniqueSmpl         `thenSmpl` \ uniq ->
 269     let
 270         tyvar' = cloneTyVar tyvar uniq
 271         env'   = setTyEnv env (tyvars `addOneToTyVarSet` tyvar',
 272                                addToTyVarEnv ty_subst tyvar (mkTyVarTy tyvar'))
 273     in
 274     returnSmpl (env', tyvar')
 275   where
 276     ((tyvars, ty_subst), (ids, id_subst)) = getEnvs env
 277     no_need_to_clone                      = not (tyvar `elementOfTyVarSet` tyvars) &&
 278                                             not clone_binds_please
 279
 280     clone_binds_please                    = switchIsOn sw_chkr SimplCloneBinds
 281     sw_chkr                               = getSwitchChecker env
 282
 283
 284 simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
 285 simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
 286 \end{code}