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     ) where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} Simplify ( simplExpr )
  14
  15 import Constants        ( uNFOLDING_USE_THRESHOLD,
  16                           uNFOLDING_CON_DISCOUNT_WEIGHT
  17                         )
  18 import CmdLineOpts      ( switchIsOn, SimplifierSwitch(..) )
  19 import CoreSyn
  20 import CoreUnfold       ( Unfolding(..), UfExpr, RdrName, UnfoldingGuidance(..),
  21                           SimpleUnfolding(..),
  22                           FormSummary, whnfOrBottom,
  23                           smallEnoughToInline )
  24 import BinderInfo       ( BinderInfo, noBinderInfo, okToInline )
  25
  26 import CostCentre       ( CostCentre, isCurrentCostCentre )
  27 import Id               ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation,
  28                           idMustBeINLINEd, GenId{-instance Outputable-}
  29                         )
  30 import SpecEnv          ( matchSpecEnv )
  31 import Literal          ( isNoRepLit )
  32 import MagicUFs         ( applyMagicUnfoldingFun, MagicUnfoldingFun )
  33 import PprType          ( GenType{-instance Outputable-} )
  34 import SimplEnv
  35 import SimplMonad
  36 import TyCon            ( tyConFamilySize )
  37 import Maybes           ( maybeToBool )
  38 import Outputable
  39 \end{code}
  40
  41 %************************************************************************
  42 %*                                                                      *
  43 \subsection[Simplify-var]{Completing variables}
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 This where all the heavy-duty unfolding stuff comes into its own.
  48
  49 \begin{code}
  50 completeVar env var args result_ty
  51
  52   | maybeToBool maybe_magic_result
  53   = tick MagicUnfold    `thenSmpl_`
  54     magic_result
  55
  56         -- If there's an InUnfolding it means that there's no
  57         -- let-binding left for the thing, so we'd better inline it!
  58   | must_unfold
  59   = let
  60         Just (_, _, InUnfolding rhs_env rhs) = info_from_env
  61     in
  62     unfold var rhs_env rhs args result_ty
  63
  64
  65         -- Conditional unfolding. There's a binding for the
  66         -- thing, but perhaps we want to inline it anyway
  67   | (  maybeToBool maybe_unfolding_info
  68     && (not essential_unfoldings_only || idMustBeINLINEd var)
  69         -- If "essential_unfoldings_only" is true we do no inlinings at all,
  70         -- EXCEPT for things that absolutely have to be done
  71         -- (see comments with idMustBeINLINEd)
  72     && ok_to_inline
  73     && costCentreOk (getEnclosingCC env) (getEnclosingCC unf_env)
  74     )
  75   = unfold var unf_env unf_template args result_ty
  76
  77
  78   | maybeToBool maybe_specialisation
  79   = tick SpecialisationDone     `thenSmpl_`
  80     simplExpr (extendTyEnvEnv env spec_bindings)
  81               spec_template
  82               remaining_args
  83               result_ty
  84
  85   | otherwise
  86   = returnSmpl (mkGenApp (Var var) args)
  87
  88   where
  89     info_from_env     = lookupOutIdEnv env var
  90     unfolding_from_id = getIdUnfolding var
  91
  92         ---------- Magic unfolding stuff
  93     maybe_magic_result  = case unfolding_from_id of
  94                                 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
  95                                                                                     env args
  96                                 other                     -> Nothing
  97     (Just magic_result) = maybe_magic_result
  98
  99         ---------- Unfolding stuff
 100     must_unfold = case info_from_env of
 101                         Just (_, _, InUnfolding _ _) -> True
 102                         other                        -> False
 103
 104     maybe_unfolding_info
 105         = case (info_from_env, unfolding_from_id) of
 106
 107              (Just (_, occ_info, OutUnfolding enc_cc unf), _)
 108                 -> Just (occ_info, setEnclosingCC env enc_cc, unf)
 109
 110              (_, CoreUnfolding unf)
 111                 -> Just (noBinderInfo, env, unf)
 112
 113              other -> Nothing
 114
 115     Just (occ_info, unf_env, simple_unfolding) = maybe_unfolding_info
 116     SimpleUnfolding form guidance unf_template = simple_unfolding
 117
 118         ---------- Specialisation stuff
 119     (ty_args, remaining_args) = initialTyArgs args
 120     maybe_specialisation = matchSpecEnv (getIdSpecialisation var) ty_args
 121     Just (spec_bindings, spec_template) = maybe_specialisation
 122
 123
 124         ---------- Switches
 125     sw_chkr                   = getSwitchChecker env
 126     essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
 127     is_case_scrutinee         = switchIsOn sw_chkr SimplCaseScrutinee
 128     ok_to_inline              = okToInline (whnfOrBottom form) small_enough occ_info
 129     small_enough              = smallEnoughToInline arg_evals is_case_scrutinee guidance
 130     arg_evals                 = [is_evald arg | arg <- args, isValArg arg]
 131
 132     is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
 133     is_evald (LitArg l) = True
 134
 135
 136 -- Perform the unfolding
 137 unfold var unf_env unf_template args result_ty
 138  =
 139 {-
 140     simplCount          `thenSmpl` \ n ->
 141     (if n > 1000 then
 142         pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var])
 143     else
 144         id
 145     )
 146     (if n>4000 then
 147        returnSmpl (mkGenApp (Var var) args)
 148     else
 149 -}
 150     tickUnfold var              `thenSmpl_`
 151     simplExpr unf_env unf_template args result_ty
 152
 153
 154 -- costCentreOk checks that it's ok to inline this thing
 155 -- The time it *isn't* is this:
 156 --
 157 --      f x = let y = E in
 158 --            scc "foo" (...y...)
 159 --
 160 -- Here y has a "current cost centre", and we can't inline it inside "foo",
 161 -- regardless of whether E is a WHNF or not.
 162
 163 costCentreOk cc_encl cc_rhs
 164   = isCurrentCostCentre cc_encl || not (isCurrentCostCentre cc_rhs)
 165 \end{code}
 166