Simplify.lhs 58.3 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1993-1998
3 4 5 6
%
\section[Simplify]{The main module of the simplifier}

\begin{code}
7
module Simplify ( simplTopBinds, simplExpr ) where
8

9
#include "HsVersions.h"
10

11
import CmdLineOpts	( switchIsOn, opt_SimplDoEtaReduction,
12
			  opt_SimplNoPreInlining, 
13
			  dopt, DynFlag(Opt_D_dump_inlinings),
14
			  SimplifierSwitch(..)
sof's avatar
sof committed
15
			)
16
import SimplMonad
17
import SimplUtils	( mkCase, tryRhsTyLam, tryEtaExpansion,
18
			  simplBinder, simplBinders, simplRecIds, simplLetId,
19
			  SimplCont(..), DupFlag(..), mkStop, mkRhsStop,
20 21
			  contResultType, discardInline, countArgs, contIsDupable,
			  getContArgs, interestingCallContext, interestingArg, isStrictType
22
			)
23
import Var		( mkSysTyVar, tyVarKind, mustHaveLocalBinding )
24
import VarEnv
25
import Literal		( Literal )
26
import Id		( Id, idType, idInfo, isDataConId, hasNoBinding,
27
			  idUnfolding, setIdUnfolding, isExportedId, isDeadBinder,
28
			  idDemandInfo, setIdInfo,
29
			  idOccInfo, setIdOccInfo, 
30
			  zapLamIdInfo, setOneShotLambda, 
31
			)
32
import IdInfo		( OccInfo(..), isDeadOcc, isLoopBreaker,
33 34
			  setArityInfo, 
			  setUnfoldingInfo, atLeastArity,
35
			  occInfo
36
			)
37
import Demand		( isStrict )
38
import DataCon		( dataConNumInstArgs, dataConRepStrictness,
39 40
			  dataConSig, dataConArgTys
			)
41
import CoreSyn
42
import PprCore		( pprParendExpr, pprCoreExpr )
43 44
import CoreUnfold	( mkOtherCon, mkUnfolding, otherCons,
			  callSiteInline
45
			)
46
import CoreUtils	( cheapEqExpr, exprIsDupable, exprIsTrivial, 
47
			  exprIsConApp_maybe, mkPiType, findAlt, findDefault,
48 49
			  exprType, coreAltsType, exprIsValue, 
			  exprOkForSpeculation, exprArity, exprIsCheap,
50
			  mkCoerce, mkSCC, mkInlineMe, mkAltExpr
51
			)
52
import Rules		( lookupRule )
53 54
import CostCentre	( currentCCS )
import Type		( mkTyVarTys, isUnLiftedType, seqType,
55
			  mkFunTy, splitTyConApp_maybe, tyConAppArgs,
56
			  funResultTy, splitFunTy_maybe, splitFunTy
57
			)
58
import Subst		( mkSubst, substTy, substEnv, substExpr,
59
			  isInScope, lookupIdSubst, simplIdInfo
60
			)
61
import TyCon		( isDataTyCon, tyConDataConsIfAvailable	)
62
import TysPrim		( realWorldStatePrimTy )
63
import PrelInfo		( realWorldPrimId )
64
import OrdList
65
import Maybes		( maybeToBool )
66
import Util		( zipWithEqual )
67
import Outputable
68 69 70
\end{code}


71
The guts of the simplifier is in this module, but the driver
72 73 74
loop for the simplifier is in SimplCore.lhs.


75 76 77 78 79 80 81 82 83 84
-----------------------------------------
	*** IMPORTANT NOTE ***
-----------------------------------------
The simplifier used to guarantee that the output had no shadowing, but
it does not do so any more.   (Actually, it never did!)  The reason is
documented with simplifyArgs.




85 86 87 88 89 90 91 92 93 94 95 96 97 98
%************************************************************************
%*									*
\subsection{Bindings}
%*									*
%************************************************************************

\begin{code}
simplTopBinds :: [InBind] -> SimplM [OutBind]

simplTopBinds binds
  = 	-- Put all the top-level binders into scope at the start
	-- so that if a transformation rule has unexpectedly brought
	-- anything into scope, then we don't get a complaint about that.
	-- It's rather as if the top-level binders were imported.
99
    simplRecIds (bindersOfBinds binds)	$ \ bndrs' -> 
100 101
    simpl_binds binds bndrs'		`thenSmpl` \ (binds', _) ->
    freeTick SimplifierDone		`thenSmpl_`
