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
  73         -- Look for an unfolding. There's a binding for the
  74         -- thing, but perhaps we want to inline it anyway
  75   | (  maybeToBool maybe_unfolding_info
  76     && (not essential_unfoldings_only || idMustBeINLINEd var)
  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     && ok_to_inline
  81     && costCentreOk (getEnclosingCC env) (getEnclosingCC unf_env)
  82     )
  83   = -- pprTrace "Unfolding" (ppr var) $
  84     unfold var unf_env unf_template args result_ty
  85
  86
  87   | otherwise
  88   = returnSmpl (mkGenApp (Var var') args)
  89
  90   where
  91    info_from_env = lookupOutIdEnv env var
  92    var'          = case info_from_env of
  93                         Just (var', _, _) -> var'
  94                         Nothing           -> var
  95
  96     unfolding_from_id = getIdUnfolding var
  97
  98         ---------- Magic unfolding stuff
  99     maybe_magic_result  = case unfolding_from_id of
 100                                 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
 101                                                                                     env args
 102                                 other                     -> Nothing
 103     Just magic_result = maybe_magic_result
 104
 105     maybe_unfolding_info
 106         = case (info_from_env, unfolding_from_id) of
 107
 108              (Just (_, occ_info, OutUnfolding enc_cc unf), _)
 109                 -> Just (occ_info, setEnclosingCC env enc_cc, unf)
 110
 111              (_, CoreUnfolding unf)
 112                 -> Just (noBinderInfo, env, unf)
 113
 114              other -> Nothing
 115
 116     Just (occ_info, unf_env, simple_unfolding) = maybe_unfolding_info
 117     SimpleUnfolding form guidance unf_template = simple_unfolding
 118
 119         ---------- Specialisation stuff
 120     (ty_args, remaining_args) = initialTyArgs args
 121     maybe_specialisation      = lookupSpecEnv (getIdSpecialisation var) ty_args
 122     Just (spec_bindings, spec_template) = maybe_specialisation
 123
 124
 125         ---------- Switches
 126     sw_chkr                   = getSwitchChecker env
 127     essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
 128     is_case_scrutinee         = switchIsOn sw_chkr SimplCaseScrutinee
 129     ok_to_inline              = okToInline (whnfOrBottom form) small_enough occ_info
 130     small_enough              = smallEnoughToInline var arg_evals is_case_scrutinee guidance
 131     arg_evals                 = [is_evald arg | arg <- args, isValArg arg]
 132
 133     is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
 134     is_evald (LitArg l) = True
 135
 136
 137 -- Perform the unfolding
 138 unfold var unf_env unf_template args result_ty
 139  =
 140 {-
 141     simplCount          `thenSmpl` \ n ->
 142     (if n > 1000 then
 143         pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var])
 144     else
 145         id
 146     )
 147     (if n>4000 then
 148        returnSmpl (mkGenApp (Var var) args)
 149     else
 150 -}
 151     tickUnfold var              `thenSmpl_`
 152     simplExpr unf_env unf_template args result_ty
 153
 154
 155 -- costCentreOk checks that it's ok to inline this thing
 156 -- The time it *isn't* is this:
 157 --
 158 --      f x = let y = E in
 159 --            scc "foo" (...y...)
 160 --
 161 -- Here y has a "current cost centre", and we can't inline it inside "foo",
 162 -- regardless of whether E is a WHNF or not.
 163
 164 costCentreOk cc_encl cc_rhs
 165   = isCurrentCostCentre cc_encl || not (isCurrentCostCentre cc_rhs)
 166 \end{code}
 167
 168
 169 %************************************************************************
 170 %*                                                                      *
 171 \section{Dealing with a single binder}
 172 %*                                                                      *
 173 %************************************************************************
 174
 175 When we hit a binder we may need to
 176   (a) apply the the type envt (if non-empty) to its type
 177   (b) apply the type envt and id envt to its SpecEnv (if it has one)
 178   (c) give it a new unique to avoid name clashes
 179
 180 \begin{code}
 181 simplBinder :: SimplEnv -> InBinder -> SmplM (SimplEnv, OutId)
 182 simplBinder env (id, _)
 183   |  not_in_scope               -- Not in scope, so no need to clone
 184   && empty_ty_subst             -- No type substitution to do inside the Id
 185   && isNullIdEnv id_subst       -- No id substitution to do inside the Id
 186   = let
 187         env' = setIdEnv env (addOneToIdEnv in_scope_ids id id, id_subst)
 188     in
 189     returnSmpl (env', id)
 190
 191   | otherwise
 192   =
 193 #if DEBUG
 194     -- I  reckon the empty-env thing should catch
 195     -- most no-free-tyvars things, so this test should be redundant
 196     (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x))
 197 #endif
 198     (let
 199        -- id1 has its type zapped
 200        id1 | empty_ty_subst = id
 201            | otherwise      = mkIdWithNewType id ty'
 202
 203        -- id2 has its SpecEnv zapped
 204        id2 | isEmptySpecEnv spec_env = id1
 205            | otherwise               = setIdSpecialisation id spec_env'
 206     in
 207     if not_in_scope then
 208         -- No need to clone
 209         let
 210             env' = setIdEnv env (addOneToIdEnv in_scope_ids id id2, id_subst)
 211         in
 212         returnSmpl (env', id2)
 213     else
 214         -- Must clone
 215         getUniqueSmpl         `thenSmpl` \ uniq ->
 216         let
 217             id3 = mkIdWithNewUniq id2 uniq
 218             env' = setIdEnv env (addOneToIdEnv in_scope_ids id3 id3,
 219                                  addOneToIdEnv id_subst id (VarArg id3))
 220         in
 221         returnSmpl (env', id3)
 222     )
 223   where
 224     ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
 225     empty_ty_subst   = isEmptyTyVarEnv ty_subst
 226     not_in_scope     = not (id `elemIdEnv` in_scope_ids)
 227
 228     ty               = idType id
 229     ty'              = instantiateTy ty_subst ty
 230
 231     spec_env         = getIdSpecialisation id
 232     spec_env'        = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
 233
 234 simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId])
 235 simplBinders env binders = mapAccumLSmpl simplBinder env binders
 236 \end{code}
 237
 238 \begin{code}
 239 simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar)
 240 simplTyBinder env tyvar
 241   | not (tyvar `elementOfTyVarSet` tyvars)      -- No need to clone
 242   = let
 243         env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar, ty_subst)
 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}