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