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,
  20                           smallEnoughToInline )
  21 import CoreUtils        ( coreExprCc )
  22 import BinderInfo       ( BinderInfo, noBinderInfo, okToInline )
  23
  24 import CostCentre       ( CostCentre, noCostCentreAttached, isCurrentCostCentre )
  25 import Id               ( idType, getIdInfo, getIdUnfolding,
  26                           getIdSpecialisation, setIdSpecialisation,
  27                           idMustBeINLINEd, idHasNoFreeTyVars,
  28                           mkIdWithNewUniq, mkIdWithNewType,
  29                           IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv
  30                         )
  31 import SpecEnv          ( lookupSpecEnv, substSpecEnv, isEmptySpecEnv )
  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 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     && (not essential_unfoldings_only || idMustBeINLINEd var)
  76         -- If "essential_unfoldings_only" is true we do no inlinings at all,
  77         -- EXCEPT for things that absolutely have to be done
  78         -- (see comments with idMustBeINLINEd)
  79     && ok_to_inline
  80     && costCentreOk (getEnclosingCC env) (coreExprCc unf_template)
  81   =
  82 {-
  83     pprTrace "Unfolding" (ppr var) $
  84     simplCount          `thenSmpl` \ n ->
  85     (if n > 1000 then
  86         pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var])
  87     else
  88         id
  89     )
  90     (if n>4000 then
  91        returnSmpl (mkGenApp (Var var) args)
  92     else
  93 -}
  94     tickUnfold var              `thenSmpl_`
  95     simplExpr unf_env unf_template args result_ty
  96
  97   | otherwise
  98   = returnSmpl (mkGenApp (Var var') args)
  99
 100   where
 101     (var', occ_info, unfolding) = case lookupOutIdEnv env var of
 102                                         Just stuff -> stuff
 103                                         Nothing    -> (var, noBinderInfo, getIdUnfolding var)
 104
 105         ---------- Magic unfolding stuff
 106     maybe_magic_result  = case unfolding of
 107                                 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
 108                                                                                     env args
 109                                 other                     -> Nothing
 110     Just magic_result = maybe_magic_result
 111
 112         ---------- Unfolding stuff
 113     has_unfolding = case unfolding of
 114                         CoreUnfolding _ _ _ -> True
 115                         other               -> False
 116
 117     CoreUnfolding form guidance unf_template = unfolding
 118     unf_env = zapSubstEnvs env
 119                 -- The template is already simplified, so don't re-substitute.
 120                 -- This is VITAL.  Consider
 121                 --      let x = e in
 122                 --      let y = \z -> ...x... in
 123                 --      \ x -> ...y...
 124                 -- We'll clone the inner \x, adding x->x' in the id_subst
 125                 -- Then when we inline y, we must *not* replace x by x' in
 126                 -- the inlined copy!!
 127
 128         ---------- Specialisation stuff
 129     (ty_args, remaining_args) = initialTyArgs args
 130     maybe_specialisation      = lookupSpecEnv (getIdSpecialisation var) ty_args
 131     Just (spec_bindings, spec_template) = maybe_specialisation
 132
 133
 134         ---------- Switches
 135     sw_chkr                   = getSwitchChecker env
 136     essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
 137     is_case_scrutinee         = switchIsOn sw_chkr SimplCaseScrutinee
 138     ok_to_inline              = okToInline (whnfOrBottom form) small_enough occ_info
 139     small_enough              = smallEnoughToInline var arg_evals is_case_scrutinee guidance
 140     arg_evals                 = [is_evald arg | arg <- args, isValArg arg]
 141
 142     is_evald (VarArg v) = isEvaluated (lookupUnfolding env v)
 143     is_evald (LitArg l) = True
 144
 145
 146
 147
 148 -- costCentreOk checks that it's ok to inline this thing
 149 -- The time it *isn't* is this:
 150 --
 151 --      f x = let y = E in
 152 --            scc "foo" (...y...)
 153 --
 154 -- Here y has a "current cost centre", and we can't inline it inside "foo",
 155 -- regardless of whether E is a WHNF or not.
 156
 157 costCentreOk cc_encl cc_rhs
 158   = isCurrentCostCentre cc_encl || not (noCostCentreAttached cc_rhs)
 159 \end{code}
 160
 161
 162 %************************************************************************
 163 %*                                                                      *
 164 \section{Dealing with a single binder}
 165 %*                                                                      *
 166 %************************************************************************
 167
 168 When we hit a binder we may need to
 169   (a) apply the the type envt (if non-empty) to its type
 170   (b) apply the type envt and id envt to its SpecEnv (if it has one)
 171   (c) give it a new unique to avoid name clashes
 172
 173 \begin{code}
 174 simplBinder :: SimplEnv -> InBinder -> SmplM (SimplEnv, OutId)
 175 simplBinder env (id, occ_info)
 176   |  not_in_scope               -- Not in scope, so no need to clone
 177   && empty_ty_subst             -- No type substitution to do inside the Id
 178   && isNullIdEnv id_subst       -- No id substitution to do inside the Id
 179   = let
 180         env'          = setIdEnv env (new_in_scope_ids id, id_subst)
 181     in
 182     returnSmpl (env', id)
 183
 184   | otherwise
 185   =
 186 #if DEBUG
 187     -- I  reckon the empty-env thing should catch
 188     -- most no-free-tyvars things, so this test should be redundant
 189 --    (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x))
 190 #endif
 191     (let
 192        -- id1 has its type zapped
 193        id1 | empty_ty_subst = id
 194            | otherwise      = mkIdWithNewType id ty'
 195
 196        -- id2 has its SpecEnv zapped
 197        id2 | isEmptySpecEnv spec_env = id1
 198            | otherwise               = setIdSpecialisation id spec_env'
 199     in
 200     if not_in_scope then
 201         -- No need to clone
 202         let
 203             env' = setIdEnv env (new_in_scope_ids id2, id_subst)
 204         in
 205         returnSmpl (env', id2)
 206     else
 207         -- Must clone
 208         getUniqueSmpl         `thenSmpl` \ uniq ->
 209         let
 210             id3 = mkIdWithNewUniq id2 uniq
 211             env' = setIdEnv env (new_in_scope_ids id3,
 212                                  addOneToIdEnv id_subst id (SubstVar id3))
 213         in
 214         returnSmpl (env', id3)
 215     )
 216   where
 217     ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
 218
 219     empty_ty_subst       = isEmptyTyVarEnv ty_subst
 220     not_in_scope         = not (id `elemIdEnv` in_scope_ids)
 221
 222     new_in_scope_ids id' = addOneToIdEnv in_scope_ids id' (id', occ_info, NoUnfolding)
 223
 224     ty                   = idType id
 225     ty'                  = instantiateTy ty_subst ty
 226
 227     spec_env             = getIdSpecialisation id
 228     spec_env'            = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
 229
 230 simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId])
 231 simplBinders env binders = mapAccumLSmpl simplBinder env binders
 232 \end{code}
 233
 234 \begin{code}
 235 simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar)
 236 simplTyBinder env tyvar
 237   | not (tyvar `elementOfTyVarSet` tyvars)      -- No need to clone
 238   = let
 239         env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar, ty_subst)
 240     in
 241     returnSmpl (env', tyvar)
 242
 243   | otherwise                                   -- Need to clone
 244   = getUniqueSmpl         `thenSmpl` \ uniq ->
 245     let
 246         tyvar' = cloneTyVar tyvar uniq
 247         env'   = setTyEnv env (tyvars `addOneToTyVarSet` tyvar',
 248                                addToTyVarEnv ty_subst tyvar (mkTyVarTy tyvar'))
 249     in
 250     returnSmpl (env', tyvar')
 251   where
 252     ((tyvars, ty_subst), (ids, id_subst)) = getEnvs env
 253
 254 simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
 255 simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
 256 \end{code}
 257
 258
 259 substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
 260 It exploits the known structure of a SpecEnv's RHS to have fewer
 261 equations.
 262
 263 \begin{code}
 264 substSpecEnvRhs te ve rhs
 265   = go te ve rhs
 266   where
 267     go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
 268     go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
 269                                                         Just (SubstVar v') -> VarArg v'
 270                                                         Just (SubstLit l)  -> LitArg l
 271                                                         Nothing            -> VarArg v)
 272     go te ve (Var v)              = case lookupIdEnv ve v of
 273                                                 Just (SubstVar v') -> Var v'
 274                                                 Just (SubstLit l)  -> Lit l
 275                                                 Nothing            -> Var v
 276
 277         -- These equations are a bit half baked, because
 278         -- they don't deal properly wih capture.
 279         -- But I'm sure it'll never matter... sigh.
 280     go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
 281                                         where
 282                                           te' = delFromTyVarEnv te tyvar
 283
 284     go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
 285                                      where
 286                                        ve' = delOneFromIdEnv ve v
 287 \end{code}