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 #include "HsVersions.h"
   8
   9 module SimplVar (
  10         completeVar
  11     ) where
  12
  13 IMP_Ubiq(){-uitous-}
  14 IMPORT_DELOOPER(SmplLoop)               ( simplExpr )
  15
  16 import Constants        ( uNFOLDING_USE_THRESHOLD,
  17                           uNFOLDING_CON_DISCOUNT_WEIGHT
  18                         )
  19 import CmdLineOpts      ( switchIsOn, SimplifierSwitch(..) )
  20 import CoreSyn
  21 import CoreUnfold       ( Unfolding(..), UfExpr, RdrName, UnfoldingGuidance(..), SimpleUnfolding(..),
  22                           FormSummary,
  23                           okToInline, smallEnoughToInline )
  24 import BinderInfo       ( BinderInfo, noBinderInfo )
  25
  26 import CostCentre       ( CostCentre, noCostCentreAttached )
  27 import Id               ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation,
  28                           idMustBeINLINEd, GenId{-instance Outputable-}
  29                         )
  30 import SpecEnv          ( SpecEnv, lookupSpecEnv )
  31 import IdInfo           ( DeforestInfo(..) )
  32 import Literal          ( isNoRepLit )
  33 import MagicUFs         ( applyMagicUnfoldingFun, MagicUnfoldingFun )
  34 import Outputable       ( PprStyle(..) )
  35 import PprType          ( GenType{-instance Outputable-} )
  36 import SimplEnv
  37 import SimplMonad
  38 import TyCon            ( tyConFamilySize )
  39 import Util             ( pprTrace, assertPanic, panic )
  40 import Maybes           ( maybeToBool )
  41 import Pretty
  42 \end{code}
  43
  44 %************************************************************************
  45 %*                                                                      *
  46 \subsection[Simplify-var]{Completing variables}
  47 %*                                                                      *
  48 %************************************************************************
  49
  50 This where all the heavy-duty unfolding stuff comes into its own.
  51
  52 \begin{code}
  53 completeVar env var args result_ty
  54
  55   | maybeToBool maybe_magic_result
  56   = tick MagicUnfold    `thenSmpl_`
  57     magic_result
  58
  59   | not do_deforest &&
  60     maybeToBool maybe_unfolding_info &&
  61     (not essential_unfoldings_only || idMustBeINLINEd var) &&
  62     ok_to_inline &&
  63         -- If "essential_unfolds_only" is true we do no inlinings at all,
  64         -- EXCEPT for things that absolutely have to be done
  65         -- (see comments with idMustBeINLINEd)
  66         --
  67         -- Need to be careful: the RHS of INLINE functions is protected against inlining
  68         -- by essential_unfoldings_only being set true; we must not inline workers back into
  69         -- wrappers, even though the former have an unfold-always guidance.
  70     costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env)
  71   =
  72 {-
  73     simplCount          `thenSmpl` \ n ->
  74     (if n > 1000 then
  75         pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr PprDebug var])
  76     else
  77         id
  78     )
  79     (if n>4000 then
  80        returnSmpl (mkGenApp (Var var) args)
  81     else
  82 -}
  83
  84     tickUnfold var              `thenSmpl_`
  85     simplExpr unfold_env unf_template args result_ty
  86
  87   | maybeToBool maybe_specialisation
  88   = tick SpecialisationDone     `thenSmpl_`
  89     simplExpr (extendTyEnvList env spec_bindings)
  90               spec_template
  91               (map TyArg leftover_ty_args ++ remaining_args)
  92               result_ty
  93
  94   | otherwise
  95   = returnSmpl (mkGenApp (Var var) args)
  96
  97   where
  98     unfolding_from_id = getIdUnfolding var
  99
 100         ---------- Magic unfolding stuff
 101     maybe_magic_result  = case unfolding_from_id of
 102                                 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
 103                                                                                     env args
 104                                 other                     -> Nothing
 105     (Just magic_result) = maybe_magic_result
 106
 107         ---------- Unfolding stuff
 108     maybe_unfolding_info
 109         = case (lookupOutIdEnv env var, unfolding_from_id) of
 110
 111              (Just (_, occ_info, OutUnfolding enc_cc unf), _)
 112                 -> Just (occ_info, setEnclosingCC env enc_cc, unf)
 113
 114              (Just (_, occ_info, InUnfolding env_unf unf), _)
 115                 -> -- pprTrace ("InUnfolding for ") (ppr PprDebug var) $
 116                    Just (occ_info, env_unf, unf)
 117
 118              (_, CoreUnfolding unf)
 119                 -> -- pprTrace ("CoreUnfolding for ") (ppr PprDebug var) $
 120                    Just (noBinderInfo, env, unf)
 121
 122              other -> Nothing
 123
 124     Just (occ_info, unfold_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_template, (spec_bindings, leftover_ty_args))) = 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     always_inline             = case guidance of {UnfoldAlways -> True; other -> False}
 138
 139     ok_to_inline              = okToInline form occ_info small_enough
 140     small_enough              = smallEnoughToInline arg_evals is_case_scrutinee guidance
 141     arg_evals                 = [is_evald arg | arg <- args, isValArg arg]
 142
 143     is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
 144     is_evald (LitArg l) = True
 145
 146 #if OMIT_DEFORESTER
 147     do_deforest = False
 148 #else
 149     do_deforest = case (getDeforestInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
 150 #endif
 151
 152
 153 -- costCentreOk checks that it's ok to inline this thing
 154 -- The time it *isn't* is this:
 155 --
 156 --      f x = let y = E in
 157 --            scc "foo" (...y...)
 158 --
 159 -- Here y has a subsumed cost centre, and we can't inline it inside "foo",
 160 -- regardless of whether E is a WHNF or not.
 161
 162 costCentreOk cc_encl cc_rhs
 163   = noCostCentreAttached cc_encl || not (noCostCentreAttached cc_rhs)
 164 \end{code}
 165