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 env var args
52 = tick MagicUnfold `thenSmpl_`
55 | has_unfolding && ok_to_inline
56 = tick UnfoldingDone `thenSmpl_`
57 simplExpr env the_unfolding args
60 = tick SpecialisationDone `thenSmpl_`
61 simplExpr (extendTyEnvList env spec_bindings)
66 = mkGenApp (Var var) args
69 unfolding = lookupUnfolding env var
71 (has_magic_unfolding, do_magic_unfold)
73 MagicForm str magic_fn
76 completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr
78 completeVar env var args
80 boring_result = mkGenApp (Var var) args
82 case (lookupUnfolding env var) of
84 GenForm form_summary template guidance
85 -> considerUnfolding env var args
86 (False{-ToDo:!-}{-txt_occ-}) form_summary template guidance
88 MagicForm str magic_fun
89 -> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
91 Nothing -> returnSmpl boring_result
93 {- pprTrace "MagicForm:- " (ppAbove
99 ppr PprDebug magic_result])) (returnSmpl ()) `thenSmpl` \ () ->
101 tick MagicUnfold `thenSmpl_`
102 returnSmpl magic_result
105 -- IWantToBeINLINEd _ -> returnSmpl boring_result
107 other -> returnSmpl boring_result
111 %************************************************************************
113 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
115 %************************************************************************
117 We have very limited information about an unfolding expression: (1)~so
118 many type arguments and so many value arguments expected---for our
119 purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
120 a single integer. (3)~An ``argument info'' vector. For this, what we
121 have at the moment is a Boolean per argument position that says, ``I
122 will look with great favour on an explicit constructor in this
125 Assuming we have enough type- and value arguments (if not, we give up
126 immediately), then we see if the ``discounted size'' is below some
127 (semi-arbitrary) threshold. It works like this: for every argument
128 position where we're looking for a constructor AND WE HAVE ONE in our
129 hands, we get a (again, semi-arbitrary) discount [proportion to the
130 number of constructors in the type being scrutinized].
135 -> OutId -- Id we're thinking about
136 -> [OutArg] -- Applied to these
137 -> Bool -- If True then *always* inline,
138 -- because it's the only one
140 -> InExpr -- Template for unfolding;
141 -> UnfoldingGuidance -- To help us decide...
142 -> SmplM CoreExpr -- Result!
144 considerUnfolding env var args txt_occ form_summary template guidance
145 | switchIsOn sw_chkr EssentialUnfoldingsOnly
146 = dont_go_for_it -- we're probably in a hurry in this simpl round...
149 = pprTrace "" (ppBesides [ppStr "not attempting to unfold `",
151 ppStr "' due to DEFOREST pragma"])
157 | (case form_summary of {BottomForm -> True; other -> False} &&
158 not (any isPrimType [ ty | (TyArg ty) <- args ]))
159 -- Always inline bottoming applications, unless
160 -- there's a primitive type lurking around...
165 -- If this is a deforestable Id, then don't unfold it (the deforester
168 case getInfo (getIdInfo var) of {
169 DoDeforest -> pprTrace "" (ppBesides [ppStr "not unfolding `",
171 ppStr "' due to DEFOREST pragma"])
176 UnfoldNever -> dont_go_for_it
178 UnfoldAlways -> go_for_it
180 EssentialUnfolding -> go_for_it
182 UnfoldIfGoodArgs m_tys_wanted n_vals_wanted is_con_vec size
183 -> if m_tys_wanted > no_tyargs
184 || n_vals_wanted > no_valargs then
185 --pprTrace "dont_go_for_it1:" (ppAbove (ppr PprDebug guidance) (ppr PprDebug var))
188 else if n_vals_wanted == 0
189 && rhs_looks_like_a_Con then
190 -- we are very keen on inlining data values
191 -- (see comments elsewhere); we ignore any size issues!
194 else -- we try the fun stuff
197 = discountedCost env con_discount size no_valargs is_con_vec valargs
199 if discounted_size <= unfold_use_threshold then
202 --pprTrace "dont_go_for_it2:" (ppCat [ppr PprDebug var, ppInt size, ppInt discounted_size, ppInt unfold_use_threshold, ppr PprDebug guidance])
206 sw_chkr = getSwitchChecker env
209 = case (intSwitchSet sw_chkr SimplUnfoldingUseThreshold) of
210 Nothing -> uNFOLDING_USE_THRESHOLD
213 con_discount -- ToDo: ************ get from a switch *********
214 = uNFOLDING_CON_DISCOUNT_WEIGHT
216 (_, _, tyargs, valargs) = collectArgs args_in_dummy_expr
217 no_tyargs = length tyargs
218 no_valargs = length valargs
219 args_in_dummy_expr = mkGenApp (Var (panic "SimplVar.dummy")) args
220 -- we concoct this dummy expr, just so we can use collectArgs
221 -- (rather than make up a special-purpose bit of code)
225 (_,_,val_binders,body) = collectBinders template
227 case (val_binders, body) of
228 ([], Con _ _) -> True
231 dont_go_for_it = returnSmpl (mkGenApp (Var var) args)
233 go_for_it = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) (
234 tick UnfoldingDone `thenSmpl_`
235 simplExpr env template args
241 do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
246 type ArgInfoVector = [Bool]
249 :: SimplEnv -- so we can look up things about the args
250 -> Int -- the discount for a "constructor" hit;
251 -- we multiply by the # of cons in the type.
252 -> Int -- the size/cost of the expr
253 -> Int -- the number of val args (== length args)
254 -> ArgInfoVector -- what we know about the *use* of the arguments
255 -> [OutArg] -- *an actual set of value arguments*!
258 -- If we apply an expression (usually a function) of given "costs"
259 -- to a particular set of arguments (possibly none), what will
260 -- the resulting expression "cost"?
262 discountedCost env con_discount_weight size no_args is_con_vec args
263 = ASSERT(no_args == length args)
264 disc (size - no_args) is_con_vec args
265 -- we start w/ a "discount" equal to the # of args...
267 disc size [] _ = size
268 disc size _ [] = size
270 disc size (want_con_here:want_cons) (arg:rest_args)
272 full_price = disc size
273 take_something_off v = let
274 (tycon, _, _) = getAppDataTyConExpandingDicts (idType v)
275 no_cons = tyConFamilySize tycon
277 = size - (no_cons * con_discount_weight)
281 (if not want_con_here then
285 LitArg _ -> full_price
286 VarArg v | whnfDetails (lookupUnfolding env v) -> take_something_off v
287 | otherwise -> full_price
289 ) want_cons rest_args
292 We use this one to avoid exporting inlinings that we ``couldn't possibly
293 use'' on the other side. Can be overridden w/ flaggery.
297 -> Int -- the size/cost of the expr
298 -> Int -- number of value args
299 -> ArgInfoVector -- what we know about the *use* of the arguments
300 -> [Type] -- NB: actual arguments *not* looked at;
301 -- but we know their types
304 leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys
305 = ASSERT(no_val_args == length arg_tys)
306 disc (size - no_val_args) is_con_vec arg_tys
307 -- we start w/ a "discount" equal to the # of args...
309 -- ToDo: rather sad that this isn't commoned-up w/ the one above...
311 disc size [] _ = size
312 disc size _ [] = size
314 disc size (want_con_here:want_cons) (arg_ty:rest_arg_tys)
316 take_something_off tycon
318 no_cons = tyConFamilySize tycon
321 = size - (no_cons * con_discount_weight)
325 if not want_con_here then
326 disc size want_cons rest_arg_tys
328 case (maybeAppDataTyConExpandingDicts arg_ty, isPrimType arg_ty) of
329 (Just (tycon, _, _), False) ->
330 disc (take_something_off tycon) want_cons rest_arg_tys
332 other -> disc size want_cons rest_arg_tys