CoreUnfold.lhs 30.1 KB
 simonpj committed Jun 08, 1999 1 %  Simon Marlow committed Oct 11, 2006 2 % (c) The University of Glasgow 2006  simonpj committed Jun 08, 1999 3 4 % (c) The AQUA Project, Glasgow University, 1994-1998 %  Simon Marlow committed Oct 11, 2006 5 6  Core-syntax unfoldings  simonpj committed Jun 08, 1999 7 8 9 10 11 12 13 14 15 16 17 18  Unfoldings (which can travel across module boundaries) are in Core syntax (namely @CoreExpr@s). The type @Unfolding@ sits above'' simply-Core-expressions unfoldings, capturing higher-level'' things we know about a binding, usually things that the simplifier found out (e.g., it's a literal''). In the corner of a @CoreUnfolding@ unfolding, you will find, unsurprisingly, a Core expression. \begin{code} module CoreUnfold (  simonpj committed Mar 27, 2000 19  Unfolding, UnfoldingGuidance, -- Abstract types  simonpj committed Jun 08, 1999 20   simonpj@microsoft.com committed Sep 10, 2008 21 22  noUnfolding, mkTopUnfolding, mkImplicitUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding,  simonpj committed Jan 31, 2005 23  evaldUnfolding, mkOtherCon, otherCons,  simonpj committed Jun 22, 1999 24  unfoldingTemplate, maybeUnfoldingTemplate,  simonpj committed Mar 23, 2000 25  isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,  simonpj committed Oct 25, 2000 26  hasUnfolding, hasSomeUnfolding, neverUnfold,  simonpj committed Jun 08, 1999 27 28  couldBeSmallEnoughToInline,  simonmar committed Aug 12, 2005 29  certainlyWillInline, smallEnoughToInline,  simonpj committed Jun 08, 1999 30   simonpj@microsoft.com committed Feb 07, 2008 31  callSiteInline, CallCtxt(..)  simonpj@microsoft.com committed Dec 04, 2007 32   simonpj committed Jun 08, 1999 33 34  ) where  Simon Marlow committed Oct 11, 2006 35 36 import StaticFlags import DynFlags  simonpj committed Jun 08, 1999 37 import CoreSyn  simonpj@microsoft.com committed May 04, 2006 38 import PprCore () -- Instances  Simon Marlow committed Oct 11, 2006 39 import OccurAnal  simonpj@microsoft.com committed Sep 10, 2008 40 41 import CoreSubst ( Subst, emptySubst, substTy, extendIdSubst, extendTvSubst , lookupIdSubst, substBndr, substBndrs, substRecBndrs )  Simon Marlow committed Oct 11, 2006 42 43 44 45 46 47 import CoreUtils import Id import DataCon import Literal import PrimOp import IdInfo  simonpj@microsoft.com committed Sep 10, 2008 48 import Type hiding( substTy, extendTvSubst )  Simon Marlow committed Oct 11, 2006 49 import PrelNames  simonpj committed Jun 08, 1999 50 import Bag  simonmar committed Oct 12, 2000 51 import FastTypes  Ian Lynagh committed Mar 29, 2008 52 import FastString  simonpj committed Jun 08, 1999 53 import Outputable  simonmar committed Sep 06, 1999 54   simonpj committed Jun 08, 1999 55 56 \end{code}  simonpj committed Mar 27, 2000 57   simonpj committed Jun 08, 1999 58 59 %************************************************************************ %* *  simonpj committed Mar 27, 2000 60 \subsection{Making unfoldings}  simonpj committed Jun 08, 1999 61 62 63 64 %* * %************************************************************************ \begin{code}  twanvl committed Jan 25, 2008 65 mkTopUnfolding :: CoreExpr -> Unfolding  simonpj committed Mar 30, 2000 66 mkTopUnfolding expr = mkUnfolding True {- Top level -} expr  simonpj committed Nov 01, 1999 67   simonpj@microsoft.com committed Sep 10, 2008 68 69 70 71 72 73 74 75 76 mkImplicitUnfolding :: CoreExpr -> Unfolding -- For implicit Ids, do a tiny bit of optimising first mkImplicitUnfolding expr = CoreUnfolding (simpleOptExpr emptySubst expr) True (exprIsHNF expr) (exprIsCheap expr) (calcUnfoldingGuidance opt_UF_CreationThreshold expr)  twanvl committed Jan 25, 2008 77 mkUnfolding :: Bool -> CoreExpr -> Unfolding  simonpj committed Mar 30, 2000 78 mkUnfolding top_lvl expr  simonpj committed Jul 19, 2005 79  = CoreUnfolding (occurAnalyseExpr expr)  simonpj committed Nov 01, 1999 80  top_lvl  simonpj committed Sep 26, 2001 81   simonpj committed Aug 10, 2005 82  (exprIsHNF expr)  simonpj committed Sep 14, 2000 83 84 85 86 87  -- Already evaluated (exprIsCheap expr) -- OK to inline inside a lambda  simonpj committed Mar 30, 2000 88  (calcUnfoldingGuidance opt_UF_CreationThreshold expr)  simonpj committed Mar 23, 2000 89 90 91 92 93 94 95 96  -- Sometimes during simplification, there's a large let-bound thing -- which has been substituted, and so is now dead; so 'expr' contains -- two copies of the thing while the occurrence-analysed expression doesn't -- Nevertheless, we don't occ-analyse before computing the size because the -- size computation bales out after a while, whereas occurrence analysis does not. -- -- This can occasionally mean that the guidance is very pessimistic; -- it gets fixed up next round  simonpj committed Jun 22, 1999 97   simonpj@microsoft.com committed May 04, 2006 98 instance Outputable Unfolding where  Ian Lynagh committed Apr 12, 2008 99 100 101  ppr NoUnfolding = ptext (sLit "No unfolding") ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e  simonpj@microsoft.com committed May 04, 2006 102  ppr (CoreUnfolding e top hnf cheap g)  Ian Lynagh committed Apr 12, 2008 103  = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g,  simonpj@microsoft.com committed May 04, 2006 104 105  ppr e]  twanvl committed Jan 25, 2008 106 mkCompulsoryUnfolding :: CoreExpr -> Unfolding  simonpj committed Nov 01, 1999 107 mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded  simonpj committed Jul 19, 2005 108  = CompulsoryUnfolding (occurAnalyseExpr expr)  simonpj committed Mar 27, 2000 109 \end{code}  simonpj committed Nov 01, 1999 110   simonpj committed Jul 14, 1999 111   simonpj committed Mar 27, 2000 112 113 114 115 116 %************************************************************************ %* * \subsection{The UnfoldingGuidance type} %* * %************************************************************************  simonpj committed Jun 08, 1999 117 118 119  \begin{code} instance Outputable UnfoldingGuidance where  Ian Lynagh committed Apr 12, 2008 120  ppr UnfoldNever = ptext (sLit "NEVER")  simonpj committed Jun 08, 1999 121  ppr (UnfoldIfGoodArgs v cs size discount)  Ian Lynagh committed Apr 12, 2008 122  = hsep [ ptext (sLit "IF_ARGS"), int v,  simonpj committed Sep 17, 1999 123  brackets (hsep (map int cs)),  simonpj committed Jun 08, 1999 124 125 126 127 128 129 130 131 132 133  int size, int discount ] \end{code} \begin{code} calcUnfoldingGuidance :: Int -- bomb out if size gets bigger than this -> CoreExpr -- expression to look at -> UnfoldingGuidance  simonpj committed Mar 30, 2000 134 calcUnfoldingGuidance bOMB_OUT_SIZE expr  simonpj committed Sep 17, 1999 135  = case collect_val_bndrs expr of { (inline, val_binders, body) ->  simonpj committed Nov 01, 1999 136 137  let n_val_binders = length val_binders  simonpj committed Mar 23, 2000 138   simonpj committed Mar 24, 2000 139  max_inline_size = n_val_binders+2  simonpj committed Mar 23, 2000 140 141 142 143 144 145  -- The idea is that if there is an INLINE pragma (inline is True) -- and there's a big body, we give a size of n_val_binders+2. This -- This is just enough to fail the no-size-increase test in callSiteInline, -- so that INLINE things don't get inlined into entirely boring contexts, -- but no more.  simonpj committed Nov 01, 1999 146  in  simonpj committed Oct 03, 2001 147  case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_binders body) of  simonpj committed Jun 08, 1999 148   simonpj committed Nov 01, 1999 149 150 151 152  TooBig | not inline -> UnfoldNever -- A big function with an INLINE pragma must -- have an UnfoldIfGoodArgs guidance  simonpj committed Oct 09, 2003 153  | otherwise -> UnfoldIfGoodArgs n_val_binders  simonpj committed Nov 01, 1999 154  (map (const 0) val_binders)  simonpj committed Mar 23, 2000 155  max_inline_size 0  simonpj committed Jun 08, 1999 156 157 158  SizeIs size cased_args scrut_discount -> UnfoldIfGoodArgs  simonpj committed Sep 17, 1999 159  n_val_binders  simonpj committed Jun 08, 1999 160  (map discount_for val_binders)  simonpj committed Sep 17, 1999 161  final_size  simonmar committed Oct 12, 2000 162  (iBox scrut_discount)  simonpj committed Jun 08, 1999 163  where  simonmar committed Oct 12, 2000 164  boxed_size = iBox size  simonpj committed Sep 17, 1999 165   simonpj committed Mar 23, 2000 166  final_size | inline = boxed_size min max_inline_size  simonpj committed Sep 17, 1999 167  | otherwise = boxed_size  simonpj committed Mar 23, 2000 168 169  -- Sometimes an INLINE thing is smaller than n_val_binders+2.  simonpj committed Sep 17, 1999 170 171 172  -- A particular case in point is a constructor, which has size 1. -- We want to inline this regardless, hence the min  simonpj committed Mar 23, 2000 173 174  discount_for b = foldlBag (\acc (b',n) -> if b==b' then acc+n else acc) 0 cased_args  simonpj committed Jun 08, 1999 175  }  simonpj committed Sep 17, 1999 176 177 178 179 180 181 182 183  where collect_val_bndrs e = go False [] e -- We need to be a bit careful about how we collect the -- value binders. In ptic, if we see -- __inline_me (\x y -> e) -- We want to say "2 value binders". Why? So that -- we take account of information given for the arguments  twanvl committed Jan 25, 2008 184  go _ rev_vbs (Note InlineMe e) = go True rev_vbs e  simonpj committed Sep 17, 1999 185 186 187  go inline rev_vbs (Lam b e) | isId b = go inline (b:rev_vbs) e | otherwise = go inline rev_vbs e go inline rev_vbs e = (inline, reverse rev_vbs, e)  simonpj committed Jun 08, 1999 188 189 190 \end{code} \begin{code}  Isaac Dupree committed Jan 17, 2008 191 sizeExpr :: FastInt -- Bomb out if it gets bigger than this  simonpj committed Jun 08, 1999 192 193 194 195 196  -> [Id] -- Arguments; we're interested in which of these -- get case'd -> CoreExpr -> ExprSize  simonmar committed Oct 12, 2000 197 sizeExpr bOMB_OUT_SIZE top_args expr  simonpj committed Jun 08, 1999 198 199  = size_up expr where  twanvl committed Jan 25, 2008 200 201  size_up (Type _) = sizeZero -- Types cost nothing size_up (Var _) = sizeOne  simonpj committed Jun 08, 1999 202   twanvl committed Jan 25, 2008 203  size_up (Note InlineMe _) = sizeOne -- Inline notes make it look very small  simonpj committed Mar 23, 2001 204 205 206 207 208 209 210  -- This can be important. If you have an instance decl like this: -- instance Foo a => Foo [a] where -- {-# INLINE op1, op2 #-} -- op1 = ... -- op2 = ... -- then we'll get a dfun which is a pair of two INLINE lambdas  twanvl committed Jan 25, 2008 211  size_up (Note _ body) = size_up body -- Other notes cost nothing  chak@cse.unsw.edu.au. committed Aug 04, 2006 212   twanvl committed Jan 25, 2008 213  size_up (Cast e _) = size_up e  simonpj committed Jun 08, 1999 214   twanvl committed Jan 25, 2008 215  size_up (App fun (Type _)) = size_up fun  simonpj committed Dec 07, 2000 216  size_up (App fun arg) = size_up_app fun [arg]  simonpj committed Jun 08, 1999 217   simonmar committed Dec 20, 2000 218  size_up (Lit lit) = sizeN (litSize lit)  simonpj committed Jun 08, 1999 219   simonpj committed Mar 23, 2000 220  size_up (Lam b e) | isId b = lamScrutDiscount (size_up e addSizeN 1)  simonpj committed Jun 08, 1999 221 222 223 224 225  | otherwise = size_up e size_up (Let (NonRec binder rhs) body) = nukeScrutDiscount (size_up rhs) addSize size_up body addSizeN  simonpj committed Jun 22, 1999 226 227 228  (if isUnLiftedType (idType binder) then 0 else 1) -- For the allocation -- If the binder has an unlifted type there is no allocation  simonpj committed Jun 08, 1999 229 230 231 232 233 234 235 236  size_up (Let (Rec pairs) body) = nukeScrutDiscount rhs_size addSize size_up body addSizeN length pairs -- For the allocation where rhs_size = foldr (addSize . size_up . snd) sizeZero pairs  simonpj committed Sep 30, 2004 237  size_up (Case (Var v) _ _ alts)  simonpj committed Aug 01, 2000 238  | v elem top_args -- We are scrutinising an argument variable  simonpj committed Sep 07, 2000 239 240 241 242 243  = {- I'm nuking this special case; BUT see the comment with case alternatives. (a) It's too eager. We don't want to inline a wrapper into a context with no benefit.  simonpj committed Dec 07, 2000 244  E.g. \ x. f (x+x) no point in inlining (+) here!  simonpj committed Sep 07, 2000 245 246 247 248 249 250  (b) It's ineffective. Once g's wrapper is inlined, its case-expressions aren't scrutinising arguments any more case alts of  Isaac Dupree committed Jan 17, 2008 251  [alt] -> size_up_alt alt addSize SizeIs (_ILIT(0)) (unitBag (v, 1)) (_ILIT(0))  simonpj committed Aug 01, 2000 252 253 254 255 256 257 258 259 260  -- We want to make wrapper-style evaluation look cheap, so that -- when we inline a wrapper it doesn't make call site (much) bigger -- Otherwise we get nasty phase ordering stuff: -- f x = g x x -- h y = ...(f e)... -- If we inline g's wrapper, f looks big, and doesn't get inlined -- into h; if we inline f first, while it looks small, then g's -- wrapper will get inlined later anyway. To avoid this nasty -- ordering difference, we make (case a of (x,y) -> ...),  simonmar committed Mar 31, 2005 261  -- *where a is one of the arguments* look free.  simonpj committed Aug 01, 2000 262   simonpj committed Sep 07, 2000 263 264 265  other -> -} alts_size (foldr addSize sizeOne alt_sizes) -- The 1 is for the scrutinee  simonpj committed Aug 01, 2000 266 267  (foldr1 maxSize alt_sizes)  simonpj committed Mar 23, 2000 268 269 270  -- Good to inline if an arg is scrutinised, because -- that may eliminate allocation in the caller -- And it eliminates the case itself  simonpj committed Aug 01, 2000 271   simonpj committed Mar 23, 2000 272 273 274  where alt_sizes = map size_up_alt alts  simonpj committed Aug 01, 2000 275 276  -- alts_size tries to compute a good discount for -- the case when we are scrutinising an argument variable  twanvl committed Jan 25, 2008 277 278  alts_size (SizeIs tot _tot_disc _tot_scrut) -- Size of all alternatives (SizeIs max max_disc max_scrut) -- Size of biggest alternative  Isaac Dupree committed Jan 17, 2008 279  = SizeIs tot (unitBag (v, iBox (_ILIT(1) +# tot -# max)) unionBags max_disc) max_scrut  simonpj committed Mar 23, 2000 280 281 282 283 284  -- If the variable is known, we produce a discount that -- will take us back to 'max', the size of rh largest alternative -- The 1+ is a little discount for reduced allocation in the caller alts_size tot_size _ = tot_size  simonpj committed Sep 30, 2004 285 286  size_up (Case e _ _ alts) = nukeScrutDiscount (size_up e) addSize foldr (addSize . size_up_alt) sizeZero alts  simonpj committed Mar 23, 2000 287 288 289 290 291  -- We don't charge for the case itself -- It's a strict thing, and the price of the call -- is paid by scrut. Also consider -- case f x of DEFAULT -> e -- This is just ';'! Don't charge for it.  simonpj committed Jun 08, 1999 292 293  ------------  simonpj committed Mar 23, 2000 294 295 296  size_up_app (App fun arg) args | isTypeArg arg = size_up_app fun args | otherwise = size_up_app fun (arg:args)  simonpj committed Nov 01, 1999 297  size_up_app fun args = foldr (addSize . nukeScrutDiscount . size_up)  simonpj committed Jan 04, 2000 298  (size_up_fun fun args)  simonpj committed Nov 01, 1999 299  args  simonpj committed Jun 08, 1999 300 301 302  -- A function application with at least one value argument -- so if the function is an argument give it an arg-discount  simonpj committed Mar 23, 2000 303  --  simonpj committed Jun 08, 1999 304  -- Also behave specially if the function is a build  simonpj committed Mar 23, 2000 305  --  simonpj committed Jan 04, 2000 306  -- Also if the function is a constant Id (constr or primop)  simonpj committed Mar 23, 2000 307 308  -- compute discounts specially size_up_fun (Var fun) args  simonpj committed May 25, 2000 309 310  | fun hasKey buildIdKey = buildSize | fun hasKey augmentIdKey = augmentSize  simonpj committed Mar 23, 2000 311  | otherwise  simonpj committed Mar 08, 2001 312  = case globalIdDetails fun of  simonpj committed Feb 12, 2003 313  DataConWorkId dc -> conSizeN dc (valArgCount args)  simonpj committed Mar 23, 2000 314   twanvl committed Jan 25, 2008 315  FCallId _ -> sizeN opt_UF_DearOp  simonpj committed Mar 23, 2000 316 317 318 319 320 321 322 323 324  PrimOpId op -> primOpSize op (valArgCount args) -- foldr addSize (primOpSize op) (map arg_discount args) -- At one time I tried giving an arg-discount if a primop -- is applied to one of the function's arguments, but it's -- not good. At the moment, any unlifted-type arg gets a -- 'True' for 'yes I'm evald', so we collect the discount even -- if we know nothing about it. And just having it in a primop -- doesn't help at all if we don't know something more.  twanvl committed Jan 25, 2008 325  _ -> fun_discount fun addSizeN  simonpj committed Mar 23, 2000 326 327 328 329 330 331 332 333  (1 + length (filter (not . exprIsTrivial) args)) -- The 1+ is for the function itself -- Add 1 for each non-trivial arg; -- the allocation cost, as in let(rec) -- Slight hack here: for constructors the args are almost always -- trivial; and for primops they are almost always prim typed -- We should really only count for non-prim-typed args in the -- general case, but that seems too much like hard work  simonpj committed Jan 04, 2000 334   twanvl committed Jan 25, 2008 335  size_up_fun other _ = size_up other  simonpj committed Jun 08, 1999 336 337  ------------  twanvl committed Jan 25, 2008 338  size_up_alt (_con, _bndrs, rhs) = size_up rhs  simonpj committed Sep 07, 2000 339 340  -- Don't charge for args, so that wrappers look cheap -- (See comments about wrappers with Case)  simonpj committed Jun 08, 1999 341 342 343  ------------ -- We want to record if we're case'ing, or applying, an argument  Isaac Dupree committed Jan 17, 2008 344  fun_discount v | v elem top_args = SizeIs (_ILIT(0)) (unitBag (v, opt_UF_FunAppDiscount)) (_ILIT(0))  twanvl committed Jan 25, 2008 345  fun_discount _ = sizeZero  simonpj committed Jun 08, 1999 346 347 348 349 350  ------------ -- These addSize things have to be here because -- I don't want to give them bOMB_OUT_SIZE as an argument  simonpj committed Oct 03, 2001 351 352  addSizeN TooBig _ = TooBig addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n +# iUnbox m) xs d  simonpj committed Jun 08, 1999 353   simonpj committed Oct 03, 2001 354 355 356 357  addSize TooBig _ = TooBig addSize _ TooBig = TooBig addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) = mkSizeIs bOMB_OUT_SIZE (n1 +# n2) (xs unionBags ys) (d1 +# d2)  simonpj committed Jun 08, 1999 358 359 360 361 362 363 \end{code} Code for manipulating sizes \begin{code} data ExprSize = TooBig  simonmar committed Oct 12, 2000 364  | SizeIs FastInt -- Size found  simonpj committed Mar 23, 2000 365  (Bag (Id,Int)) -- Arguments cased herein, and discount for each such  simonmar committed Oct 12, 2000 366  FastInt -- Size to subtract if result is scrutinised  simonpj committed Mar 23, 2000 367 368  -- by a case expression  simonmar committed Nov 06, 2001 369 370 371 372 373 -- subtract the discount before deciding whether to bale out. eg. we -- want to inline a large constructor application into a selector: -- tup = (a_1, ..., a_99) -- x = case tup of ... --  twanvl committed Jan 25, 2008 374 mkSizeIs :: FastInt -> FastInt -> Bag (Id, Int) -> FastInt -> ExprSize  simonpj committed Oct 03, 2001 375 376 377 mkSizeIs max n xs d | (n -# d) ># max = TooBig | otherwise = SizeIs n xs d  twanvl committed Jan 25, 2008 378 maxSize :: ExprSize -> ExprSize -> ExprSize  simonpj committed Mar 23, 2000 379 380 381 382 maxSize TooBig _ = TooBig maxSize _ TooBig = TooBig maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2 = s1 | otherwise = s2  simonpj committed Jun 08, 1999 383   twanvl committed Jan 25, 2008 384 385 386 387 sizeZero, sizeOne :: ExprSize sizeN :: Int -> ExprSize conSizeN :: DataCon ->Int -> ExprSize  Isaac Dupree committed Jan 17, 2008 388 389 390 sizeZero = SizeIs (_ILIT(0)) emptyBag (_ILIT(0)) sizeOne = SizeIs (_ILIT(1)) emptyBag (_ILIT(0)) sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT(0))  simonpj committed Sep 26, 2001 391 conSizeN dc n  Isaac Dupree committed Jan 17, 2008 392 393  | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n +# _ILIT(1)) | otherwise = SizeIs (_ILIT(1)) emptyBag (iUnbox n +# _ILIT(1))  simonpj committed Mar 23, 2000 394 395  -- Treat constructors as size 1; we are keen to expose them -- (and we charge separately for their args). We can't treat  simonmar committed Oct 12, 2000 396  -- them as size zero, else we find that (iBox x) has size 1,  simonpj committed Mar 23, 2000 397  -- which is the same as a lone variable; and hence 'v' will  simonmar committed Oct 12, 2000 398  -- always be replaced by (iBox x), where v is bound to iBox x.  simonpj committed Sep 26, 2001 399 400 401 402 403  -- -- However, unboxed tuples count as size zero -- I found occasions where we had -- f x y z = case op# x y z of { s -> (# s, () #) } -- and f wasn't getting inlined  simonpj committed Mar 23, 2000 404   twanvl committed Jan 25, 2008 405 primOpSize :: PrimOp -> Int -> ExprSize  simonpj committed Mar 23, 2000 406 407 primOpSize op n_args | not (primOpIsDupable op) = sizeN opt_UF_DearOp  simonpj committed Sep 26, 2001 408  | not (primOpOutOfLine op) = sizeN (2 - n_args)  simonpj committed Dec 07, 2000 409  -- Be very keen to inline simple primops.  simonpj committed Sep 26, 2001 410 411 412 413 414 415 416 417  -- We give a discount of 1 for each arg so that (op# x y z) costs 2. -- We can't make it cost 1, else we'll inline let v = (op# x y z) -- at every use of v, which is excessive. -- -- A good example is: -- let x = +# p q in C {x} -- Even though x get's an occurrence of 'many', its RHS looks cheap, -- and there's a good chance it'll get inlined back into C's RHS. Urgh!  simonpj committed Mar 23, 2000 418  | otherwise = sizeOne  simonpj committed Jun 08, 1999 419   twanvl committed Jan 25, 2008 420 buildSize :: ExprSize  Isaac Dupree committed Jan 17, 2008 421 buildSize = SizeIs (_ILIT(-2)) emptyBag (_ILIT(4))  simonpj committed Jun 08, 1999 422 423 424 425  -- We really want to inline applications of build -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later) -- Indeed, we should add a result_discount becuause build is -- very like a constructor. We don't bother to check that the  simonpj committed Jun 22, 1999 426  -- build is saturated (it usually is). The "-2" discounts for the \c n,  simonpj committed Jun 08, 1999 427  -- The "4" is rather arbitrary.  simonpj committed Jun 22, 1999 428   twanvl committed Jan 25, 2008 429 augmentSize :: ExprSize  Isaac Dupree committed Jan 17, 2008 430 augmentSize = SizeIs (_ILIT(-2)) emptyBag (_ILIT(4))  simonpj committed Jun 22, 1999 431 432  -- Ditto (augment t (\cn -> e) ys) should cost only the cost of -- e plus ys. The -2 accounts for the \cn  twanvl committed Jan 25, 2008 433 434 435 436  nukeScrutDiscount :: ExprSize -> ExprSize nukeScrutDiscount (SizeIs n vs _) = SizeIs n vs (_ILIT(0)) nukeScrutDiscount TooBig = TooBig  simonpj committed Mar 23, 2000 437 438  -- When we return a lambda, give a discount if it's used (applied)  twanvl committed Jan 25, 2008 439 440 441 lamScrutDiscount :: ExprSize -> ExprSize lamScrutDiscount (SizeIs n vs _) = case opt_UF_FunAppDiscount of { d -> SizeIs n vs (iUnbox d) } lamScrutDiscount TooBig = TooBig  simonpj committed Jun 08, 1999 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 \end{code} %************************************************************************ %* * \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} %* * %************************************************************************ We have very limited information about an unfolding expression: (1)~so many type arguments and so many value arguments expected---for our purposes here, we assume we've got those. (2)~A size'' or cost,'' a single integer. (3)~An argument info'' vector. For this, what we have at the moment is a Boolean per argument position that says, I will look with great favour on an explicit constructor in this position.'' (4)~The discount'' to subtract if the expression is being scrutinised. Assuming we have enough type- and value arguments (if not, we give up immediately), then we see if the discounted size'' is below some (semi-arbitrary) threshold. It works like this: for every argument position where we're looking for a constructor AND WE HAVE ONE in our hands, we get a (again, semi-arbitrary) discount [proportion to the number of constructors in the type being scrutinized]. If we're in the context of a scrutinee ( \tr{(case of A .. -> ...;.. )}) and the expression in question will evaluate to a constructor, we use the computed discount size *for the result only* rather than computing the argument discounts. Since we know the result of the expression is going to be taken apart, discounting its size is more accurate (see @sizeExpr@ above for how this discount size is computed). We use this one to avoid exporting inlinings that we couldn't possibly use'' on the other side. Can be overridden w/ flaggery. Just the same as smallEnoughToInline, except that it has no actual arguments. \begin{code}  simonpj committed Mar 23, 2000 480 couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool  simonpj committed Mar 30, 2000 481 couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold rhs of  twanvl committed Jan 25, 2008 482 483  UnfoldNever -> False _ -> True  simonpj committed Mar 23, 2000 484   simonpj committed Oct 24, 2001 485 486 487 488 certainlyWillInline :: Unfolding -> Bool -- Sees if the unfolding is pretty certain to inline certainlyWillInline (CoreUnfolding _ _ _ is_cheap (UnfoldIfGoodArgs n_vals _ size _)) = is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold  twanvl committed Jan 25, 2008 489 certainlyWillInline _  simonpj committed Oct 24, 2001 490  = False  simonmar committed Aug 12, 2005 491 492 493 494  smallEnoughToInline :: Unfolding -> Bool smallEnoughToInline (CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ _ size _)) = size <= opt_UF_UseThreshold  twanvl committed Jan 25, 2008 495 smallEnoughToInline _  simonmar committed Aug 12, 2005 496  = False  simonpj committed Jun 08, 1999 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 \end{code} %************************************************************************ %* * \subsection{callSiteInline} %* * %************************************************************************ This is the key function. It decides whether to inline a variable at a call site callSiteInline is used at call sites, so it is a bit more generous. It's a very important function that embodies lots of heuristics. A non-WHNF can be inlined if it doesn't occur inside a lambda, and occurs exactly once or occurs once in each branch of a case and is small If the thing is in WHNF, there's no danger of duplicating work, so we can inline if it occurs once, or is small  simonpj committed Mar 23, 2000 516 NOTE: we don't want to inline top-level functions that always diverge.  Simon Marlow committed Feb 01, 2008 517 It just makes the code bigger. Tt turns out that the convenient way to prevent  simonpj committed Mar 23, 2000 518 519 520 them inlining is to give them a NOINLINE pragma, which we do in StrictAnal.addStrictnessInfoToTopId  simonpj committed Jun 08, 1999 521 \begin{code}  sewardj committed Oct 12, 2000 522 callSiteInline :: DynFlags  simonpj committed Sep 26, 2001 523  -> Bool -- True <=> the Id can be inlined  simonpj committed Jun 08, 1999 524  -> Id -- The Id  simonpj@microsoft.com committed Dec 04, 2007 525  -> Bool -- True if there are are no arguments at all (incl type args)  simonpj committed Jul 06, 1999 526  -> [Bool] -- One for each value arg; True if it is interesting  simonpj@microsoft.com committed Feb 07, 2008 527  -> CallCtxt -- True <=> continuation is interesting  simonpj committed Jun 08, 1999 528 529 530  -> Maybe CoreExpr -- Unfolding, if any  simonpj@microsoft.com committed Feb 07, 2008 531 data CallCtxt = BoringCtxt  simonpj@microsoft.com committed Dec 04, 2007 532   simonpj@microsoft.com committed Feb 07, 2008 533 534 535 536 537 538 539 540 541 542  | ArgCtxt Bool -- We're somewhere in the RHS of function with rules -- => be keener to inline Int -- We *are* the argument of a function with this arg discount -- => be keener to inline -- INVARIANT: ArgCtxt False 0 ==> BoringCtxt | CaseCtxt -- We're the scrutinee of a case -- that decomposes its scrutinee instance Outputable CallCtxt where  Ian Lynagh committed Apr 12, 2008 543 544 545  ppr BoringCtxt = ptext (sLit "BoringCtxt") ppr (ArgCtxt _ _) = ptext (sLit "ArgCtxt") ppr CaseCtxt = ptext (sLit "CaseCtxt")  simonpj@microsoft.com committed Dec 04, 2007 546 547  callSiteInline dflags active_inline id lone_variable arg_infos cont_info  simonpj committed Mar 23, 2000 548  = case idUnfolding id of {  simonpj committed Jun 08, 1999 549  NoUnfolding -> Nothing ;  twanvl committed Jan 25, 2008 550  OtherCon _ -> Nothing ;  simonpj committed Sep 14, 2001 551 552 553 554 555 556  CompulsoryUnfolding unf_template -> Just unf_template ; -- CompulsoryUnfolding => there is no top-level binding -- for these things, so we must inline it. -- Only a couple of primop-like things have -- compulsory unfoldings (see MkId.lhs).  simonpj committed Sep 26, 2001 557  -- We don't allow them to be inactive  simonpj committed Sep 14, 2001 558   simonpj committed Sep 14, 2000 559  CoreUnfolding unf_template is_top is_value is_cheap guidance ->  simonpj committed Jun 08, 1999 560 561 562 563 564  let result | yes_or_no = Just unf_template | otherwise = Nothing  simonpj committed Jul 06, 1999 565  n_val_args = length arg_infos  simonpj committed Jun 08, 1999 566   simonpj@microsoft.com committed Dec 04, 2007 567  yes_or_no = active_inline && is_cheap && consider_safe  simonpj@microsoft.com committed Oct 04, 2006 568  -- We consider even the once-in-one-branch  simonmar committed Aug 04, 2005 569 570 571 572 573 574  -- occurrences, because they won't all have been -- caught by preInlineUnconditionally. In particular, -- if the occurrence is once inside a lambda, and the -- rhs is cheap but not a manifest lambda, then -- pre-inline will not have inlined it for fear of -- invalidating the occurrence info in the rhs.  simonmar committed Aug 03, 2005 575   simonpj@microsoft.com committed Dec 04, 2007 576  consider_safe  simonmar committed Aug 03, 2005 577 578 579  -- consider_safe decides whether it's a good idea to -- inline something, given that there's no -- work-duplication issue (the caller checks that).  simonpj committed Jun 08, 1999 580  = case guidance of  simonmar committed Mar 31, 2005 581  UnfoldNever -> False  simonpj committed Jun 08, 1999 582  UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount  simonpj committed Nov 01, 1999 583  | enough_args && size <= (n_vals_wanted + 1)  simonpj committed Sep 26, 2001 584  -- Inline unconditionally if there no size increase  simonpj committed Jun 08, 1999 585  -- Size of call is n_vals_wanted (+1 for the function)  simonpj committed Nov 01, 1999 586 587 588  -> True | otherwise  rl@cse.unsw.edu.au committed Oct 02, 2008 589  -> some_benefit && small_enough && inline_enough_args  Simon Marlow committed Feb 01, 2008 590   simonpj committed Nov 01, 1999 591  where  simonpj@microsoft.com committed Dec 04, 2007 592  enough_args = n_val_args >= n_vals_wanted  rl@cse.unsw.edu.au committed Oct 02, 2008 593 594 595  inline_enough_args = not (dopt Opt_InlineIfEnoughArgs dflags) || enough_args  simonpj@microsoft.com committed Dec 04, 2007 596 597 598 599 600 601 602 603 604 605  some_benefit = or arg_infos || really_interesting_cont -- There must be something interesting -- about some argument, or the result -- context, to make it worth inlining really_interesting_cont | n_val_args < n_vals_wanted = False -- Too few args | n_val_args == n_vals_wanted = interesting_saturated_call | otherwise = True -- Extra args  simonpj committed Mar 23, 2000 606 607 608  -- really_interesting_cont tells if the result of the -- call is in an interesting context.  simonpj@microsoft.com committed Dec 04, 2007 609 610  interesting_saturated_call = case cont_info of  simonpj@microsoft.com committed Feb 07, 2008 611 612  BoringCtxt -> not is_top && n_vals_wanted > 0 -- Note [Nested functions] CaseCtxt -> not lone_variable || not is_value -- Note [Lone variables]  613 614  ArgCtxt {} -> n_vals_wanted > 0 -- See Note [Inlining in ArgCtxt]  simonpj@microsoft.com committed Dec 04, 2007 615   simonpj committed Nov 01, 1999 616  small_enough = (size - discount) <= opt_UF_UseThreshold  simonpj@microsoft.com committed Dec 04, 2007 617 618 619  discount = computeDiscount n_vals_wanted arg_discounts res_discount' arg_infos res_discount' = case cont_info of  simonpj@microsoft.com committed Feb 07, 2008 620 621 622  BoringCtxt -> 0 CaseCtxt -> res_discount ArgCtxt _ _ -> 4 min res_discount  simonpj@microsoft.com committed Dec 04, 2007 623 624 625 626 627 628  -- res_discount can be very large when a function returns -- construtors; but we only want to invoke that large discount -- when there's a case continuation. -- Otherwise we, rather arbitrarily, threshold it. Yuk. -- But we want to aovid inlining large functions that return -- constructors into contexts that are simply "interesting"  simonpj committed Nov 01, 1999 629   simonpj committed Jun 08, 1999 630  in  simonmar committed Oct 17, 2000 631  if dopt Opt_D_dump_inlinings dflags then  simonpj committed Jun 08, 1999 632  pprTrace "Considering inlining"  simonpj committed Sep 26, 2001 633  (ppr id <+> vcat [text "active:" <+> ppr active_inline,  simonpj committed Jun 08, 1999 634  text "arg infos" <+> ppr arg_infos,  Simon Marlow committed Feb 01, 2008 635  text "interesting continuation" <+> ppr cont_info,  simonpj committed Mar 24, 2000 636  text "is value:" <+> ppr is_value,  simonpj committed Mar 23, 2000 637  text "is cheap:" <+> ppr is_cheap,  simonpj committed Jun 08, 1999 638  text "guidance" <+> ppr guidance,  simonpj committed May 16, 2005 639  text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])  simonpj committed Jun 08, 1999 640 641 642 643  result else result }  simonpj@microsoft.com committed Dec 04, 2007 644 645 646 647 648 649 650 651 652 653 654 655 656 657 \end{code} Note [Nested functions] ~~~~~~~~~~~~~~~~~~~~~~~ If a function has a nested defn we also record some-benefit, on the grounds that we are often able to eliminate the binding, and hence the allocation, for the function altogether; this is good for join points. But this only makes sense for *functions*; inlining a constructor doesn't help allocation unless the result is scrutinised. UNLESS the constructor occurs just once, albeit possibly in multiple case branches. Then inlining it doesn't increase allocation, but it does increase the chance that the constructor won't be allocated at all in the branches that don't use it.  658 659 660 661 662 663 664 665 666 667 668 669 670 Note [Inlining in ArgCtxt] ~~~~~~~~~~~~~~~~~~~~~~~~~~ The condition (n_vals_wanted > 0) here is very important, because otherwise we end up inlining top-level stuff into useless places; eg x = I# 3# f = \y. g x This can make a very big difference: it adds 16% to nofib 'integer' allocs, and 20% to 'power'. At one stage I replaced this condition by 'True' (leading to the above slow-down). The motivation was test eyeball/inline1.hs; but that seems to work ok now.  simonpj@microsoft.com committed Dec 04, 2007 671 Note [Lone variables]  Simon Marlow committed Feb 01, 2008 672 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj@microsoft.com committed Dec 04, 2007 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 The "lone-variable" case is important. I spent ages messing about with unsatisfactory varaints, but this is nice. The idea is that if a variable appears all alone as an arg of lazy fn, or rhs Stop as scrutinee of a case Select as arg of a strict fn ArgOf AND it is bound to a value then we should not inline it (unless there is some other reason, e.g. is is the sole occurrence). That is what is happening at the use of 'lone_variable' in 'interesting_saturated_call'. Why? At least in the case-scrutinee situation, turning let x = (a,b) in case x of y -> ... into let x = (a,b) in case (a,b) of y -> ... and thence to let x = (a,b) in let y = (a,b) in ... is bad if the binding for x will remain. Another example: I discovered that strings were getting inlined straight back into applications of 'error' because the latter is strict. s = "foo" f = \x -> ...(error s)... Fundamentally such contexts should not encourage inlining because the context can see'' the unfolding of the variable (e.g. case or a RULE) so there's no gain. If the thing is bound to a value. However, watch out: * Consider this: foo = _inline_ (\n. [n]) bar = _inline_ (foo 20) baz = \n. case bar of { (m:_) -> m + n } Here we really want to inline 'bar' so that we can inline 'foo' and the whole thing unravels as it should obviously do. This is important: in the NDP project, 'bar' generates a closure data structure rather than a list. * Even a type application or coercion isn't a lone variable. Consider case \$fMonadST @ RealWorld of { :DMonad a b c -> c } We had better inline that sucker! The case won't see through it. For now, I'm treating treating a variable applied to types in a *lazy* context "lone". The motivating example was f = /\a. \x. BIG g = /\a. \y. h (f a) There's no advantage in inlining f here, and perhaps a significant disadvantage. Hence some_val_args in the Stop case  simonpj committed Jun 08, 1999 725   simonpj@microsoft.com committed Dec 04, 2007 726 727 728 \begin{code} computeDiscount :: Int -> [Int] -> Int -> [Bool] -> Int computeDiscount n_vals_wanted arg_discounts result_discount arg_infos  simonpj committed Jun 08, 1999 729 730  -- We multiple the raw discounts (args_discount and result_discount) -- ty opt_UnfoldingKeenessFactor because the former have to do with  simonmar committed Mar 31, 2005 731 732  -- *size* whereas the discounts imply that there's some extra -- *efficiency* to be gained (e.g. beta reductions, case reductions)  simonpj committed Jun 08, 1999 733 734 735 736 737  -- by inlining. -- we also discount 1 for each argument passed, because these will -- reduce with the lambdas in the function (we count 1 for a lambda -- in size_up).  simonpj committed Sep 17, 1999 738 739 740  = 1 + -- Discount of 1 because the result replaces the call -- so we count 1 for the function itself length (take n_vals_wanted arg_infos) +  simonpj committed Jun 08, 1999 741 742 743  -- Discount of 1 for each arg supplied, because the -- result replaces the call round (opt_UF_KeenessFactor *  simonmar committed Feb 11, 2002 744  fromIntegral (arg_discount + result_discount))  simonpj committed Jun 08, 1999 745 746 747 748 749 750  where arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos) mk_arg_discount discount is_evald | is_evald = discount | otherwise = 0 \end{code}  simonpj@microsoft.com committed Sep 10, 2008 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804  %************************************************************************ %* * The Very Simple Optimiser %* * %************************************************************************ \begin{code} simpleOptExpr :: Subst -> CoreExpr -> CoreExpr -- Return an occur-analysed and slightly optimised expression -- The optimisation is very straightforward: just -- inline non-recursive bindings that are used only once, -- or wheere the RHS is trivial simpleOptExpr subst expr = go subst (occurAnalyseExpr expr) where go subst (Var v) = lookupIdSubst subst v go subst (App e1 e2) = App (go subst e1) (go subst e2) go subst (Type ty) = Type (substTy subst ty) go _ (Lit lit) = Lit lit go subst (Note note e) = Note note (go subst e) go subst (Cast e co) = Cast (go subst e) (substTy subst co) go subst (Let bind body) = go_bind subst bind body go subst (Lam bndr body) = Lam bndr' (go subst' body) where (subst', bndr') = substBndr subst bndr go subst (Case e b ty as) = Case (go subst e) b' (substTy subst ty) (map (go_alt subst') as) where (subst', b') = substBndr subst b ---------------------- go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs) where (subst', bndrs') = substBndrs subst bndrs ---------------------- go_bind subst (Rec prs) body = Let (Rec (bndrs' zip rhss')) (go subst' body) where (bndrs, rhss) = unzip prs (subst', bndrs') = substRecBndrs subst bndrs rhss' = map (go subst') rhss go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body ---------------------- go_nonrec subst b (Type ty') body | isTyVar b = go (extendTvSubst subst b ty') body  simonpj@microsoft.com committed Sep 14, 2008 805  -- let a::* = TYPE ty in  simonpj@microsoft.com committed Sep 10, 2008 806  go_nonrec subst b r' body  simonpj@microsoft.com committed Sep 14, 2008 807  | isId b -- let x = e in  simonpj@microsoft.com committed Sep 10, 2008 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822  , exprIsTrivial r' || safe_to_inline (idOccInfo b) = go (extendIdSubst subst b r') body go_nonrec subst b r' body = Let (NonRec b' r') (go subst' body) where (subst', b') = substBndr subst b ---------------------- -- Unconditionally safe to inline safe_to_inline :: OccInfo -> Bool safe_to_inline IAmDead = True safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br safe_to_inline (IAmALoopBreaker {}) = False safe_to_inline NoOccInfo = False \end{code}