2 % (c) The AQUA Project, Glasgow University, 1993-1995
4 \section[SimplVar]{Simplifier stuff related to variables}
7 #include "HsVersions.h"
15 import SmplLoop ( simplExpr )
17 import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
18 uNFOLDING_CON_DISCOUNT_WEIGHT
20 import CmdLineOpts ( intSwitchSet, switchIsOn, SimplifierSwitch(..) )
22 import CoreUnfold ( 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, getAppDataTyCon, maybeAppDataTyCon )
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
59 | not (isNoRepLit lit)
60 -- Inline literals, if they aren't no-repish things
61 -> ASSERT( null args )
65 -- Always inline constructors.
66 -- See comments before completeLetBinding
67 -> ASSERT( null args )
68 returnSmpl (Con con con_args)
70 GenForm txt_occ form_summary template guidance
71 -> considerUnfolding env var args
72 txt_occ form_summary template guidance
74 MagicForm str magic_fun
75 -> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
77 Nothing -> returnSmpl boring_result
79 {- pprTrace "MagicForm:- " (ppAbove
85 ppr PprDebug magic_result])) (returnSmpl ()) `thenSmpl` \ () ->
87 tick MagicUnfold `thenSmpl_`
88 returnSmpl magic_result
91 -- IWantToBeINLINEd _ -> returnSmpl boring_result
93 other -> returnSmpl boring_result
97 %************************************************************************
99 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
101 %************************************************************************
103 We have very limited information about an unfolding expression: (1)~so
104 many type arguments and so many value arguments expected---for our
105 purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
106 a single integer. (3)~An ``argument info'' vector. For this, what we
107 have at the moment is a Boolean per argument position that says, ``I
108 will look with great favour on an explicit constructor in this
111 Assuming we have enough type- and value arguments (if not, we give up
112 immediately), then we see if the ``discounted size'' is below some
113 (semi-arbitrary) threshold. It works like this: for every argument
114 position where we're looking for a constructor AND WE HAVE ONE in our
115 hands, we get a (again, semi-arbitrary) discount [proportion to the
116 number of constructors in the type being scrutinized].
121 -> OutId -- Id we're thinking about
122 -> [OutArg] -- Applied to these
123 -> Bool -- If True then *always* inline,
124 -- because it's the only one
126 -> InExpr -- Template for unfolding;
127 -> UnfoldingGuidance -- To help us decide...
128 -> SmplM CoreExpr -- Result!
130 considerUnfolding env var args txt_occ form_summary template guidance
131 | switchIsOn sw_chkr EssentialUnfoldingsOnly
132 = dont_go_for_it -- we're probably in a hurry in this simpl round...
135 = pprTrace "" (ppBesides [ppStr "not attempting to unfold `",
137 ppStr "' due to DEFOREST pragma"])
143 | (case form_summary of {BottomForm -> True; other -> False} &&
144 not (any isPrimType [ ty | (TyArg ty) <- args ]))
145 -- Always inline bottoming applications, unless
146 -- there's a primitive type lurking around...
151 -- If this is a deforestable Id, then don't unfold it (the deforester
154 case getInfo (getIdInfo var) of {
155 DoDeforest -> pprTrace "" (ppBesides [ppStr "not unfolding `",
157 ppStr "' due to DEFOREST pragma"])
162 UnfoldNever -> dont_go_for_it
164 UnfoldAlways -> go_for_it
166 EssentialUnfolding -> go_for_it
168 UnfoldIfGoodArgs m_tys_wanted n_vals_wanted is_con_vec size
169 -> if m_tys_wanted > no_tyargs
170 || n_vals_wanted > no_valargs then
171 --pprTrace "dont_go_for_it1:" (ppAbove (ppr PprDebug guidance) (ppr PprDebug var))
174 else if n_vals_wanted == 0
175 && rhs_looks_like_a_Con then
176 -- we are very keen on inlining data values
177 -- (see comments elsewhere); we ignore any size issues!
180 else -- we try the fun stuff
183 = discountedCost env con_discount size no_valargs is_con_vec valargs
185 if discounted_size <= unfold_use_threshold then
188 --pprTrace "dont_go_for_it2:" (ppCat [ppr PprDebug var, ppInt size, ppInt discounted_size, ppInt unfold_use_threshold, ppr PprDebug guidance])
192 sw_chkr = getSwitchChecker env
195 = case (intSwitchSet sw_chkr SimplUnfoldingUseThreshold) of
196 Nothing -> uNFOLDING_USE_THRESHOLD
199 con_discount -- ToDo: ************ get from a switch *********
200 = uNFOLDING_CON_DISCOUNT_WEIGHT
202 (_, _, tyargs, valargs) = collectArgs args_in_dummy_expr
203 no_tyargs = length tyargs
204 no_valargs = length valargs
205 args_in_dummy_expr = mkGenApp (Var (panic "SimplVar.dummy")) args
206 -- we concoct this dummy expr, just so we can use collectArgs
207 -- (rather than make up a special-purpose bit of code)
211 (_,_,val_binders,body) = collectBinders template
213 case (val_binders, body) of
214 ([], Con _ _) -> True
217 dont_go_for_it = returnSmpl (mkGenApp (Var var) args)
219 go_for_it = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) (
220 tick UnfoldingDone `thenSmpl_`
221 simplExpr env template args
227 do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
232 type ArgInfoVector = [Bool]
235 :: SimplEnv -- so we can look up things about the args
236 -> Int -- the discount for a "constructor" hit;
237 -- we multiply by the # of cons in the type.
238 -> Int -- the size/cost of the expr
239 -> Int -- the number of val args (== length args)
240 -> ArgInfoVector -- what we know about the *use* of the arguments
241 -> [OutArg] -- *an actual set of value arguments*!
244 -- If we apply an expression (usually a function) of given "costs"
245 -- to a particular set of arguments (possibly none), what will
246 -- the resulting expression "cost"?
248 discountedCost env con_discount_weight size no_args is_con_vec args
249 = ASSERT(no_args == length args)
250 disc (size - no_args) is_con_vec args
251 -- we start w/ a "discount" equal to the # of args...
253 disc size [] _ = size
254 disc size _ [] = size
256 disc size (want_con_here:want_cons) (arg:rest_args)
258 full_price = disc size
259 take_something_off v = let
260 (tycon, _, _) = getAppDataTyCon (idType v)
261 no_cons = tyConFamilySize tycon
263 = size - (no_cons * con_discount_weight)
267 (if not want_con_here then
271 LitArg _ -> full_price
272 VarArg v -> case lookupUnfolding env v of
273 ConForm _ _ -> take_something_off v
274 other_form -> full_price
276 ) want_cons rest_args
279 We use this one to avoid exporting inlinings that we ``couldn't possibly
280 use'' on the other side. Can be overridden w/ flaggery.
284 -> Int -- the size/cost of the expr
285 -> Int -- number of value args
286 -> ArgInfoVector -- what we know about the *use* of the arguments
287 -> [Type] -- NB: actual arguments *not* looked at;
288 -- but we know their types
291 leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys
292 = ASSERT(no_val_args == length arg_tys)
293 disc (size - no_val_args) is_con_vec arg_tys
294 -- we start w/ a "discount" equal to the # of args...
296 -- ToDo: rather sad that this isn't commoned-up w/ the one above...
298 disc size [] _ = size
299 disc size _ [] = size
301 disc size (want_con_here:want_cons) (arg_ty:rest_arg_tys)
303 take_something_off tycon
305 no_cons = tyConFamilySize tycon
308 = size - (no_cons * con_discount_weight)
312 if not want_con_here then
313 disc size want_cons rest_arg_tys
315 case (maybeAppDataTyCon arg_ty, isPrimType arg_ty) of
316 (Just (tycon, _, _), False) ->
317 disc (take_something_off tycon) want_cons rest_arg_tys
319 other -> disc size want_cons rest_arg_tys