CoreUnfold.lhs 17.5 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1994-1996
3
%
4 5 6 7 8
\section[CoreUnfold]{Core-syntax unfoldings}

Unfoldings (which can travel across module boundaries) are in Core
syntax (namely @CoreExpr@s).

9
The type @Unfolding@ sits ``above'' simply-Core-expressions
10 11
unfoldings, capturing ``higher-level'' things we know about a binding,
usually things that the simplifier found out (e.g., ``it's a
12
literal'').  In the corner of a @CoreUnfolding@ unfolding, you will
13
find, unsurprisingly, a Core expression.
14 15 16

\begin{code}
module CoreUnfold (
17
	Unfolding(..), UnfoldingGuidance(..), -- types
18

19 20
	FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup, 
	exprIsTrivial,
21

22
	noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
23

24
	smallEnoughToInline, couldBeSmallEnoughToInline, 
25
	certainlySmallEnoughToInline, inlineUnconditionally, okToInline,
26

27
	calcUnfoldingGuidance
28 29
    ) where

30 31 32
#include "HsVersions.h"

import {-# SOURCE #-} MagicUFs	( MagicUnfoldingFun, mkMagicUnfoldingFun )
33

34 35
import CmdLineOpts	( opt_UnfoldingCreationThreshold,
			  opt_UnfoldingUseThreshold,
sof's avatar
sof committed
36 37
			  opt_UnfoldingConDiscount,
			  opt_UnfoldingKeenessFactor
38 39
			)
import Constants	( uNFOLDING_CHEAP_OP_COST,
40 41 42
			  uNFOLDING_DEAR_OP_COST,
			  uNFOLDING_NOREP_LIT_COST
			)
43
import BinderInfo	( BinderInfo, isOneSameSCCFunOcc, isDeadOcc,
44
			  isInlinableOcc, isOneSafeFunOcc
sof's avatar
sof committed
45
			)
46
import CoreSyn
47
import Literal		( Literal )
48 49
import CoreUtils	( unTagBinders )
import OccurAnal	( occurAnalyseGlobalExpr )
50
import CoreUtils	( coreExprType )
51
import Id		( Id, idType, getIdArity,  isBottomingId, isDataCon,
sof's avatar
sof committed
52
			  idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
53
			  IdSet )
54
import PrimOp		( fragilePrimOp, primOpCanTriggerGC )
55
import IdInfo		( ArityInfo(..), InlinePragInfo(..) )
56
import Name		( isExported )
57
import Literal		( isNoRepLit )
58
import TyCon		( tyConFamilySize )
59
import Type		( splitAlgTyConApp_maybe )
sof's avatar
sof committed
60
import Unique           ( Unique )
61
import Util		( isIn, panic, assertPanic )
sof's avatar
sof committed
62
import Outputable
63 64 65 66
\end{code}

%************************************************************************
%*									*
67
\subsection{@Unfolding@ and @UnfoldingGuidance@ types}
68 69 70 71
%*									*
%************************************************************************

\begin{code}
72 73
data Unfolding
  = NoUnfolding
74

75 76
  | OtherLit [Literal]		-- It ain't one of these
  | OtherCon [Id]		-- It ain't one of these
77

78
  | CoreUnfolding			-- An unfolding with redundant cached information
79 80 81
		FormSummary		-- Tells whether the template is a WHNF or bottom
		UnfoldingGuidance	-- Tells about the *size* of the template.
		SimplifiableCoreExpr	-- Template
82

83 84 85 86
  | MagicUnfolding
	Unique				-- Unique of the Id whose magic unfolding this is
	MagicUnfoldingFun
\end{code}
87

88
\begin{code}
89
noUnfolding = NoUnfolding
90

91
mkUnfolding expr
92 93
  = let
     -- strictness mangling (depends on there being no CSE)
94
     ufg = calcUnfoldingGuidance opt_UnfoldingCreationThreshold expr
95
     occ = occurAnalyseGlobalExpr expr
96
     cuf = CoreUnfolding (mkFormSummary expr) ufg occ
97 98 99 100
					  
     cont = case occ of { Var _ -> cuf; _ -> cuf }
    in
    case ufg of { UnfoldAlways -> cont; _ -> cont }
101

102 103
mkMagicUnfolding :: Unique -> Unfolding
mkMagicUnfolding tag  = MagicUnfolding tag (mkMagicUnfoldingFun tag)
104

105
getUnfoldingTemplate :: Unfolding -> CoreExpr
106
getUnfoldingTemplate (CoreUnfolding _ _ expr)
107 108 109
  = unTagBinders expr
getUnfoldingTemplate other = panic "getUnfoldingTemplate"

110 111

data UnfoldingGuidance
112
  = UnfoldNever
113 114 115 116 117
  | UnfoldAlways		-- There is no "original" definition,
				-- so you'd better unfold.  Or: something
				-- so cheap to unfold (e.g., 1#) that
				-- you should do it absolutely always.

118 119
  | UnfoldIfGoodArgs	Int	-- if "m" type args 
			Int	-- and "n" value args
sof's avatar
sof committed
120

121
			[Int]	-- Discount if the argument is evaluated.
122
				-- (i.e., a simplification will definitely
123
				-- be possible).  One elt of the list per *value* arg.
sof's avatar
sof committed
124

125 126
			Int	-- The "size" of the unfolding; to be elaborated
				-- later. ToDo
sof's avatar
sof committed
127 128 129 130

			Int	-- Scrutinee discount: the discount to substract if the thing is in
				-- a context (case (thing args) of ...),
				-- (where there are the right number of arguments.)
131 132 133 134
\end{code}

\begin{code}
instance Outputable UnfoldingGuidance where
135 136
    ppr UnfoldAlways    	= ptext SLIT("_ALWAYS_")
    ppr (UnfoldIfGoodArgs t v cs size discount)
sof's avatar
sof committed
137
      = hsep [ptext SLIT("_IF_ARGS_"), int t, int v,
138
	       if null cs	-- always print *something*
sof's avatar
sof committed
139 140 141 142
	       	then char 'X'
		else hcat (map (text . show) cs),
	       int size,
	       int discount ]
143 144
\end{code}

145 146 147

%************************************************************************
%*									*
148
\subsection{Figuring out things about expressions}
149 150 151 152
%*									*
%************************************************************************

\begin{code}
153 154 155 156 157 158
data FormSummary
  = VarForm		-- Expression is a variable (or scc var, etc)
  | ValueForm		-- Expression is a value: i.e. a value-lambda,constructor, or literal
  | BottomForm		-- Expression is guaranteed to be bottom. We're more gung
			-- ho about inlining such things, because it can't waste work
  | OtherForm		-- Anything else
159

160
instance Outputable FormSummary where
161 162 163 164
   ppr VarForm    = ptext SLIT("Var")
   ppr ValueForm  = ptext SLIT("Value")
   ppr BottomForm = ptext SLIT("Bot")
   ppr OtherForm  = ptext SLIT("Other")
165

166
mkFormSummary ::GenCoreExpr bndr Id flexi -> FormSummary
167 168 169 170 171 172

mkFormSummary expr
  = go (0::Int) expr		-- The "n" is the number of (value) arguments so far
  where
    go n (Lit _)	= ASSERT(n==0) ValueForm
    go n (Con _ _)      = ASSERT(n==0) ValueForm
173
    go n (Prim _ _)	= OtherForm
174
    go n (Note _ e)     = go n e
sof's avatar
sof committed
175 176 177

    go n (Let (NonRec b r) e) | exprIsTrivial r = go n e	-- let f = f' alpha in (f,g) 
								-- should be treated as a value
178 179 180 181 182 183 184 185 186 187 188
    go n (Let _ e)      = OtherForm
    go n (Case _ _)     = OtherForm

    go 0 (Lam (ValBinder x) e) = ValueForm	-- NB: \x.bottom /= bottom!
    go n (Lam (ValBinder x) e) = go (n-1) e	-- Applied lambda
    go n (Lam other_binder e)  = go n e

    go n (App fun arg) | isValArg arg = go (n+1) fun
    go n (App fun other_arg)          = go n fun

    go n (Var f) | isBottomingId f = BottomForm
189
		 | isDataCon f	   = ValueForm		-- Can happen inside imported unfoldings
190
    go 0 (Var f)		   = VarForm
191 192 193
    go n (Var f)		   = case getIdArity f of
					  ArityExactly a | n < a -> ValueForm
					  ArityAtLeast a | n < a -> ValueForm
194 195
					  other			 -> OtherForm

sof's avatar
sof committed
196 197 198 199 200
whnfOrBottom :: FormSummary -> Bool
whnfOrBottom VarForm    = True
whnfOrBottom ValueForm  = True
whnfOrBottom BottomForm = True
whnfOrBottom OtherForm  = False
201
\end{code}
202

sof's avatar
sof committed
203 204 205 206 207 208 209
@exprIsTrivial@ is true of expressions we are unconditionally happy to duplicate;
simple variables and constants, and type applications.

\begin{code}
exprIsTrivial (Var v) 		= True
exprIsTrivial (Lit lit)         = not (isNoRepLit lit)
exprIsTrivial (App e (TyArg _)) = exprIsTrivial e
210
exprIsTrivial (Note _ e)        = exprIsTrivial e
sof's avatar
sof committed
211 212
exprIsTrivial other		= False
\end{code}
213

214
\begin{code}
sof's avatar
sof committed
215 216 217
exprSmallEnoughToDup (Con _ _)      = True	-- Could check # of args
exprSmallEnoughToDup (Prim op _)    = not (fragilePrimOp op) -- Could check # of args
exprSmallEnoughToDup (Lit lit)      = not (isNoRepLit lit)
218
exprSmallEnoughToDup (Note _ e)     = exprSmallEnoughToDup e
219
exprSmallEnoughToDup expr
220
  = case (collectArgs expr) of { (fun, _, vargs) ->
221
    case fun of
sof's avatar
sof committed
222
      Var v | length vargs <= 4 -> True
223 224 225
      _				-> False
    }

226
\end{code}
sof's avatar
sof committed
227

228

229 230 231 232 233 234 235 236
%************************************************************************
%*									*
\subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
%*									*
%************************************************************************

\begin{code}
calcUnfoldingGuidance
237
	:: Int		    	-- bomb out if size gets bigger than this
238
	-> CoreExpr    		-- expression to look at
239 240
	-> UnfoldingGuidance

241
calcUnfoldingGuidance bOMB_OUT_SIZE expr
242
  = case collectBinders expr of { (ty_binders, val_binders, body) ->
243
    case (sizeExpr bOMB_OUT_SIZE val_binders body) of
244

sof's avatar
sof committed
245
      TooBig -> UnfoldNever
246

sof's avatar
sof committed
247
      SizeIs size cased_args scrut_discount
248
	-> UnfoldIfGoodArgs
249 250
			(length ty_binders)
			(length val_binders)
251
			(map discount_for val_binders)
sof's avatar
sof committed
252 253
			(I# size)
			(I# scrut_discount)
254 255
	where        
	    discount_for b
256 257 258 259
	         | is_data && b `is_elem` cased_args = tyConFamilySize tycon
		 | otherwise = 0
		 where
		   (is_data, tycon)
260
		     = case (splitAlgTyConApp_maybe (idType b)) of
261 262
			  Nothing       -> (False, panic "discount")
			  Just (tc,_,_) -> (True,  tc)
263

264
	    is_elem = isIn "calcUnfoldingGuidance" }
265 266 267
\end{code}

\begin{code}
268
sizeExpr :: Int 	    -- Bomb out if it gets bigger than this
269 270
	 -> [Id]	    -- Arguments; we're interested in which of these
			    -- get case'd
271
	 -> CoreExpr
sof's avatar
sof committed
272
	 -> ExprSize
273

sof's avatar
sof committed
274
sizeExpr (I# bOMB_OUT_SIZE) args expr
275 276
  = size_up expr
  where
sof's avatar
sof committed
277 278 279
    size_up (Var v)        	       = sizeZero
    size_up (Lit lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
		      | otherwise      = sizeZero
280

281
    size_up (Note _ body)  = size_up body		-- Notes cost nothing
282

sof's avatar
sof committed
283 284 285 286 287
    size_up (App fun arg)  = size_up fun `addSize` size_up_arg arg
				-- NB Zero cost for for type applications;
				-- others cost 1 or more

    size_up (Con con args) = conSizeN (numValArgs args)
288 289 290
			     -- We don't count 1 for the constructor because we're
			     -- quite keen to get constructors into the open
			     
291
    size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
292 293 294 295 296 297 298
      where
	op_cost = if primOpCanTriggerGC op
		  then uNFOLDING_DEAR_OP_COST
			-- these *tend* to be more expensive;
			-- number chosen to avoid unfolding (HACK)
		  else uNFOLDING_CHEAP_OP_COST

299 300
    size_up expr@(Lam _ _)
      = let
301
	    (tyvars, args, body) = collectBinders expr
302 303
	in
	size_up body `addSizeN` length args
304

305
    size_up (Let (NonRec binder rhs) body)
sof's avatar
sof committed
306
      = nukeScrutDiscount (size_up rhs)
307 308
		`addSize`
	size_up body
309 310
		`addSizeN`
	1	-- For the allocation
311

312
    size_up (Let (Rec pairs) body)
sof's avatar
sof committed
313
      = nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs])
314 315
		`addSize`
	size_up body
316 317
		`addSizeN`
	length pairs	-- For the allocation
318 319

    size_up (Case scrut alts)
sof's avatar
sof committed
320 321 322
      = nukeScrutDiscount (size_up scrut)
		`addSize`
	arg_discount scrut
323
		`addSize`
324
	size_up_alts (coreExprType scrut) alts
325 326 327
	    -- We charge for the "case" itself in "size_up_alts"

    ------------
sof's avatar
sof committed
328 329 330
	-- In an application we charge	0 for type application
	-- 				1 for most anything else
	--				N for norep_lits
331
    size_up_arg (LitArg lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
sof's avatar
sof committed
332 333
    size_up_arg (TyArg _)		      = sizeZero
    size_up_arg other			      = sizeOne
334 335 336

    ------------
    size_up_alts scrut_ty (AlgAlts alts deflt)
sof's avatar
sof committed
337
      = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts)
338 339 340 341 342
	`addSizeN`
	alt_cost
      where
	size_alg_alt (con,args,rhs) = size_up rhs
	    -- Don't charge for args, so that wrappers look cheap
343

344 345 346 347
	-- NB: we charge N for an alg. "case", where N is
	-- the number of constructors in the thing being eval'd.
	-- (You'll eventually get a "discount" of N if you
	-- think the "case" is likely to go away.)
348 349 350
	-- It's important to charge for alternatives.  If you don't then you
	-- get size 1 for things like:
	--		case x of { A -> 1#; B -> 2#; ... lots }
351

352 353
	alt_cost :: Int
	alt_cost
354
	  = case (splitAlgTyConApp_maybe scrut_ty) of
355 356
	      Nothing       -> 1
	      Just (tc,_,_) -> tyConFamilySize tc
357

358 359
    size_up_alts _ (PrimAlts alts deflt)
      = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
360 361 362 363 364
	    -- *no charge* for a primitive "case"!
      where
	size_prim_alt (lit,rhs) = size_up rhs

    ------------
sof's avatar
sof committed
365
    size_up_deflt NoDefault		   = sizeZero
366
    size_up_deflt (BindDefault binder rhs) = size_up rhs
367 368

    ------------
sof's avatar
sof committed
369 370 371
	-- We want to record if we're case'ing an argument
    arg_discount (Var v) | v `is_elem` args = scrutArg v
    arg_discount other			    = sizeZero
372

373
    is_elem :: Id -> [Id] -> Bool
374 375 376
    is_elem = isIn "size_up_scrut"

    ------------
sof's avatar
sof committed
377 378
	-- These addSize things have to be here because
	-- I don't want to give them bOMB_OUT_SIZE as an argument
379

sof's avatar
sof committed
380 381 382 383 384 385 386 387 388 389 390 391
    addSizeN TooBig          _ = TooBig
    addSizeN (SizeIs n xs d) (I# m)
      | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d
      | otherwise 		    = TooBig
      where
	n_tot = n +# m
    
    addSize TooBig _ = TooBig
    addSize _ TooBig = TooBig
    addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
      | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot
      | otherwise 			  = TooBig
392
      where
sof's avatar
sof committed
393 394 395
	n_tot = n1 +# n2
	d_tot = d1 +# d2
	xys   = xs ++ ys
396

sof's avatar
sof committed
397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412

\end{code}

Code for manipulating sizes

\begin{code}

data ExprSize = TooBig
	      | SizeIs Int#	-- Size found
		       [Id]	-- Arguments cased herein
		       Int#	-- Size to subtract if result is scrutinised 
				-- by a case expression

sizeZero     	= SizeIs 0# [] 0#
sizeOne      	= SizeIs 1# [] 0#
sizeN (I# n) 	= SizeIs n  [] 0#
sof's avatar
sof committed
413
conSizeN (I# n) = SizeIs n  [] n
sof's avatar
sof committed
414 415 416 417
scrutArg v	= SizeIs 0# [v] 0#

nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
nukeScrutDiscount TooBig	  = TooBig
418 419
\end{code}

420 421 422 423 424 425 426 427 428 429 430 431
%************************************************************************
%*									*
\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
sof's avatar
sof committed
432 433
position.'' (4)~The ``discount'' to subtract if the expression
is being scrutinised. 
434 435 436 437 438 439 440 441

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].

sof's avatar
sof committed
442 443 444 445 446 447 448 449
If we're in the context of a scrutinee ( \tr{(case <expr > 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).

450
\begin{code}
451
smallEnoughToInline :: Id			-- The function (trace msg only)
452
		    -> [Bool]			-- Evaluated-ness of value arguments
sof's avatar
sof committed
453
		    -> Bool			-- Result is scrutinised
454 455
		    -> UnfoldingGuidance
		    -> Bool			-- True => unfold it
456

457 458 459
smallEnoughToInline _ _ _ UnfoldAlways = True
smallEnoughToInline _ _ _ UnfoldNever  = False
smallEnoughToInline id arg_is_evald_s result_is_scruted
sof's avatar
sof committed
460
	      (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
461 462 463
  = if enough_args n_vals_wanted arg_is_evald_s &&
       size - discount <= opt_UnfoldingUseThreshold
    then
464 465
       -- pprTrace "small enough" (ppr id <+> int size <+> int discount) 
       True
466 467
    else
       False
468
  where
sof's avatar
sof committed
469 470 471 472

    enough_args n [] | n > 0 = False	-- A function with no value args => don't unfold
    enough_args _ _	     = True	-- Otherwise it's ok to try

sof's avatar
sof committed
473 474 475 476 477 478 479 480 481
	-- We multiple the raw discounts (args_discount and result_discount)
	-- ty opt_UnfoldingKeenessFactor because the former have to do with
	-- *size* whereas the discounts imply that there's some extra *efficiency*
	-- to be gained (e.g. beta reductions, case reductions) by inlining.
    discount :: Int
    discount = round (
		      opt_UnfoldingKeenessFactor * 
		      fromInt (args_discount + result_discount)
		     )
482

sof's avatar
sof committed
483 484 485
    args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s)
    result_discount | result_is_scruted = scrut_discount
		    | otherwise		= 0
486 487

    arg_discount no_of_constrs is_evald
488 489
      | is_evald  = no_of_constrs * opt_UnfoldingConDiscount
      | otherwise = 0
490 491 492 493 494 495 496
\end{code}

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}
497 498
couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance
499

500 501
certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance
502 503
\end{code}

504 505
Predicates
~~~~~~~~~~
506

sof's avatar
sof committed
507 508 509 510 511 512
@inlineUnconditionally@ decides whether a let-bound thing can
*definitely* be inlined at each of its call sites.  If so, then
we can drop the binding right away.  But remember, you have to be 
certain that every use can be inlined.  So, notably, any ArgOccs 
rule this out.  Since ManyOcc doesn't record FunOcc/ArgOcc 

513
\begin{code}
514
inlineUnconditionally :: (Id,BinderInfo) -> Bool
515

516
inlineUnconditionally (id, occ_info)
517 518 519
  |  idMustNotBeINLINEd id 
  || isExported id
  =  False
520

521 522
  |  isOneSameSCCFunOcc occ_info
  && idWantsToBeINLINEd id = True
sof's avatar
sof committed
523

524
  |  isOneSafeFunOcc occ_info
sof's avatar
sof committed
525 526 527 528 529
  =  True

  |  otherwise
  = False
\end{code}
530 531 532 533 534 535 536 537 538 539 540 541 542 543

okToInline is used at call sites, so it is a bit more generous

\begin{code}
okToInline :: Id		-- The Id
	   -> Bool		-- The thing is WHNF or bottom; 
	   -> Bool		-- It's small enough to duplicate the code
	   -> BinderInfo
	   -> Bool		-- True <=> inline it

okToInline id _ _ _		-- Check the Id first
  | idWantsToBeINLINEd id = True
  | idMustNotBeINLINEd id = False

544 545 546 547 548 549 550
okToInline id whnf small binder_info 
#ifdef DEBUG
  | isDeadOcc binder_info
  = pprTrace "okToInline: dead" (ppr id) False
  | otherwise
#endif
  = isInlinableOcc whnf small binder_info
551
\end{code}