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