2 % (c) The AQUA Project, Glasgow University, 1993-1995
4 \section[SimplVar]{Simplifier stuff related to variables}
7 #include "HsVersions.h"
16 import Literal ( isNoRepLit )
18 import Type ( getAppDataTyCon, maybeAppDataTyCon,
19 getTyConFamilySize, isPrimType
21 import BinderInfo ( oneTextualOcc, oneSafeOcc )
22 import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
23 uNFOLDING_CON_DISCOUNT_WEIGHT
25 import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..) )
26 import Id ( idType, getIdInfo )
28 import Maybes ( maybeToBool, Maybe(..) )
29 import Simplify ( simplExpr )
30 import SimplUtils ( simplIdWantsToBeINLINEd )
36 %************************************************************************
38 \subsection[Simplify-var]{Completing variables}
40 %************************************************************************
42 This where all the heavy-duty unfolding stuff comes into its own.
45 completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr
47 completeVar env var args
49 boring_result = mkGenApp (Var var) args
51 case (lookupUnfolding env var) of
54 | not (isNoRepLit lit)
55 -- Inline literals, if they aren't no-repish things
56 -> ASSERT( null args )
59 ConForm con ty_args val_args
60 -- Always inline constructors.
61 -- See comments before completeLetBinding
62 -> ASSERT( null args )
63 returnSmpl (Con con ty_args val_args)
65 GenForm txt_occ form_summary template guidance
66 -> considerUnfolding env var args
67 txt_occ form_summary template guidance
69 MagicForm str magic_fun
70 -> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
72 Nothing -> returnSmpl boring_result
74 {- pprTrace "MagicForm:- " (ppAbove
80 ppr PprDebug magic_result])) (returnSmpl ()) `thenSmpl` \ () ->
82 tick MagicUnfold `thenSmpl_`
83 returnSmpl magic_result
85 IWantToBeINLINEd _ -> returnSmpl boring_result
87 other -> returnSmpl boring_result
91 %************************************************************************
93 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
95 %************************************************************************
97 We have very limited information about an unfolding expression: (1)~so
98 many type arguments and so many value arguments expected---for our
99 purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
100 a single integer. (3)~An ``argument info'' vector. For this, what we
101 have at the moment is a Boolean per argument position that says, ``I
102 will look with great favour on an explicit constructor in this
105 Assuming we have enough type- and value arguments (if not, we give up
106 immediately), then we see if the ``discounted size'' is below some
107 (semi-arbitrary) threshold. It works like this: for every argument
108 position where we're looking for a constructor AND WE HAVE ONE in our
109 hands, we get a (again, semi-arbitrary) discount [proportion to the
110 number of constructors in the type being scrutinized].
115 -> OutId -- Id we're thinking about
116 -> [OutArg] -- Applied to these
117 -> Bool -- If True then *always* inline,
118 -- because it's the only one
120 -> InExpr -- Template for unfolding;
121 -> UnfoldingGuidance -- To help us decide...
122 -> SmplM CoreExpr -- Result!
124 considerUnfolding env var args txt_occ form_summary template guidance
125 | switchIsOn sw_chkr EssentialUnfoldingsOnly
126 = dont_go_for_it -- we're probably in a hurry in this simpl round...
129 = pprTrace "" (ppBesides [ppStr "not attempting to unfold `",
131 ppStr "' due to DEFOREST pragma"])
137 | (case form_summary of {BottomForm -> True; other -> False} &&
138 not (any isPrimType [ ty | (TypeArg ty) <- args ]))
139 -- Always inline bottoming applications, unless
140 -- there's a primitive type lurking around...
145 -- If this is a deforestable Id, then don't unfold it (the deforester
148 case getInfo (getIdInfo var) of {
149 DoDeforest -> pprTrace "" (ppBesides [ppStr "not unfolding `",
151 ppStr "' due to DEFOREST pragma"])
156 UnfoldNever -> dont_go_for_it
158 UnfoldAlways -> go_for_it
160 EssentialUnfolding -> go_for_it
162 UnfoldIfGoodArgs m_tys_wanted n_vals_wanted is_con_vec size
163 -> if m_tys_wanted > no_tyargs
164 || n_vals_wanted > no_valargs then
165 --pprTrace "dont_go_for_it1:" (ppAbove (ppr PprDebug guidance) (ppr PprDebug var))
168 else if n_vals_wanted == 0
169 && rhs_looks_like_a_Con then
170 -- we are very keen on inlining data values
171 -- (see comments elsewhere); we ignore any size issues!
174 else -- we try the fun stuff
177 = discountedCost env con_discount size no_valargs is_con_vec valargs
179 if discounted_size <= unfold_use_threshold then
182 --pprTrace "dont_go_for_it2:" (ppCat [ppr PprDebug var, ppInt size, ppInt discounted_size, ppInt unfold_use_threshold, ppr PprDebug guidance])
186 sw_chkr = getSwitchChecker env
189 = case (intSwitchSet sw_chkr SimplUnfoldingUseThreshold) of
190 Nothing -> uNFOLDING_USE_THRESHOLD
193 con_discount -- ToDo: ************ get from a switch *********
194 = uNFOLDING_CON_DISCOUNT_WEIGHT
196 (tyargs, valargs, args_left) = decomposeArgs args
197 no_tyargs = length tyargs
198 no_valargs = length valargs
202 (_,_,val_binders,body) = collectBinders template
204 case (val_binders, body) of
205 ([], Con _ _ _) -> True
208 dont_go_for_it = returnSmpl (mkGenApp (Var var) args)
210 go_for_it = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) (
211 tick UnfoldingDone `thenSmpl_`
212 simplExpr env template args
218 do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
223 type ArgInfoVector = [Bool]
226 :: SimplEnv -- so we can look up things about the args
227 -> Int -- the discount for a "constructor" hit;
228 -- we multiply by the # of cons in the type.
229 -> Int -- the size/cost of the expr
230 -> Int -- the number of val args (== length args)
231 -> ArgInfoVector -- what we know about the *use* of the arguments
232 -> [OutAtom] -- *an actual set of value arguments*!
235 -- If we apply an expression (usually a function) of given "costs"
236 -- to a particular set of arguments (possibly none), what will
237 -- the resulting expression "cost"?
239 discountedCost env con_discount_weight size no_args is_con_vec args
240 = ASSERT(no_args == length args)
241 disc (size - no_args) is_con_vec args
242 -- we start w/ a "discount" equal to the # of args...
244 disc size [] _ = size
245 disc size _ [] = size
247 disc size (want_con_here:want_cons) (arg:rest_args)
249 full_price = disc size
250 take_something_off v = let
251 (tycon, _, _) = getAppDataTyCon (idType v)
252 no_cons = case (getTyConFamilySize tycon) of
255 = size - (no_cons * con_discount_weight)
259 (if not want_con_here then
263 LitArg _ -> full_price
264 VarArg v -> case lookupUnfolding env v of
265 ConForm _ _ _ -> take_something_off v
266 other_form -> full_price
268 ) want_cons rest_args
271 We use this one to avoid exporting inlinings that we ``couldn't possibly
272 use'' on the other side. Can be overridden w/ flaggery.
276 -> Int -- the size/cost of the expr
277 -> Int -- number of value args
278 -> ArgInfoVector -- what we know about the *use* of the arguments
279 -> [Type] -- NB: actual arguments *not* looked at;
280 -- but we know their types
283 leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys
284 = ASSERT(no_val_args == length arg_tys)
285 disc (size - no_val_args) is_con_vec arg_tys
286 -- we start w/ a "discount" equal to the # of args...
288 -- ToDo: rather sad that this isn't commoned-up w/ the one above...
290 disc size [] _ = size
291 disc size _ [] = size
293 disc size (want_con_here:want_cons) (arg_ty:rest_arg_tys)
295 take_something_off tycon
297 no_cons = case (getTyConFamilySize tycon) of { Just n -> n }
300 = size - (no_cons * con_discount_weight)
304 if not want_con_here then
305 disc size want_cons rest_arg_tys
307 case (maybeAppDataTyCon arg_ty, isPrimType arg_ty) of
308 (Just (tycon, _, _), False) ->
309 disc (take_something_off tycon) want_cons rest_arg_tys
311 other -> disc size want_cons rest_arg_tys