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                           SimpleUnfolding(..),
  20                           FormSummary, whnfOrBottom,
  21                           smallEnoughToInline )
  22 import Specialise       ( substSpecEnvRhs )
  23 import BinderInfo       ( BinderInfo, noBinderInfo, okToInline )
  24
  25 import CostCentre       ( CostCentre, isCurrentCostCentre )
  26 import Id               ( idType, getIdInfo, getIdUnfolding,
  27                           getIdSpecialisation, setIdSpecialisation,
  28                           idMustBeINLINEd, idHasNoFreeTyVars,
  29                           mkIdWithNewUniq, mkIdWithNewType,
  30                           elemIdEnv, isNullIdEnv, addOneToIdEnv
  31                         )
  32 import SpecEnv          ( lookupSpecEnv, substSpecEnv, isEmptySpecEnv )
  33 import OccurAnal        ( occurAnalyseGlobalExpr )
  34 import Literal          ( isNoRepLit )
  35 import MagicUFs         ( applyMagicUnfoldingFun, MagicUnfoldingFun )
  36 import SimplEnv
  37 import SimplMonad
  38 import Type             ( instantiateTy, mkTyVarTy )
  39 import TyCon            ( tyConFamilySize )
  40 import TyVar            ( TyVar, cloneTyVar,
  41                           isEmptyTyVarEnv, addToTyVarEnv,
  42                           addOneToTyVarSet, elementOfTyVarSet
  43                         )
  44 import Maybes           ( maybeToBool )
  45 import Outputable
  46 \end{code}
  47
  48 %************************************************************************
  49 %*                                                                      *
  50 \subsection[Simplify-var]{Completing variables}
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 This where all the heavy-duty unfolding stuff comes into its own.
  55
  56 \begin{code}
  57 completeVar env var args result_ty
  58
  59   | maybeToBool maybe_magic_result
  60   = tick MagicUnfold    `thenSmpl_`
  61     magic_result
  62
  63         -- Look for existing specialisations before
  64         -- trying inlining
  65   | maybeToBool maybe_specialisation
  66   = tick SpecialisationDone     `thenSmpl_`
  67     simplExpr (bindTyVars env spec_bindings)
  68               (occurAnalyseGlobalExpr spec_template)
  69               remaining_args
  70               result_ty
  71
  72         -- If there's an InUnfolding it means that there's no
  73         -- let-binding left for the thing, so we'd better inline it!
  74   | must_unfold
  75   = let
  76         Just (_, _, InUnfolding rhs_env rhs) = info_from_env
  77     in
  78     unfold var rhs_env rhs args result_ty
  79
  80
  81         -- Conditional unfolding. There's a binding for the
  82         -- thing, but perhaps we want to inline it anyway
  83   | (  maybeToBool maybe_unfolding_info
  84     && (not essential_unfoldings_only || idMustBeINLINEd var)
  85         -- If "essential_unfoldings_only" is true we do no inlinings at all,
  86         -- EXCEPT for things that absolutely have to be done
  87         -- (see comments with idMustBeINLINEd)
  88     && ok_to_inline
  89     && costCentreOk (getEnclosingCC env) (getEnclosingCC unf_env)
  90     )
  91   = -- pprTrace "Unfolding" (ppr var) $
  92     unfold var unf_env unf_template args result_ty
  93
  94
  95   | otherwise
  96   = returnSmpl (mkGenApp (Var var) args)
  97
  98   where
  99     info_from_env     = lookupOutIdEnv env var
 100     unfolding_from_id = getIdUnfolding var
 101
 102         ---------- Magic unfolding stuff
 103     maybe_magic_result  = case unfolding_from_id of
 104                                 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
 105                                                                                     env args
 106                                 other                     -> Nothing
 107     (Just magic_result) = maybe_magic_result
 108
 109         ---------- Unfolding stuff
 110     must_unfold = case info_from_env of
 111                         Just (_, _, InUnfolding _ _) -> True
 112                         other                        -> False
 113
 114     maybe_unfolding_info
 115         = case (info_from_env, unfolding_from_id) of
 116
 117              (Just (_, occ_info, OutUnfolding enc_cc unf), _)
 118                 -> Just (occ_info, setEnclosingCC env enc_cc, unf)
 119
 120              (_, CoreUnfolding unf)
 121                 -> Just (noBinderInfo, env, unf)
 122
 123              other -> Nothing
 124
 125     Just (occ_info, unf_env, simple_unfolding) = maybe_unfolding_info
 126     SimpleUnfolding form guidance unf_template = simple_unfolding
 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 (lookupRhsInfo env v)
 143     is_evald (LitArg l) = True
 144
 145
 146 -- Perform the unfolding
 147 unfold var unf_env unf_template args result_ty
 148  =
 149 {-
 150     simplCount          `thenSmpl` \ n ->
 151     (if n > 1000 then
 152         pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var])
 153     else
 154         id
 155     )
 156     (if n>4000 then
 157        returnSmpl (mkGenApp (Var var) args)
 158     else
 159 -}
 160     tickUnfold var              `thenSmpl_`
 161     simplExpr unf_env unf_template args result_ty
 162
 163
 164 -- costCentreOk checks that it's ok to inline this thing
 165 -- The time it *isn't* is this:
 166 --
 167 --      f x = let y = E in
 168 --            scc "foo" (...y...)
 169 --
 170 -- Here y has a "current cost centre", and we can't inline it inside "foo",
 171 -- regardless of whether E is a WHNF or not.
 172
 173 costCentreOk cc_encl cc_rhs
 174   = isCurrentCostCentre cc_encl || not (isCurrentCostCentre cc_rhs)
 175 \end{code}
 176
 177
 178 %************************************************************************
 179 %*                                                                      *
 180 \section{Dealing with a single binder}
 181 %*                                                                      *
 182 %************************************************************************
 183
 184 When we hit a binder we may need to
 185   (a) apply the the type envt (if non-empty) to its type
 186   (b) apply the type envt and id envt to its SpecEnv (if it has one)
 187   (c) give it a new unique to avoid name clashes
 188
 189 \begin{code}
 190 simplBinder :: SimplEnv -> InBinder -> SmplM (SimplEnv, OutId)
 191 simplBinder env (id, _)
 192   |  not_in_scope               -- Not in scope, so no need to clone
 193   && empty_ty_subst             -- No type substitution to do inside the Id
 194   && isNullIdEnv id_subst       -- No id substitution to do inside the Id
 195   = let
 196         env' = setIdEnv env (addOneToIdEnv in_scope_ids id id, id_subst)
 197     in
 198     returnSmpl (env', id)
 199
 200   | otherwise
 201   =
 202 #if DEBUG
 203     -- I  reckon the empty-env thing should catch
 204     -- most no-free-tyvars things, so this test should be redundant
 205     (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x))
 206 #endif
 207     (let
 208        -- id1 has its type zapped
 209        id1 | empty_ty_subst = id
 210            | otherwise      = mkIdWithNewType id ty'
 211
 212        -- id2 has its SpecEnv zapped
 213        id2 | isEmptySpecEnv spec_env = id1
 214            | otherwise               = setIdSpecialisation id spec_env'
 215     in
 216     if not_in_scope then
 217         -- No need to clone
 218         let
 219             env' = setIdEnv env (addOneToIdEnv in_scope_ids id id2, id_subst)
 220         in
 221         returnSmpl (env', id2)
 222     else
 223         -- Must clone
 224         getUniqueSmpl         `thenSmpl` \ uniq ->
 225         let
 226             id3 = mkIdWithNewUniq id2 uniq
 227             env' = setIdEnv env (addOneToIdEnv in_scope_ids id3 id3,
 228                                  addOneToIdEnv id_subst id (VarArg id3))
 229         in
 230         returnSmpl (env', id3)
 231     )
 232   where
 233     ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getSubstEnvs env
 234     empty_ty_subst   = isEmptyTyVarEnv ty_subst
 235     not_in_scope     = not (id `elemIdEnv` in_scope_ids)
 236
 237     ty               = idType id
 238     ty'              = instantiateTy ty_subst ty
 239
 240     spec_env         = getIdSpecialisation id
 241     spec_env'        = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
 242
 243 simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId])
 244 simplBinders env binders = mapAccumLSmpl simplBinder env binders
 245 \end{code}
 246
 247 \begin{code}
 248 simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar)
 249 simplTyBinder env tyvar
 250   | not (tyvar `elementOfTyVarSet` tyvars)      -- No need to clone
 251   = let
 252         env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar, ty_subst)
 253     in
 254     returnSmpl (env', tyvar)
 255
 256   | otherwise                                   -- Need to clone
 257   = getUniqueSmpl         `thenSmpl` \ uniq ->
 258     let
 259         tyvar' = cloneTyVar tyvar uniq
 260         env'   = setTyEnv env (tyvars `addOneToTyVarSet` tyvar',
 261                                addToTyVarEnv ty_subst tyvar (mkTyVarTy tyvar'))
 262     in
 263     returnSmpl (env', tyvar')
 264   where
 265     ((tyvars, ty_subst), (ids, id_subst)) = getSubstEnvs env
 266
 267 simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
 268 simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
 269 \end{code}