2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[SimplVar]{Simplifier stuff related to variables}
7 #include "HsVersions.h"
15 IMPORT_DELOOPER(SmplLoop) ( simplExpr )
17 import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
18 uNFOLDING_CON_DISCOUNT_WEIGHT
20 import CmdLineOpts ( intSwitchSet, switchIsOn, SimplifierSwitch(..) )
22 import CoreUnfold ( whnfDetails, UnfoldingDetails(..), UnfoldingGuidance(..),
25 import Id ( idType, getIdInfo,
26 GenId{-instance Outputable-}
28 import IdInfo ( DeforestInfo(..) )
29 import Literal ( isNoRepLit )
30 import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
31 import PprStyle ( PprStyle(..) )
32 import PprType ( GenType{-instance Outputable-} )
33 import Pretty ( ppBesides, ppStr )
36 import TyCon ( tyConFamilySize )
37 import Type ( isPrimType, getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts )
38 import Util ( pprTrace, assertPanic, panic )
41 %************************************************************************
43 \subsection[Simplify-var]{Completing variables}
45 %************************************************************************
47 This where all the heavy-duty unfolding stuff comes into its own.
50 completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr
52 completeVar env var args
54 boring_result = mkGenApp (Var var) args
56 case (lookupUnfolding env var) of
58 GenForm form_summary template guidance
59 -> considerUnfolding env var args
60 (panic "completeVar"{-txt_occ-}) form_summary template guidance
62 MagicForm str magic_fun
63 -> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
65 Nothing -> returnSmpl boring_result
67 {- pprTrace "MagicForm:- " (ppAbove
73 ppr PprDebug magic_result])) (returnSmpl ()) `thenSmpl` \ () ->
75 tick MagicUnfold `thenSmpl_`
76 returnSmpl magic_result
79 -- IWantToBeINLINEd _ -> returnSmpl boring_result
81 other -> returnSmpl boring_result
85 %************************************************************************
87 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
89 %************************************************************************
91 We have very limited information about an unfolding expression: (1)~so
92 many type arguments and so many value arguments expected---for our
93 purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
94 a single integer. (3)~An ``argument info'' vector. For this, what we
95 have at the moment is a Boolean per argument position that says, ``I
96 will look with great favour on an explicit constructor in this
99 Assuming we have enough type- and value arguments (if not, we give up
100 immediately), then we see if the ``discounted size'' is below some
101 (semi-arbitrary) threshold. It works like this: for every argument
102 position where we're looking for a constructor AND WE HAVE ONE in our
103 hands, we get a (again, semi-arbitrary) discount [proportion to the
104 number of constructors in the type being scrutinized].
109 -> OutId -- Id we're thinking about
110 -> [OutArg] -- Applied to these
111 -> Bool -- If True then *always* inline,
112 -- because it's the only one
114 -> InExpr -- Template for unfolding;
115 -> UnfoldingGuidance -- To help us decide...
116 -> SmplM CoreExpr -- Result!
118 considerUnfolding env var args txt_occ form_summary template guidance
119 | switchIsOn sw_chkr EssentialUnfoldingsOnly
120 = dont_go_for_it -- we're probably in a hurry in this simpl round...
123 = pprTrace "" (ppBesides [ppStr "not attempting to unfold `",
125 ppStr "' due to DEFOREST pragma"])
131 | (case form_summary of {BottomForm -> True; other -> False} &&
132 not (any isPrimType [ ty | (TyArg ty) <- args ]))
133 -- Always inline bottoming applications, unless
134 -- there's a primitive type lurking around...
139 -- If this is a deforestable Id, then don't unfold it (the deforester
142 case getInfo (getIdInfo var) of {
143 DoDeforest -> pprTrace "" (ppBesides [ppStr "not unfolding `",
145 ppStr "' due to DEFOREST pragma"])
150 UnfoldNever -> dont_go_for_it
152 UnfoldAlways -> go_for_it
154 EssentialUnfolding -> go_for_it
156 UnfoldIfGoodArgs m_tys_wanted n_vals_wanted is_con_vec size
157 -> if m_tys_wanted > no_tyargs
158 || n_vals_wanted > no_valargs then
159 --pprTrace "dont_go_for_it1:" (ppAbove (ppr PprDebug guidance) (ppr PprDebug var))
162 else if n_vals_wanted == 0
163 && rhs_looks_like_a_Con then
164 -- we are very keen on inlining data values
165 -- (see comments elsewhere); we ignore any size issues!
168 else -- we try the fun stuff
171 = discountedCost env con_discount size no_valargs is_con_vec valargs
173 if discounted_size <= unfold_use_threshold then
176 --pprTrace "dont_go_for_it2:" (ppCat [ppr PprDebug var, ppInt size, ppInt discounted_size, ppInt unfold_use_threshold, ppr PprDebug guidance])
180 sw_chkr = getSwitchChecker env
183 = case (intSwitchSet sw_chkr SimplUnfoldingUseThreshold) of
184 Nothing -> uNFOLDING_USE_THRESHOLD
187 con_discount -- ToDo: ************ get from a switch *********
188 = uNFOLDING_CON_DISCOUNT_WEIGHT
190 (_, _, tyargs, valargs) = collectArgs args_in_dummy_expr
191 no_tyargs = length tyargs
192 no_valargs = length valargs
193 args_in_dummy_expr = mkGenApp (Var (panic "SimplVar.dummy")) args
194 -- we concoct this dummy expr, just so we can use collectArgs
195 -- (rather than make up a special-purpose bit of code)
199 (_,_,val_binders,body) = collectBinders template
201 case (val_binders, body) of
202 ([], Con _ _) -> True
205 dont_go_for_it = returnSmpl (mkGenApp (Var var) args)
207 go_for_it = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) (
208 tick UnfoldingDone `thenSmpl_`
209 simplExpr env template args
215 do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
220 type ArgInfoVector = [Bool]
223 :: SimplEnv -- so we can look up things about the args
224 -> Int -- the discount for a "constructor" hit;
225 -- we multiply by the # of cons in the type.
226 -> Int -- the size/cost of the expr
227 -> Int -- the number of val args (== length args)
228 -> ArgInfoVector -- what we know about the *use* of the arguments
229 -> [OutArg] -- *an actual set of value arguments*!
232 -- If we apply an expression (usually a function) of given "costs"
233 -- to a particular set of arguments (possibly none), what will
234 -- the resulting expression "cost"?
236 discountedCost env con_discount_weight size no_args is_con_vec args
237 = ASSERT(no_args == length args)
238 disc (size - no_args) is_con_vec args
239 -- we start w/ a "discount" equal to the # of args...
241 disc size [] _ = size
242 disc size _ [] = size
244 disc size (want_con_here:want_cons) (arg:rest_args)
246 full_price = disc size
247 take_something_off v = let
248 (tycon, _, _) = getAppDataTyConExpandingDicts (idType v)
249 no_cons = tyConFamilySize tycon
251 = size - (no_cons * con_discount_weight)
255 (if not want_con_here then
259 LitArg _ -> full_price
260 VarArg v | whnfDetails (lookupUnfolding env v) -> take_something_off v
261 | otherwise -> full_price
263 ) want_cons rest_args
266 We use this one to avoid exporting inlinings that we ``couldn't possibly
267 use'' on the other side. Can be overridden w/ flaggery.
271 -> Int -- the size/cost of the expr
272 -> Int -- number of value args
273 -> ArgInfoVector -- what we know about the *use* of the arguments
274 -> [Type] -- NB: actual arguments *not* looked at;
275 -- but we know their types
278 leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys
279 = ASSERT(no_val_args == length arg_tys)
280 disc (size - no_val_args) is_con_vec arg_tys
281 -- we start w/ a "discount" equal to the # of args...
283 -- ToDo: rather sad that this isn't commoned-up w/ the one above...
285 disc size [] _ = size
286 disc size _ [] = size
288 disc size (want_con_here:want_cons) (arg_ty:rest_arg_tys)
290 take_something_off tycon
292 no_cons = tyConFamilySize tycon
295 = size - (no_cons * con_discount_weight)
299 if not want_con_here then
300 disc size want_cons rest_arg_tys
302 case (maybeAppDataTyConExpandingDicts arg_ty, isPrimType arg_ty) of
303 (Just (tycon, _, _), False) ->
304 disc (take_something_off tycon) want_cons rest_arg_tys
306 other -> disc size want_cons rest_arg_tys