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 CgCompInfo       ( uNFOLDING_USE_THRESHOLD,
  17                           uNFOLDING_CON_DISCOUNT_WEIGHT
  18                         )
  19 import CmdLineOpts      ( switchIsOn, SimplifierSwitch(..) )
  20 import CoreSyn
  21 import CoreUnfold       ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding(..),
  22                           FormSummary,
  23                           smallEnoughToInline )
  24 import BinderInfo       ( BinderInfo, noBinderInfo, okToInline )
  25
  26 import CostCentre       ( CostCentre, noCostCentreAttached )
  27 import Id               ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation,
  28                           GenId{-instance Outputable-}
  29                         )
  30 import SpecEnv          ( SpecEnv, lookupSpecEnv )
  31 import IdInfo           ( DeforestInfo(..) )
  32 import Literal          ( isNoRepLit )
  33 import MagicUFs         ( applyMagicUnfoldingFun, MagicUnfoldingFun )
  34 import PprStyle         ( PprStyle(..) )
  35 import PprType          ( GenType{-instance Outputable-} )
  36 import Pretty           ( ppBesides, ppStr )
  37 import SimplEnv
  38 import SimplMonad
  39 import TyCon            ( tyConFamilySize )
  40 import Type             ( isPrimType, getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts )
  41 import Util             ( pprTrace, assertPanic, panic )
  42 import Maybes           ( maybeToBool )
  43 \end{code}
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection[Simplify-var]{Completing variables}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 This where all the heavy-duty unfolding stuff comes into its own.
  52
  53 \begin{code}
  54 completeVar env var args
  55
  56   | maybeToBool maybe_magic_result
  57   = tick MagicUnfold    `thenSmpl_`
  58     magic_result
  59
  60   | not do_deforest &&
  61     maybeToBool maybe_unfolding_info &&
  62     (always_inline || (ok_to_inline && not essential_unfoldings_only)) &&
  63     costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env)
  64   = tick UnfoldingDone  `thenSmpl_`
  65     simplExpr unfold_env unf_template args
  66
  67   | maybeToBool maybe_specialisation
  68   = tick SpecialisationDone     `thenSmpl_`
  69     simplExpr (extendTyEnvList env spec_bindings)
  70               spec_template
  71               (map TyArg leftover_ty_args ++ remaining_args)
  72
  73   | otherwise
  74   = returnSmpl (mkGenApp (Var var) args)
  75
  76   where
  77     unfolding_from_id = getIdUnfolding var
  78
  79         ---------- Magic unfolding stuff
  80     maybe_magic_result  = case unfolding_from_id of
  81                                 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
  82                                                                                     env args
  83                                 other                     -> Nothing
  84     (Just magic_result) = maybe_magic_result
  85
  86         ---------- Unfolding stuff
  87     maybe_unfolding_info
  88         = case (lookupOutIdEnv env var, unfolding_from_id) of
  89              (Just (_, occ_info, OutUnfolding enc_cc unf), _)
  90                 -> Just (occ_info, setEnclosingCC env enc_cc, unf)
  91              (Just (_, occ_info, InUnfolding env_unf unf), _)
  92                 -> Just (occ_info, combineSimplEnv env env_unf, unf)
  93              (_, CoreUnfolding unf)
  94                 -> Just (noBinderInfo, env, unf)
  95
  96              other -> Nothing
  97
  98     Just (occ_info, unfold_env, simple_unfolding)     = maybe_unfolding_info
  99     SimpleUnfolding form guidance unf_template = simple_unfolding
 100
 101         ---------- Specialisation stuff
 102     (ty_args, remaining_args) = initialTyArgs args
 103     maybe_specialisation = lookupSpecEnv (getIdSpecialisation var) ty_args
 104     (Just (spec_template, (spec_bindings, leftover_ty_args))) = maybe_specialisation
 105
 106
 107         ---------- Switches
 108     sw_chkr                   = getSwitchChecker env
 109     essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
 110     always_inline             = case guidance of {UnfoldAlways -> True; other -> False}
 111     ok_to_inline              = okToInline form
 112                                            occ_info
 113                                            small_enough
 114     small_enough = smallEnoughToInline con_disc unf_thresh arg_evals guidance
 115     arg_evals = [is_evald arg | arg <- args, isValArg arg]
 116
 117     is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
 118     is_evald (LitArg l) = True
 119
 120     con_disc   = getSimplIntSwitch sw_chkr SimplUnfoldingConDiscount
 121     unf_thresh = getSimplIntSwitch sw_chkr SimplUnfoldingUseThreshold
 122
 123 #if OMIT_DEFORESTER
 124     do_deforest = False
 125 #else
 126     do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
 127 #endif
 128
 129
 130 -- costCentreOk checks that it's ok to inline this thing
 131 -- The time it *isn't* is this:
 132 --
 133 --      f x = let y = E in
 134 --            scc "foo" (...y...)
 135 --
 136 -- Here y has a subsumed cost centre, and we can't inline it inside "foo",
 137 -- regardless of whether E is a WHNF or not.
 138
 139 costCentreOk cc_encl cc_rhs
 140   = noCostCentreAttached cc_encl || not (noCostCentreAttached cc_rhs)
 141 \end{code}
 142