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