2 % (c) The AQUA Project, Glasgow University, 1993-1995
4 \section[SimplVar]{Simplifier stuff related to variables}
7 #include "HsVersions.h"
20 import BasicLit ( isNoRepLit )
22 import AbsUniType ( getUniDataTyCon, getUniDataTyCon_maybe,
23 getTyConFamilySize, isPrimType
25 import BinderInfo ( oneTextualOcc, oneSafeOcc )
26 import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
27 uNFOLDING_CON_DISCOUNT_WEIGHT
29 import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..) )
30 import Id ( getIdUniType, getIdInfo )
32 import Maybes ( maybeToBool, Maybe(..) )
33 import Simplify ( simplExpr )
34 import SimplUtils ( simplIdWantsToBeINLINEd )
40 %************************************************************************
42 \subsection[Simplify-var]{Completing variables}
44 %************************************************************************
46 This where all the heavy-duty unfolding stuff comes into its own.
49 completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr
51 completeVar env var args
53 boring_result = applyToArgs (CoVar var) args
55 case (lookupUnfolding env var) of
58 | not (isNoRepLit lit)
59 -- Inline literals, if they aren't no-repish things
60 -> ASSERT( null args )
61 returnSmpl (CoLit lit)
63 ConstructorForm con ty_args val_args
64 -- Always inline constructors.
65 -- See comments before completeLetBinding
66 -> ASSERT( null args )
67 returnSmpl (CoCon con ty_args val_args)
69 GeneralForm txt_occ form_summary template guidance
70 -> considerUnfolding env var args
71 txt_occ form_summary template guidance
73 MagicForm str magic_fun
74 -> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
76 Nothing -> returnSmpl boring_result
78 {- pprTrace "MagicForm:- " (ppAbove
84 ppr PprDebug magic_result])) (returnSmpl ()) `thenSmpl` \ () ->
86 tick MagicUnfold `thenSmpl_`
87 returnSmpl magic_result
89 IWantToBeINLINEd _ -> returnSmpl boring_result
91 other -> returnSmpl boring_result
95 %************************************************************************
97 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
99 %************************************************************************
101 We have very limited information about an unfolding expression: (1)~so
102 many type arguments and so many value arguments expected---for our
103 purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
104 a single integer. (3)~An ``argument info'' vector. For this, what we
105 have at the moment is a Boolean per argument position that says, ``I
106 will look with great favour on an explicit constructor in this
109 Assuming we have enough type- and value arguments (if not, we give up
110 immediately), then we see if the ``discounted size'' is below some
111 (semi-arbitrary) threshold. It works like this: for every argument
112 position where we're looking for a constructor AND WE HAVE ONE in our
113 hands, we get a (again, semi-arbitrary) discount [proportion to the
114 number of constructors in the type being scrutinized].
119 -> OutId -- Id we're thinking about
120 -> [OutArg] -- Applied to these
121 -> Bool -- If True then *always* inline,
122 -- because it's the only one
124 -> InExpr -- Template for unfolding;
125 -> UnfoldingGuidance -- To help us decide...
126 -> SmplM PlainCoreExpr -- Result!
128 considerUnfolding env var args txt_occ form_summary template guidance
129 | switchIsOn sw_chkr EssentialUnfoldingsOnly
130 = dont_go_for_it -- we're probably in a hurry in this simpl round...
133 = pprTrace "" (ppBesides [ppStr "not attempting to unfold `",
135 ppStr "' due to DEFOREST pragma"])
141 | (case form_summary of {BottomForm -> True; other -> False} &&
142 not (any isPrimType [ ty | (TypeArg ty) <- args ]))
143 -- Always inline bottoming applications, unless
144 -- there's a primitive type lurking around...
149 -- If this is a deforestable Id, then don't unfold it (the deforester
152 case getInfo (getIdInfo var) of {
153 DoDeforest -> pprTrace "" (ppBesides [ppStr "not unfolding `",
155 ppStr "' due to DEFOREST pragma"])
160 UnfoldNever -> dont_go_for_it
162 UnfoldAlways -> go_for_it
164 EssentialUnfolding -> go_for_it
166 UnfoldIfGoodArgs m_tys_wanted n_vals_wanted is_con_vec size
167 -> if m_tys_wanted > no_tyargs
168 || n_vals_wanted > no_valargs then
169 --pprTrace "dont_go_for_it1:" (ppAbove (ppr PprDebug guidance) (ppr PprDebug var))
172 else if n_vals_wanted == 0
173 && looks_like_a_data_val_to_me then
174 -- we are very keen on inlining data values
175 -- (see comments elsewhere); we ignore any size issues!
178 else -- we try the fun stuff
181 = discountedCost env con_discount size no_valargs is_con_vec valargs
183 if discounted_size <= unfold_use_threshold then
186 --pprTrace "dont_go_for_it2:" (ppCat [ppr PprDebug var, ppInt size, ppInt discounted_size, ppInt unfold_use_threshold, ppr PprDebug guidance])
190 sw_chkr = getSwitchChecker env
193 = case (intSwitchSet sw_chkr SimplUnfoldingUseThreshold) of
194 Nothing -> uNFOLDING_USE_THRESHOLD
197 con_discount -- ToDo: ************ get from a switch *********
198 = uNFOLDING_CON_DISCOUNT_WEIGHT
200 (tyargs, valargs, args_left) = decomposeArgs args
201 no_tyargs = length tyargs
202 no_valargs = length valargs
204 looks_like_a_data_val_to_me
206 (_,val_binders,body) = digForLambdas template
208 case (val_binders, body) of
209 ([], CoCon _ _ _) -> True
212 dont_go_for_it = returnSmpl (applyToArgs (CoVar var) args)
214 go_for_it = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) (
215 tick UnfoldingDone `thenSmpl_`
216 simplExpr env template args
222 do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
227 type ArgInfoVector = [Bool]
230 :: SimplEnv -- so we can look up things about the args
231 -> Int -- the discount for a "constructor" hit;
232 -- we multiply by the # of cons in the type.
233 -> Int -- the size/cost of the expr
234 -> Int -- the number of val args (== length args)
235 -> ArgInfoVector -- what we know about the *use* of the arguments
236 -> [OutAtom] -- *an actual set of value arguments*!
239 -- If we apply an expression (usually a function) of given "costs"
240 -- to a particular set of arguments (possibly none), what will
241 -- the resulting expression "cost"?
243 discountedCost env con_discount_weight size no_args is_con_vec args
244 = ASSERT(no_args == length args)
245 disc (size - no_args) is_con_vec args
246 -- we start w/ a "discount" equal to the # of args...
248 disc size [] _ = size
249 disc size _ [] = size
251 disc size (want_con_here:want_cons) (arg:rest_args)
253 full_price = disc size
254 take_something_off v = let
255 (tycon, _, _) = getUniDataTyCon (getIdUniType v)
256 no_cons = case (getTyConFamilySize tycon) of
259 = size - (no_cons * con_discount_weight)
263 (if not want_con_here then
267 CoLitAtom _ -> full_price
268 CoVarAtom v -> case lookupUnfolding env v of
269 ConstructorForm _ _ _ -> take_something_off v
270 other_form -> full_price
272 ) want_cons rest_args
275 We use this one to avoid exporting inlinings that we ``couldn't possibly
276 use'' on the other side. Can be overridden w/ flaggery.
280 -> Int -- the size/cost of the expr
281 -> Int -- number of value args
282 -> ArgInfoVector -- what we know about the *use* of the arguments
283 -> [UniType] -- NB: actual arguments *not* looked at;
284 -- but we know their types
287 leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys
288 = ASSERT(no_val_args == length arg_tys)
289 disc (size - no_val_args) is_con_vec arg_tys
290 -- we start w/ a "discount" equal to the # of args...
292 -- ToDo: rather sad that this isn't commoned-up w/ the one above...
294 disc size [] _ = size
295 disc size _ [] = size
297 disc size (want_con_here:want_cons) (arg_ty:rest_arg_tys)
299 take_something_off tycon
301 no_cons = case (getTyConFamilySize tycon) of { Just n -> n }
304 = size - (no_cons * con_discount_weight)
308 if not want_con_here then
309 disc size want_cons rest_arg_tys
311 case (getUniDataTyCon_maybe arg_ty, isPrimType arg_ty) of
312 (Just (tycon, _, _), False) ->
313 disc (take_something_off tycon) want_cons rest_arg_tys
315 other -> disc size want_cons rest_arg_tys