102
    returnSmpl (fromOL binds')
103 104
  where

105 106
	-- We need to track the zapped top-level binders, because
	-- they should have their fragile IdInfo zapped (notably occurrence info)
107
    simpl_binds []			  bs     = ASSERT( null bs ) returnSmpl (nilOL, panic "simplTopBinds corner")
108 109 110 111
    simpl_binds (NonRec bndr rhs : binds) (b:bs) = simplLazyBind True bndr  b rhs	(simpl_binds binds bs)
    simpl_binds (Rec pairs       : binds) bs     = simplRecBind  True pairs (take n bs) (simpl_binds binds (drop n bs))
					         where 
						   n = length pairs
112

113
simplRecBind :: Bool -> [(InId, InExpr)] -> [OutId]
114 115
	     -> SimplM (OutStuff a) -> SimplM (OutStuff a)
simplRecBind top_lvl pairs bndrs' thing_inside
116 117
  = go pairs bndrs'		`thenSmpl` \ (binds', (_, (binds'', res))) ->
    returnSmpl (unitOL (Rec (flattenBinds (fromOL binds'))) `appOL` binds'', res)
118 119
  where
    go [] _ = thing_inside 	`thenSmpl` \ stuff ->
120
	      returnOutStuff stuff
121 122 123 124 125 126
	
    go ((bndr, rhs) : pairs) (bndr' : bndrs')
	= simplLazyBind top_lvl bndr bndr' rhs (go pairs bndrs')
		-- Don't float unboxed bindings out,
		-- because we can't "rec" them
\end{code}
127 128 129 130 131 132 133 134


%************************************************************************
%*									*
\subsection[Simplify-simplExpr]{The main function: simplExpr}
%*									*
%************************************************************************

135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172
The reason for this OutExprStuff stuff is that we want to float *after*
simplifying a RHS, not before.  If we do so naively we get quadratic
behaviour as things float out.

To see why it's important to do it after, consider this (real) example:

	let t = f x
	in fst t
==>
	let t = let a = e1
		    b = e2
		in (a,b)
	in fst t
==>
	let a = e1
	    b = e2
	    t = (a,b)
	in
	a	-- Can't inline a this round, cos it appears twice
==>
	e1

Each of the ==> steps is a round of simplification.  We'd save a
whole round if we float first.  This can cascade.  Consider

	let f = g d
	in \x -> ...f...
==>
	let f = let d1 = ..d.. in \y -> e
	in \x -> ...f...
==>
	let d1 = ..d..
	in \x -> ...(\y ->e)...

Only in this second round can the \y be applied, and it 
might do the same again.


173
\begin{code}
174 175
simplExpr :: CoreExpr -> SimplM CoreExpr
simplExpr expr = getSubst	`thenSmpl` \ subst ->
176
		 simplExprC expr (mkStop (substTy subst (exprType expr)))
177 178
	-- The type in the Stop continuation is usually not used
	-- It's only needed when discarding continuations after finding
179 180
	-- a function that returns bottom.
	-- Hence the lazy substitution
181

182 183
simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr
	-- Simplify an expression, given a continuation
184

185
simplExprC expr cont = simplExprF expr cont	`thenSmpl` \ (floats, (_, body)) ->
186
  		       returnSmpl (wrapFloats floats body)
187

188 189
simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff
	-- Simplify an expression, returning floated binds
190

191 192 193 194
simplExprF (Var v)	    cont = simplVar v cont
simplExprF (Lit lit)	    cont = simplLit lit cont
simplExprF expr@(Lam _ _)   cont = simplLam expr cont
simplExprF (Note note expr) cont = simplNote note expr cont
195

196
simplExprF (App fun arg) cont
197
  = getSubstEnv		`thenSmpl` \ se ->
198
    simplExprF fun (ApplyTo NoDup arg se cont)
199

200 201 202 203 204
simplExprF (Type ty) cont
  = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } )
    simplType ty	`thenSmpl` \ ty' ->
    rebuild (Type ty') cont

205
simplExprF (Case scrut bndr alts) cont
206
  = getSubstEnv			`thenSmpl` \ subst_env ->
207
    getSwitchChecker 		`thenSmpl` \ chkr ->
208 209 210 211
    if not (switchIsOn chkr NoCaseOfCase) then
	-- Simplify the scrutinee with a Select continuation
	simplExprF scrut (Select NoDup bndr alts subst_env cont)

212
    else
213 214 215
	-- If case-of-case is off, simply simplify the case expression
	-- in a vanilla Stop context, and rebuild the result around it
	simplExprC scrut (Select NoDup bndr alts subst_env 
216
				 (mkStop (contResultType cont)))	`thenSmpl` \ case_expr' ->
217
	rebuild case_expr' cont
218 219

simplExprF (Let (Rec pairs) body) cont
220
  = simplRecIds (map fst pairs) 		$ \ bndrs' -> 
221 222
	-- NB: bndrs' don't have unfoldings or spec-envs
	-- We add them as we go down, using simplPrags
223

224
    simplRecBind False pairs bndrs' (simplExprF body cont)
225

226
-- A non-recursive let is dealt with by simplNonRecBind
227 228
simplExprF (Let (NonRec bndr rhs) body) cont
  = getSubstEnv			`thenSmpl` \ se ->
229
    simplNonRecBind bndr rhs se (contResultType cont)	$
230 231 232 233
    simplExprF body cont


---------------------------------
234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257
simplType :: InType -> SimplM OutType
simplType ty
  = getSubst	`thenSmpl` \ subst ->
    let
	new_ty = substTy subst ty
    in
    seqType new_ty `seq`  
    returnSmpl new_ty

---------------------------------
simplLit :: Literal -> SimplCont -> SimplM OutExprStuff

simplLit lit (Select _ bndr alts se cont)
  = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont

simplLit lit cont = rebuild (Lit lit) cont
\end{code}


%************************************************************************
%*									*
\subsection{Lambdas}
%*									*
%************************************************************************
258 259 260 261

\begin{code}
simplLam fun cont
  = go fun cont
262
  where
263
    zap_it  = mkLamBndrZapper fun cont
264 265 266 267 268
    cont_ty = contResultType cont

      	-- Type-beta reduction
    go (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
      =	ASSERT( isTyVar bndr )
269 270 271
	tick (BetaReduction bndr)	`thenSmpl_`
	simplTyArg ty_arg arg_se	`thenSmpl` \ ty_arg' ->
	extendSubst bndr (DoneTy ty_arg')
272 273 274 275 276
	(go body body_cont)

	-- Ordinary beta reduction
    go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
      = tick (BetaReduction bndr)			`thenSmpl_`
277
	simplNonRecBind zapped_bndr arg arg_se cont_ty
278 279 280 281 282 283 284 285 286
	(go body body_cont)
      where
	zapped_bndr = zap_it bndr

	-- Not enough args
    go lam@(Lam _ _) cont = completeLam [] lam cont

	-- Exactly enough args
    go expr cont = simplExprF expr cont
287

288
-- completeLam deals with the case where a lambda doesn't have an ApplyTo
289 290 291 292 293 294 295 296
-- continuation, so there are real lambdas left to put in the result

-- We try for eta reduction here, but *only* if we get all the 
-- way to an exprIsTrivial expression.    
-- We don't want to remove extra lambdas unless we are going 
-- to avoid allocating this thing altogether

completeLam rev_bndrs (Lam bndr body) cont
297
  = simplBinder bndr			$ \ bndr' ->
298
    completeLam (bndr':rev_bndrs) body cont
299

300
completeLam rev_bndrs body cont
301
  = simplExpr body 			`thenSmpl` \ body' ->
302 303 304 305 306 307
    case try_eta body' of
	Just etad_lam -> tick (EtaReduction (head rev_bndrs)) 	`thenSmpl_`
			 rebuild etad_lam cont

	Nothing	      -> rebuild (foldl (flip Lam) body' rev_bndrs) cont
  where
308
	-- We don't use CoreUtils.etaReduce, because we can be more
309 310 311 312 313 314
	-- efficient here:
	--  (a) we already have the binders,
	--  (b) we can do the triviality test before computing the free vars
	--	[in fact I take the simple path and look for just a variable]
	--  (c) we don't want to eta-reduce a data con worker or primop
	--      because we only have to eta-expand them later when we saturate
315 316 317 318 319 320 321
    try_eta body | not opt_SimplDoEtaReduction = Nothing
		 | otherwise		       = go rev_bndrs body

    go (b : bs) (App fun arg) | ok_arg b arg = go bs fun	-- Loop round
    go []       body          | ok_body body = Just body	-- Success!
    go _        _			     = Nothing		-- Failure!

322 323 324
    ok_body (Var v) = not (v `elem` rev_bndrs) && not (hasNoBinding v)
    ok_body other   = False
    ok_arg b arg    = varToCoreExpr b `cheapEqExpr` arg
325 326

mkLamBndrZapper :: CoreExpr 	-- Function
327
		-> SimplCont	-- The context
328
		-> Id -> Id	-- Use this to zap the binders
329
mkLamBndrZapper fun cont
330
  | n_args >= n_params fun = \b -> b		-- Enough args
331
  | otherwise		   = \b -> zapLamIdInfo b
332
  where
333 334 335 336 337 338 339
	-- NB: we count all the args incl type args
	-- so we must count all the binders (incl type lambdas)
    n_args = countArgs cont

    n_params (Note _ e) = n_params e
    n_params (Lam b e)  = 1 + n_params e
    n_params other	= 0::Int
340 341
\end{code}

342

343 344 345 346 347 348
%************************************************************************
%*									*
\subsection{Notes}
%*									*
%************************************************************************

sof's avatar
sof committed
349
\begin{code}
350 351
simplNote (Coerce to from) body cont
  = getInScope			`thenSmpl` \ in_scope ->
352
    let
353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385
	addCoerce s1 k1 (CoerceIt t1 cont)
		-- 	coerce T1 S1 (coerce S1 K1 e)
		-- ==>
		--	e, 			if T1=K1
		--	coerce T1 K1 e,		otherwise
		--
		-- For example, in the initial form of a worker
		-- we may find 	(coerce T (coerce S (\x.e))) y
		-- and we'd like it to simplify to e[y/x] in one round 
		-- of simplification
	  | t1 == k1  = cont		 	-- The coerces cancel out
	  | otherwise = CoerceIt t1 cont	-- They don't cancel, but 
						-- the inner one is redundant

	addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
	  | Just (s1, s2) <- splitFunTy_maybe s1s2
		--	(coerce (T1->T2) (S1->S2) F) E
		-- ===> 
		--	coerce T2 S2 (F (coerce S1 T1 E))
		--
		-- t1t2 must be a function type, T1->T2
		-- but s1s2 might conceivably not be
		--
		-- When we build the ApplyTo we can't mix the out-types
		-- with the InExpr in the argument, so we simply substitute
		-- to make it all consistent.  This isn't a common case.
	  = let 
		(t1,t2) = splitFunTy t1t2
		new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope arg_se) arg)
	    in
	    ApplyTo dup new_arg emptySubstEnv (addCoerce t2 s2 cont)
			
	addCoerce to' _ cont = CoerceIt to' cont
386
    in
387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443
    simplType to		`thenSmpl` \ to' ->
    simplType from		`thenSmpl` \ from' ->
    simplExprF body (addCoerce to' from' cont)

		
-- Hack: we only distinguish subsumed cost centre stacks for the purposes of
-- inlining.  All other CCCSs are mapped to currentCCS.
simplNote (SCC cc) e cont
  = setEnclosingCC currentCCS $
    simplExpr e 	`thenSmpl` \ e ->
    rebuild (mkSCC cc e) cont

simplNote InlineCall e cont
  = simplExprF e (InlinePlease cont)

--	 Comments about the InlineMe case 
--	 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Don't inline in the RHS of something that has an
-- inline pragma.  But be careful that the InScopeEnv that
-- we return does still have inlinings on!
-- 
-- It really is important to switch off inlinings.  This function
-- may be inlinined in other modules, so we don't want to remove
-- (by inlining) calls to functions that have specialisations, or
-- that may have transformation rules in an importing scope.
-- E.g. 	{-# INLINE f #-}
-- 		f x = ...g...
-- and suppose that g is strict *and* has specialisations.
-- If we inline g's wrapper, we deny f the chance of getting
-- the specialised version of g when f is inlined at some call site
-- (perhaps in some other module).

-- It's also important not to inline a worker back into a wrapper.
-- A wrapper looks like
--	wraper = inline_me (\x -> ...worker... )
-- Normally, the inline_me prevents the worker getting inlined into
-- the wrapper (initially, the worker's only call site!).  But,
-- if the wrapper is sure to be called, the strictness analyser will
-- mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
-- continuation.  That's why the keep_inline predicate returns True for
-- ArgOf continuations.  It shouldn't do any harm not to dissolve the
-- inline-me note under these circumstances

simplNote InlineMe e cont
  | keep_inline cont		-- Totally boring continuation
  =				-- Don't inline inside an INLINE expression
    setBlackList noInlineBlackList (simplExpr e)	`thenSmpl` \ e' ->
    rebuild (mkInlineMe e') cont

  | otherwise  	-- Dissolve the InlineMe note if there's
		-- an interesting context of any kind to combine with
		-- (even a type application -- anything except Stop)
  = simplExprF e cont
  where
    keep_inline (Stop _ _)    = True		-- See notes above
    keep_inline (ArgOf _ _ _) = True		-- about this predicate
    keep_inline other	      = False
444 445 446
\end{code}


447 448
%************************************************************************
%*									*
449
\subsection{Binding}
450 451
%*									*
%************************************************************************
452

453
@simplNonRecBind@ is used for non-recursive lets in expressions, 
454
as well as true beta reduction.
455

456
Very similar to @simplLazyBind@, but not quite the same.
457

458
\begin{code}
459
simplNonRecBind :: InId 		-- Binder
460 461 462 463
	  -> InExpr -> SubstEnv		-- Arg, with its subst-env
	  -> OutType			-- Type of thing computed by the context
	  -> SimplM OutExprStuff	-- The body
	  -> SimplM OutExprStuff
464
#ifdef DEBUG
465
simplNonRecBind bndr rhs rhs_se cont_ty thing_inside
466
  | isTyVar bndr
467
  = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)
468
#endif
469

470
simplNonRecBind bndr rhs rhs_se cont_ty thing_inside
471
  | preInlineUnconditionally False {- not black listed -} bndr
472 473
  = tick (PreInlineUnconditionally bndr)		`thenSmpl_`
    extendSubst bndr (ContEx rhs_se rhs) thing_inside
474

475
  | otherwise
476 477 478 479 480
  =  	-- Simplify the binder.
	-- Don't use simplBinder because that doesn't keep 
	-- fragile occurrence in the substitution
    simplLetId bndr					$ \ bndr' ->
    getSubst						`thenSmpl` \ bndr_subst ->
481
    let
482 483 484 485 486
	-- Substitute its IdInfo (which simplLetId does not)
	-- The appropriate substitution env is the one right here,
	-- not rhs_se.  Often they are the same, when all this 
	-- has arisen from an application (\x. E) RHS, perhaps they aren't
	bndr''    = simplIdInfo bndr_subst (idInfo bndr) bndr'
487 488 489
	bndr_ty'  = idType bndr'
	is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty'
    in
490 491 492
    modifyInScope bndr'' bndr''				$

	-- Simplify the argument
493
    simplValArg bndr_ty' is_strict rhs rhs_se cont_ty	$ \ rhs' ->
494 495

	-- Now complete the binding and simplify the body
496
    if needsCaseBinding bndr_ty' rhs' then
497
	addCaseBind bndr'' rhs' thing_inside
498
    else
499
	completeBinding bndr bndr'' False False rhs' thing_inside
500
\end{code}
501 502


503
\begin{code}
504 505 506 507 508 509 510 511 512
simplTyArg :: InType -> SubstEnv -> SimplM OutType
simplTyArg ty_arg se
  = getInScope		`thenSmpl` \ in_scope ->
    let
	ty_arg' = substTy (mkSubst in_scope se) ty_arg
    in
    seqType ty_arg'	`seq`
    returnSmpl ty_arg'

513 514
simplValArg :: OutType		-- rhs_ty: Type of arg; used only occasionally
	    -> Bool		-- True <=> evaluate eagerly
515
	    -> InExpr -> SubstEnv
516 517 518 519 520 521 522 523
	    -> OutType		-- cont_ty: Type of thing computed by the context
	    -> (OutExpr -> SimplM OutExprStuff)	
				-- Takes an expression of type rhs_ty, 
				-- returns an expression of type cont_ty
	    -> SimplM OutExprStuff	-- An expression of type cont_ty

simplValArg arg_ty is_strict arg arg_se cont_ty thing_inside
  | is_strict
524
  = getEnv 				`thenSmpl` \ env ->
525
    setSubstEnv arg_se 				$
526
    simplExprF arg (ArgOf NoDup cont_ty 	$ \ rhs' ->
527
    setAllExceptInScope env			$
528
    thing_inside rhs')
529

530
  | otherwise
531 532
  = simplRhs False {- Not top level -} 
	     True {- OK to float unboxed -}
533 534
	     arg_ty arg arg_se 
	     thing_inside
535
\end{code}
536 537


538 539 540
completeBinding
	- deals only with Ids, not TyVars
	- take an already-simplified RHS
541

542
It does *not* attempt to do let-to-case.  Why?  Because they are used for
543

544 545
	- top-level bindings
		(when let-to-case is impossible) 
546

547 548
	- many situations where the "rhs" is known to be a WHNF
		(so let-to-case is inappropriate).
549 550

\begin{code}
551 552
completeBinding :: InId 		-- Binder
		-> OutId		-- New binder
553
		-> Bool			-- True <=> top level
554
		-> Bool			-- True <=> black-listed; don't inline
555 556 557
	        -> OutExpr		-- Simplified RHS
		-> SimplM (OutStuff a)	-- Thing inside
	   	-> SimplM (OutStuff a)
558

559
completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside
560 561 562
  |  isDeadOcc occ_info 	-- This happens; for example, the case_bndr during case of
				-- known constructor:  case (a,b) of x { (p,q) -> ... }
				-- Here x isn't mentioned in the RHS, so we don't want to
563 564
				-- create the (dead) let-binding  let x = (a,b) in ...
  =  thing_inside
565

566
  | trivial_rhs && not must_keep_binding
567 568 569
	-- We're looking at a binding with a trivial RHS, so
	-- perhaps we can discard it altogether!
	--
570
	-- NB: a loop breaker has must_keep_binding = True
571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589
	-- and non-loop-breakers only have *forward* references
	-- Hence, it's safe to discard the binding
	--	
	-- NOTE: This isn't our last opportunity to inline.
	-- We're at the binding site right now, and
	-- we'll get another opportunity when we get to the ocurrence(s)

	-- Note that we do this unconditional inlining only for trival RHSs.
	-- Don't inline even WHNFs inside lambdas; doing so may
	-- simply increase allocation when the function is called
	-- This isn't the last chance; see NOTE above.
	--
	-- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here
	-- Why?  Because we don't even want to inline them into the
	-- RHS of constructor arguments. See NOTE above
	--
	-- NB: Even NOINLINEis ignored here: if the rhs is trivial
	-- it's best to inline it anyway.  We often get a=E; b=a
	-- from desugaring, with both a and b marked NOINLINE.
590 591
  = 		-- Drop the binding
    extendSubst old_bndr (DoneEx new_rhs)	$
592 593
		-- Use the substitution to make quite, quite sure that the substitution
		-- will happen, since we are going to discard the binding
594 595
    tick (PostInlineUnconditionally old_bndr)	`thenSmpl_`
    thing_inside
596

597
  | Note coercion@(Coerce _ inner_ty) inner_rhs <- new_rhs,
598
    not trivial_rhs && not (isUnLiftedType inner_ty)
599 600 601 602 603 604 605
	-- x = coerce t e  ==>  c = e; x = inline_me (coerce t c)
	-- Now x can get inlined, which moves the coercion
	-- to the usage site.  This is a bit like worker/wrapper stuff,
	-- but it's useful to do it very promptly, so that
	--	x = coerce T (I# 3)
	-- get's w/wd to
	--	c = I# 3
606
	--	x = coerce T c
607 608 609 610
	-- This in turn means that
	--	case (coerce Int x) of ...
	-- will inline x.  
	-- Also the full-blown w/w thing isn't set up for non-functions
611
	--
612 613 614 615 616 617 618 619 620 621
	-- The (not (isUnLiftedType inner_ty)) avoids the nasty case of
	--	x::Int = coerce Int Int# (foo y)
	-- ==>
	--	v::Int# = foo y
	--	x::Int  = coerce Int Int# v
	-- which would be bogus because then v will be evaluated strictly.
	-- How can this arise?  Via 
	--	x::Int = case (foo y) of { ... }
	-- followed by case elimination.
	--
622 623 624 625 626
	-- The inline_me note is so that the simplifier doesn't 
	-- just substitute c back inside x's rhs!  (Typically, x will
	-- get substituted away, but not if it's exported.)
  = newId SLIT("c") inner_ty 					$ \ c_id ->
    completeBinding c_id c_id top_lvl False inner_rhs		$
627 628
    completeBinding old_bndr new_bndr top_lvl black_listed
		    (Note InlineMe (Note coercion (Var c_id)))	$
629 630
    thing_inside

631
  |  otherwise
632
  = let
633 634 635
		-- We make new IdInfo for the new binder by starting from the old binder, 
		-- doing appropriate substitutions.
		-- Then we add arity and unfolding info to get the new binder
636
  	new_bndr_info = idInfo new_bndr `setArityInfo` arity_info
637 638 639 640 641 642

		-- Add the unfolding *only* for non-loop-breakers
		-- Making loop breakers not have an unfolding at all 
		-- means that we can avoid tests in exprIsConApp, for example.
		-- This is important: if exprIsConApp says 'yes' for a recursive
		-- thing, then we can get into an infinite loop
643 644
        info_w_unf | loop_breaker = new_bndr_info
		   | otherwise    = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
645

646 647
	final_id = new_bndr `setIdInfo` info_w_unf
    in
648 649
		-- These seqs forces the Id, and hence its IdInfo,
		-- and hence any inner substitutions
650 651 652 653 654 655 656 657 658 659 660
    final_id				`seq`
    addLetBind (NonRec final_id new_rhs) 	$
    modifyInScope new_bndr final_id thing_inside

  where
    old_info          = idInfo old_bndr
    occ_info          = occInfo old_info
    loop_breaker      = isLoopBreaker occ_info
    trivial_rhs	      = exprIsTrivial new_rhs
    must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr
    arity_info	      = atLeastArity (exprArity new_rhs)
661
\end{code}    
662

663

664

665 666
%************************************************************************
%*									*
667
\subsection{simplLazyBind}
668 669
%*									*
%************************************************************************
670

671
simplLazyBind basically just simplifies the RHS of a let(rec).
672
It does two important optimisations though:
673

674 675
	* It floats let(rec)s out of the RHS, even if they
	  are hidden by big lambdas
676

677
	* It does eta expansion
678

679
\begin{code}
680
simplLazyBind :: Bool			-- True <=> top level
681 682 683 684 685 686 687 688 689
	      -> InId -> OutId
	      -> InExpr 		-- The RHS
	      -> SimplM (OutStuff a)	-- The body of the binding
	      -> SimplM (OutStuff a)
-- When called, the subst env is correct for the entire let-binding
-- and hence right for the RHS.
-- Also the binder has already been simplified, and hence is in scope

simplLazyBind top_lvl bndr bndr' rhs thing_inside
690
  = getBlackList		`thenSmpl` \ black_list_fn ->
691 692
    let
	black_listed = black_list_fn bndr
693
    in
694 695 696 697 698

    if preInlineUnconditionally black_listed bndr then
	-- Inline unconditionally
	tick (PreInlineUnconditionally bndr)	`thenSmpl_`
	getSubstEnv 				`thenSmpl` \ rhs_se ->
699
	(extendSubst bndr (ContEx rhs_se rhs) thing_inside)
700
    else
701

702
  	-- Simplify the RHS
703 704 705 706 707 708 709 710 711
    getSubst 					`thenSmpl` \ rhs_subst ->
    let
	-- Substitute IdInfo on binder, in the light of earlier
	-- substitutions in this very letrec, and extend the in-scope
	-- env so that it can see the new thing
	bndr'' = simplIdInfo rhs_subst (idInfo bndr) bndr'
    in
    modifyInScope bndr'' bndr''				$

712
    simplRhs top_lvl False {- Not ok to float unboxed (conservative) -}
713
	     (idType bndr')
714
	     rhs (substEnv rhs_subst)			$ \ rhs' ->
715 716

	-- Now compete the binding and simplify the body
717
    completeBinding bndr bndr'' top_lvl black_listed rhs' thing_inside
718
\end{code}
719 720 721



722
\begin{code}
723
simplRhs :: Bool		-- True <=> Top level
724
	 -> Bool		-- True <=> OK to float unboxed (speculative) bindings
725
				--	    False for (a) recursive and (b) top-level bindings
726 727
	 -> OutType 		-- Type of RHS; used only occasionally
	 -> InExpr -> SubstEnv
728 729 730
	 -> (OutExpr -> SimplM (OutStuff a))
	 -> SimplM (OutStuff a)
simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside
731
  =	-- Simplify it
732
    setSubstEnv rhs_se (simplExprF rhs (mkRhsStop rhs_ty))	`thenSmpl` \ (floats1, (rhs_in_scope, rhs1)) ->
733
    let
734
	(floats2, rhs2) = splitFloats float_ubx floats1 rhs1
735 736 737 738 739 740 741
    in
		-- There's a subtlety here.  There may be a binding (x* = e) in the
		-- floats, where the '*' means 'will be demanded'.  So is it safe
		-- to float it out?  Answer no, but it won't matter because
		-- we only float if arg' is a WHNF,
		-- and so there can't be any 'will be demanded' bindings in the floats.
		-- Hence the assert
742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765
    WARN( any demanded_float (fromOL floats2), ppr (fromOL floats2) )

	-- 			Transform the RHS
	-- It's important that we do eta expansion on function *arguments* (which are
	-- simplified with simplRhs), as well as let-bound right-hand sides.  
	-- Otherwise we find that things like
	--	f (\x -> case x of I# x' -> coerce T (\ y -> ...))
	-- get right through to the code generator as two separate lambdas, 
	-- which is a Bad Thing
    tryRhsTyLam rhs2		`thenSmpl` \ (floats3, rhs3) ->
    tryEtaExpansion rhs3 rhs_ty	`thenSmpl` \ (floats4, rhs4) ->

 	-- Float lets if (a) we're at the top level
	-- or 		 (b) the resulting RHS is one we'd like to expose
    if (top_lvl || exprIsCheap rhs4) then
	(if (isNilOL floats2 && null floats3 && null floats4) then
		returnSmpl ()
	 else
		tick LetFloatFromLet)			`thenSmpl_`

	addFloats floats2 rhs_in_scope	$
	addAuxiliaryBinds floats3 	$
	addAuxiliaryBinds floats4 	$
	thing_inside rhs4
766 767
    else	
		-- Don't do the float
768
	thing_inside (wrapFloats floats1 rhs1)
769

770
demanded_float (NonRec b r) = isStrict (idDemandInfo b) && not (isUnLiftedType (idType b))
771 772 773
		-- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
demanded_float (Rec _)	    = False

774 775 776 777 778 779
-- If float_ubx is true we float all the bindings, otherwise
-- we just float until we come across an unlifted one.
-- Remember that the unlifted bindings in the floats are all for
-- guaranteed-terminating non-exception-raising unlifted things,
-- which we are happy to do speculatively.  However, we may still
-- not be able to float them out, because the context
780 781
-- is either a Rec group, or the top level, neither of which
-- can tolerate them.
782 783
splitFloats float_ubx floats rhs
  | float_ubx = (floats, rhs)		-- Float them all
784
  | otherwise = go (fromOL floats)
785
  where
786 787
    go []		    = (nilOL, rhs)
    go (f:fs) | must_stay f = (nilOL, mkLets (f:fs) rhs)
788
	      | otherwise   = case go fs of
789
				   (out, rhs') -> (f `consOL` out, rhs')
790

791 792
    must_stay (Rec prs)    = False	-- No unlifted bindings in here
    must_stay (NonRec b r) = isUnLiftedType (idType b)
793 794 795
\end{code}


796

797 798
%************************************************************************
%*									*
799
\subsection{Variables}
800 801 802 803
%*									*
%************************************************************************

\begin{code}
804
simplVar var cont
805
  = getSubst		`thenSmpl` \ subst ->
806 807 808
    case lookupIdSubst subst var of
	DoneEx e	-> zapSubstEnv (simplExprF e cont)
	ContEx env1 e   -> setSubstEnv env1 (simplExprF e cont)
809
	DoneId var1 occ -> WARN( not (isInScope var1 subst) && mustHaveLocalBinding var1,
810
				 text "simplVar:" <+> ppr var )
811
			   zapSubstEnv (completeCall var1 occ cont)
812 813 814 815 816 817 818 819
		-- The template is already simplified, so don't re-substitute.
		-- This is VITAL.  Consider
		--	let x = e in
		--	let y = \z -> ...x... in
		--	\ x -> ...y...
		-- We'll clone the inner \x, adding x->x' in the id_subst
		-- Then when we inline y, we must *not* replace x by x' in
		-- the inlined copy!!
820

821 822 823
---------------------------------------------------------
--	Dealing with a call

824
completeCall var occ_info cont
825 826 827
  = getBlackList		`thenSmpl` \ black_list_fn ->
    getInScope			`thenSmpl` \ in_scope ->
    getContArgs var cont	`thenSmpl` \ (args, call_cont, inline_call) ->
828
    getDOptsSmpl		`thenSmpl` \ dflags ->
829
    let
830
	black_listed       = black_list_fn var
831 832 833 834 835 836
	arg_infos	   = [ interestingArg in_scope arg subst 
			     | (arg, subst, _) <- args, isValArg arg]

	interesting_cont = interestingCallContext (not (null args)) 
						  (not (null arg_infos))
						  call_cont
837

838 839
	inline_cont | inline_call = discardInline cont
		    | otherwise   = cont
840

841
	maybe_inline = callSiteInline dflags black_listed inline_call occ_info
842 843 844 845 846 847
				      var arg_infos interesting_cont
    in
	-- First, look for an inlining
    case maybe_inline of {
	Just unfolding  	-- There is an inlining!
	  ->  tick (UnfoldingDone var)		`thenSmpl_`
848
	      simplExprF unfolding inline_cont
849 850 851 852

	;
	Nothing -> 		-- No inlining!

853 854 855

    simplifyArgs (isDataConId var) args (contResultType call_cont)  $ \ args' ->

856
	-- Next, look for rules or specialisations that match
857 858 859 860 861 862 863 864 865 866 867 868
	--
	-- It's important to simplify the args first, because the rule-matcher
	-- doesn't do substitution as it goes.  We don't want to use subst_args
	-- (defined in the 'where') because that throws away useful occurrence info,
	-- and perhaps-very-important specialisations.
	--
	-- Some functions have specialisations *and* are strict; in this case,
	-- we don't want to inline the wrapper of the non-specialised thing; better
	-- to call the specialised thing instead.
	-- But the black-listing mechanism means that inlining of the wrapper
	-- won't occur for things that have specialisations till a later phase, so
	-- it's ok to try for inlining first.
869
	--
870 871 872 873 874 875 876 877 878 879 880
	-- You might think that we shouldn't apply rules for a loop breaker: 
	-- doing so might give rise to an infinite loop, because a RULE is
	-- rather like an extra equation for the function:
	--	RULE:		f (g x) y = x+y
	--	Eqn:		f a     y = a-y
	--
	-- But it's too drastic to disable rules for loop breakers.  
	-- Even the foldr/build rule would be disabled, because foldr 
	-- is recursive, and hence a loop breaker:
	--	foldr k z (build g) = g k z
	-- So it's up to the programmer: rules can cause divergence
881

882
    getSwitchChecker 	`thenSmpl` \ chkr ->
883
    let
884
	maybe_rule | switchIsOn chkr DontApplyRules = Nothing
885
		   | otherwise			    = lookupRule in_scope var args' 
886 887
    in
    case maybe_rule of {
888
	Just (rule_name, rule_rhs) -> 
889
		tick (RuleFired rule_name)			`thenSmpl_`
890 891 892 893 894 895 896 897 898
#ifdef DEBUG
		(if dopt Opt_D_dump_inlinings dflags then
		   pprTrace "Rule fired" (vcat [
			text "Rule:" <+> ptext rule_name,
			text "Before:" <+> ppr var <+> sep (map pprParendExpr args'),
			text "After: " <+> pprCoreExpr rule_rhs])
		 else
			id)		$
#endif
899
		simplExprF rule_rhs call_cont ;
900
	
901
	Nothing -> 		-- No rules
902

903
	-- Done
904
    rebuild (mkApps (Var var) args') call_cont
905
    }}
906 907


908
---------------------------------------------------------
909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945
--	Simplifying the arguments of a call

simplifyArgs :: Bool 				-- It's a data constructor
	     -> [(InExpr, SubstEnv, Bool)]	-- Details of the arguments
	     -> OutType				-- Type of the continuation
	     -> ([OutExpr] -> SimplM OutExprStuff)
	     -> SimplM OutExprStuff

-- Simplify the arguments to a call.
-- This part of the simplifier may break the no-shadowing invariant
-- Consider
--	f (...(\a -> e)...) (case y of (a,b) -> e')
-- where f is strict in its second arg
-- If we simplify the innermost one first we get (...(\a -> e)...)
-- Simplifying the second arg makes us float the case out, so we end up with
--	case y of (a,b) -> f (...(\a -> e)...) e'
-- So the output does not have the no-shadowing invariant.  However, there is
-- no danger of getting name-capture, because when the first arg was simplified
-- we used an in-scope set that at least mentioned all the variables free in its
-- static environment, and that is enough.
--
-- We can't just do innermost first, or we'd end up with a dual problem:
--	case x of (a,b) -> f e (...(\a -> e')...)
--
-- I spent hours trying to recover the no-shadowing invariant, but I just could
-- not think of an elegant way to do it.  The simplifier is already knee-deep in
-- continuations.  We have to keep the right in-scope set around; AND we have
-- to get the effect that finding (error "foo") in a strict arg position will
-- discard the entire application and replace it with (error "foo").  Getting
-- all this at once is TOO HARD!

simplifyArgs is_data_con args cont_ty thing_inside
  | not is_data_con
  = go args thing_inside

  | otherwise	-- It's a data constructor, so we want 
		-- to switch off inlining in the arguments
946 947 948 949
		-- If we don't do this, consider:
		--	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!
950 951 952 953 954
  = getBlackList				`thenSmpl` \ old_bl ->
    setBlackList noInlineBlackList		$
    go args					$ \ args' ->
    setBlackList old_bl				$
    thing_inside args'
955

956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994
  where
    go []	  thing_inside = thing_inside []
    go (arg:args) thing_inside = simplifyArg is_data_con arg cont_ty 	$ \ arg' ->
				 go args 				$ \ args' ->
				 thing_inside (arg':args')

simplifyArg is_data_con (Type ty_arg, se, _) cont_ty thing_inside
  = simplTyArg ty_arg se	`thenSmpl` \ new_ty_arg ->
    thing_inside (Type new_ty_arg)

simplifyArg is_data_con (val_arg, se, is_strict) cont_ty thing_inside
  = getInScope		`thenSmpl` \ in_scope ->
    let
	arg_ty = substTy (mkSubst in_scope se) (exprType val_arg)
    in
    if not is_data_con then
	-- An ordinary function
	simplValArg arg_ty is_strict val_arg se cont_ty thing_inside
    else
	-- A data constructor
	-- simplifyArgs has already switched off inlining, so 
	-- all we have to do here is to let-bind any non-trivial argument

	-- It's not always the case that new_arg will be trivial
	-- Consider		f x
	-- where, in one pass, f gets substituted by a constructor,
	-- but x gets substituted by an expression (assume this is the
	-- unique occurrence of x).  It doesn't really matter -- it'll get
	-- fixed up next pass.  And it happens for dictionary construction,
	-- which mentions the wrapper constructor to start with.
	simplValArg arg_ty is_strict val_arg se cont_ty 	$ \ arg' ->
	
	if exprIsTrivial arg' then
	     thing_inside arg'
	else
	newId SLIT("a") (exprType arg')		$ \ arg_id ->
	addNonRecBind arg_id arg'		$
	thing_inside (Var arg_id)
\end{code}		   
995

996

997 998 999 1000 1001
%************************************************************************
%*									*
\subsection{Decisions about inlining}
%*									*
%************************************************************************
1002

1003 1004 1005 1006 1007
NB: At one time I tried not pre/post-inlining top-level things,
even if they occur exactly once.  Reason: 
	(a) some might appear as a function argument, so we simply
		replace static allocation with dynamic allocation:
		   l = <...>
1008
		   x = f l
1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019
	becomes
		   x = f <...>

	(b) some top level things might be black listed

HOWEVER, I found that some useful foldr/build fusion was lost (most
notably in spectral/hartel/parstof) because the foldr didn't see the build.

Doing the dynamic allocation isn't a big deal, in fact, but losing the
fusion can be.

1020
\begin{code}
1021
preInlineUnconditionally :: Bool {- Black listed -} -> InId -> Bool
1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038
	-- Examines a bndr to see if it is used just once in a 
	-- completely safe way, so that it is safe to discard the binding
	-- inline its RHS at the (unique) usage site, REGARDLESS of how
	-- big the RHS might be.  If this is the case we don't simplify
	-- the RHS first, but just inline it un-simplified.
	--
	-- This is much better than first simplifying a perhaps-huge RHS
	-- and then inlining and re-simplifying it.
	--
	-- NB: we don't even look at the RHS to see if it's trivial
	-- We might have
	--			x = y
	-- where x is used many times, but this is the unique occurrence
	-- of y.  We should NOT inline x at all its uses, because then
	-- we'd do the same for y -- aargh!  So we must base this
	-- pre-rhs-simplification decision solely on x's occurrences, not
	-- on its rhs.
1039 1040 1041
	-- 
	-- Evne RHSs labelled InlineMe aren't caught here, because
	-- there might be no benefit from inlining at the call site.
1042 1043 1044

preInlineUnconditionally black_listed bndr
  | black_listed || opt_SimplNoPreInlining = False
1045
  | otherwise = case idOccInfo bndr of
1046 1047 1048
	  	  OneOcc in_lam once -> not in_lam && once
			-- Not inside a lambda, one occurrence ==> safe!
		  other 	     -> False
1049
\end{code}
1050

1051

1052

1053 1054 1055 1056 1057
%************************************************************************
%*									*
\subsection{The main rebuilder}
%*									*
%************************************************************************
1058

1059 1060
\begin{code}
-------------------------------------------------------------------
1061
-- Finish rebuilding
1062
rebuild_done expr = returnOutStuff expr
1063

1064
---------------------------------------------------------