2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[SimplVar]{Simplifier stuff related to variables}
7 #include "HsVersions.h"
14 IMPORT_DELOOPER(SmplLoop) ( simplExpr )
16 import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
17 uNFOLDING_CON_DISCOUNT_WEIGHT
19 import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) )
21 import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding(..),
24 import BinderInfo ( BinderInfo, noBinderInfo, okToInline )
26 import CostCentre ( CostCentre, noCostCentreAttached )
27 import Id ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation,
28 GenId{-instance Outputable-}
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 )
39 import TyCon ( tyConFamilySize )
40 import Type ( isPrimType, getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts )
41 import Util ( pprTrace, assertPanic, panic )
42 import Maybes ( maybeToBool )
45 %************************************************************************
47 \subsection[Simplify-var]{Completing variables}
49 %************************************************************************
51 This where all the heavy-duty unfolding stuff comes into its own.
54 completeVar env var args
56 | maybeToBool maybe_magic_result
57 = tick MagicUnfold `thenSmpl_`
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
67 | maybeToBool maybe_specialisation
68 = tick SpecialisationDone `thenSmpl_`
69 simplExpr (extendTyEnvList env spec_bindings)
71 (map TyArg leftover_ty_args ++ remaining_args)
74 = returnSmpl (mkGenApp (Var var) args)
77 unfolding_from_id = getIdUnfolding var
79 ---------- Magic unfolding stuff
80 maybe_magic_result = case unfolding_from_id of
81 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
84 (Just magic_result) = maybe_magic_result
86 ---------- Unfolding stuff
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)
98 Just (occ_info, unfold_env, simple_unfolding) = maybe_unfolding_info
99 SimpleUnfolding form guidance unf_template = simple_unfolding
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
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
114 small_enough = smallEnoughToInline con_disc unf_thresh arg_evals guidance
115 arg_evals = [is_evald arg | arg <- args, isValArg arg]
117 is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
118 is_evald (LitArg l) = True
120 con_disc = getSimplIntSwitch sw_chkr SimplUnfoldingConDiscount
121 unf_thresh = getSimplIntSwitch sw_chkr SimplUnfoldingUseThreshold
126 do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
130 -- costCentreOk checks that it's ok to inline this thing
131 -- The time it *isn't* is this:
133 -- f x = let y = E in
134 -- scc "foo" (...y...)
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.
139 costCentreOk cc_encl cc_rhs
140 = noCostCentreAttached cc_encl || not (noCostCentreAttached cc_rhs)