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(..), SimpleUnfolding(..),
  26                           FormSummary,
  27                           okToInline, smallEnoughToInline )
  28 import BinderInfo       ( BinderInfo, noBinderInfo )
  29
  30 import CostCentre       ( CostCentre, isCurrentCostCentre )
  31 import Id               ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation,
  32                           idMustBeINLINEd, GenId{-instance Outputable-}
  33                         )
  34 import SpecEnv          ( SpecEnv, lookupSpecEnv )
  35 import IdInfo           ( DeforestInfo(..) )
  36 import Literal          ( isNoRepLit )
  37 import MagicUFs         ( applyMagicUnfoldingFun, MagicUnfoldingFun )
  38 import Outputable       ( Outputable(..), PprStyle(..) )
  39 import PprType          ( GenType{-instance Outputable-} )
  40 import SimplEnv
  41 import SimplMonad
  42 import TyCon            ( tyConFamilySize )
  43 import Util             ( pprTrace, assertPanic, panic )
  44 import Maybes           ( maybeToBool )
  45 import Pretty
  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   | not do_deforest &&
  64     maybeToBool maybe_unfolding_info &&
  65     (not essential_unfoldings_only || idMustBeINLINEd var) &&
  66         -- If "essential_unfolds_only" is true we do no inlinings at all,
  67         -- EXCEPT for things that absolutely have to be done
  68         -- (see comments with idMustBeINLINEd)
  69     ok_to_inline &&
  70     costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env)
  71
  72   =
  73 {-
  74     simplCount          `thenSmpl` \ n ->
  75     (if n > 1000 then
  76         pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr PprDebug var])
  77     else
  78         id
  79     )
  80     (if n>4000 then
  81        returnSmpl (mkGenApp (Var var) args)
  82     else
  83 -}
  84
  85     tickUnfold var              `thenSmpl_`
  86     simplExpr unfold_env unf_template args result_ty
  87
  88   | maybeToBool maybe_specialisation
  89   = tick SpecialisationDone     `thenSmpl_`
  90     simplExpr (extendTyEnvList env spec_bindings)
  91               spec_template
  92               (map TyArg leftover_ty_args ++ remaining_args)
  93               result_ty
  94
  95   | otherwise
  96   = returnSmpl (mkGenApp (Var var) args)
  97
  98   where
  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     maybe_unfolding_info
 110         = case (lookupOutIdEnv env var, unfolding_from_id) of
 111
 112              (Just (_, occ_info, OutUnfolding enc_cc unf), _)
 113                 -> Just (occ_info, setEnclosingCC env enc_cc, unf)
 114
 115              (Just (_, occ_info, InUnfolding env_unf unf), _)
 116                 -> -- pprTrace ("InUnfolding for ") (ppr PprDebug var) $
 117                    Just (occ_info, env_unf, unf)
 118
 119              (_, CoreUnfolding unf)
 120                 -> -- pprTrace ("CoreUnfolding for ") (ppr PprDebug var) $
 121                    Just (noBinderInfo, env, unf)
 122
 123              other -> Nothing
 124
 125     Just (occ_info, unfold_env, simple_unfolding)     = maybe_unfolding_info
 126     SimpleUnfolding form guidance unf_template = simple_unfolding
 127
 128         ---------- Specialisation stuff
 129     (ty_args, remaining_args) = initialTyArgs args
 130     maybe_specialisation = lookupSpecEnv (getIdSpecialisation var) ty_args
 131     (Just (spec_template, (spec_bindings, leftover_ty_args))) = maybe_specialisation
 132
 133
 134         ---------- Switches
 135     sw_chkr                   = getSwitchChecker env
 136     essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
 137     is_case_scrutinee         = switchIsOn sw_chkr SimplCaseScrutinee
 138     ok_to_inline              = okToInline form occ_info small_enough
 139     small_enough              = smallEnoughToInline arg_evals is_case_scrutinee guidance
 140     arg_evals                 = [is_evald arg | arg <- args, isValArg arg]
 141
 142     is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
 143     is_evald (LitArg l) = True
 144
 145 #if OMIT_DEFORESTER
 146     do_deforest = False
 147 #else
 148     do_deforest = case (getDeforestInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
 149 #endif
 150
 151
 152 -- costCentreOk checks that it's ok to inline this thing
 153 -- The time it *isn't* is this:
 154 --
 155 --      f x = let y = E in
 156 --            scc "foo" (...y...)
 157 --
 158 -- Here y has a "current cost centre", and we can't inline it inside "foo",
 159 -- regardless of whether E is a WHNF or not.
 160
 161 costCentreOk cc_encl cc_rhs
 162   = isCurrentCostCentre cc_encl || not (isCurrentCostCentre cc_rhs)
 163 \end{code}
 164