SimplMonad.lhs 29.2 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1993-1998
3 4 5 6 7
%
\section[SimplMonad]{The simplifier Monad}

\begin{code}
module SimplMonad (
8 9
	InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
	OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
10
	OutExprStuff, OutStuff,
11 12

	-- The continuation type
13
	SimplCont(..), DupFlag(..), contIsDupable, contResultType,
14
	contIsInteresting, pushArgs, discardCont, countValArgs, countArgs,
15
	contArgs, contIsInline, discardInline,
16 17 18

	-- The monad
	SimplM,
19
	initSmpl, returnSmpl, thenSmpl, thenSmpl_,
20 21
	mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,

22 23 24
	-- The inlining black-list
	getBlackList,

25 26
        -- Unique supply
        getUniqueSmpl, getUniquesSmpl,
27
	newId, newIds,
28

29
	-- Counting
30
	SimplCount, Tick(..),
31
	tick, freeTick,
32 33 34 35 36 37 38 39 40 41
	getSimplCount, zeroSimplCount, pprSimplCount, 
	plusSimplCount, isZeroSimplCount,

	-- Switch checker
	SwitchChecker, getSwitchChecker, getSimplIntSwitch,

	-- Cost centres
	getEnclosingCC, setEnclosingCC,

	-- Environments
42
	getEnv, setAllExceptInScope,
43 44
	getSubst, setSubst,
	getSubstEnv, extendSubst, extendSubstList,
45
	getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
46
	setSubstEnv, zapSubstEnv,
47 48
	getSimplBinderStuff, setSimplBinderStuff,
	switchOffInlining
49 50
    ) where

51
#include "HsVersions.h"
52

53
import Const		( Con(DEFAULT) )
54
import Id		( Id, mkSysLocal, getIdUnfolding )
55
import IdInfo		( InlinePragInfo(..) )
56
import Demand		( Demand )
57
import CoreSyn
58
import CoreUnfold	( isCompulsoryUnfolding )
59 60
import PprCore		()	-- Instances
import Rules		( RuleBase )
61
import CostCentre	( CostCentreStack, subsumedCCS )
62
import Name		( isLocallyDefined )
63 64 65
import Var		( TyVar )
import VarEnv
import VarSet
66 67
import qualified Subst
import Subst		( Subst, emptySubst, mkSubst,
68
			  substTy, substEnv, substExpr,
69 70 71
			  InScopeSet, substInScope, isInScope, lookupInScope
			)
import Type             ( Type, TyVarSubst, applyTy )
72
import UniqSupply	( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
73 74
			  UniqSupply
			)
75 76 77 78 79
import FiniteMap
import CmdLineOpts	( SimplifierSwitch(..), SwitchResult(..),
			  opt_PprStyle_Debug, opt_HistorySize,
			  intSwitchSet
			)
80
import Unique		( Unique )
81 82
import Maybes		( expectJust )
import Util		( zipWithEqual )
83
import Outputable
84 85 86 87

infixr 9  `thenSmpl`, `thenSmpl_`
\end{code}

88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121
%************************************************************************
%*									*
\subsection[Simplify-types]{Type declarations}
%*									*
%************************************************************************

\begin{code}
type InBinder  = CoreBndr
type InId      = Id			-- Not yet cloned
type InType    = Type			-- Ditto
type InBind    = CoreBind
type InExpr    = CoreExpr
type InAlt     = CoreAlt
type InArg     = CoreArg

type OutBinder  = CoreBndr
type OutId	= Id			-- Cloned
type OutType	= Type			-- Cloned
type OutBind	= CoreBind
type OutExpr	= CoreExpr
type OutAlt	= CoreAlt
type OutArg	= CoreArg

type SwitchChecker = SimplifierSwitch -> SwitchResult
\end{code}


%************************************************************************
%*									*
\subsection{The continuation data type}
%*									*
%************************************************************************

\begin{code}
122
type OutExprStuff = OutStuff (InScopeSet, OutExpr)
123 124 125 126 127 128
type OutStuff a   = ([OutBind], a)
	-- We return something equivalent to (let b in e), but
	-- in pieces to avoid the quadratic blowup when floating 
	-- incrementally.  Comments just before simplExprB in Simplify.lhs

data SimplCont		-- Strict contexts
129
  = Stop OutType		-- Type of the result
130

131
  | CoerceIt OutType			-- The To-type, simplified
132 133
	     SimplCont

134 135 136
  | InlinePlease			-- This continuation makes a function very
	     SimplCont			-- keen to inline itelf

137 138 139 140 141 142 143 144
  | ApplyTo  DupFlag 
	     InExpr SubstEnv		-- The argument, as yet unsimplified, 
	     SimplCont			-- and its subst-env

  | Select   DupFlag 
	     InId [InAlt] SubstEnv	-- The case binder, alts, and subst-env
	     SimplCont

145 146 147 148 149 150 151
  | ArgOf    DupFlag		-- An arbitrary strict context: the argument 
  	     			-- 	of a strict function, or a primitive-arg fn
				-- 	or a PrimOp
	     OutType		-- The type of the expression being sought by the context
				--	f (error "foo") ==> coerce t (error "foo")
				-- when f is strict
				-- We need to know the type t, to which to coerce.
152
	     (OutExpr -> SimplM OutExprStuff)	-- What to do with the result
153

154
instance Outputable SimplCont where
155
  ppr (Stop _)        		     = ptext SLIT("Stop")
156
  ppr (ApplyTo dup arg se cont)      = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
157
  ppr (ArgOf   dup _ _)   	     = ptext SLIT("ArgOf...") <+> ppr dup
158 159
  ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$ 
				       (nest 4 (ppr alts)) $$ ppr cont
160 161
  ppr (CoerceIt ty cont)	     = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
  ppr (InlinePlease cont)	     = ptext SLIT("InlinePlease") $$ ppr cont
162 163 164 165 166 167 168 169

data DupFlag = OkToDup | NoDup

instance Outputable DupFlag where
  ppr OkToDup = ptext SLIT("ok")
  ppr NoDup   = ptext SLIT("nodup")

contIsDupable :: SimplCont -> Bool
170
contIsDupable (Stop _)       		 = True
171 172 173
contIsDupable (ApplyTo  OkToDup _ _ _)   = True
contIsDupable (ArgOf    OkToDup _ _)     = True
contIsDupable (Select   OkToDup _ _ _ _) = True
174 175
contIsDupable (CoerceIt _ cont)          = contIsDupable cont
contIsDupable (InlinePlease cont)	 = contIsDupable cont
176 177
contIsDupable other			 = False

178 179 180 181 182 183 184 185 186 187
contArgs :: InScopeSet -> SimplCont -> ([OutExpr], SimplCont)
	-- Get the arguments from the continuation
	-- Apply the appropriate substitution first;
	-- this is done lazily and typically only the bit at the top is used
contArgs in_scope (ApplyTo _ e s cont)
  = case contArgs in_scope cont of
	(args, result) -> (substExpr (mkSubst in_scope s) e : args, result)
contArgs in_scope result_cont	
   = ([], result_cont)

188 189 190 191
contIsInline :: SimplCont -> Bool
contIsInline (InlinePlease cont) = True
contIsInline other		 = False

192 193 194 195
discardInline :: SimplCont -> SimplCont
discardInline (InlinePlease cont)  = cont
discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
discardInline cont		   = cont
196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237
\end{code}


Comment about contIsInteresting
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to avoid inlining an expression where there can't possibly be
any gain, such as in an argument position.  Hence, if the continuation
is interesting (eg. a case scrutinee, application etc.) then we
inline, otherwise we don't.  

Previously some_benefit used to return True only if the variable was
applied to some value arguments.  This didn't work:

	let x = _coerce_ (T Int) Int (I# 3) in
	case _coerce_ Int (T Int) x of
		I# y -> ....

we want to inline x, but can't see that it's a constructor in a case
scrutinee position, and some_benefit is False.

Another example:

dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)

....  case dMonadST _@_ x0 of (a,b,c) -> ....

we'd really like to inline dMonadST here, but we *don't* want to
inline if the case expression is just

	case x of y { DEFAULT -> ... }

since we can just eliminate this case instead (x is in WHNF).  Similar
applies when x is bound to a lambda expression.  Hence
contIsInteresting looks for case expressions with just a single
default case.

\begin{code}
contIsInteresting :: SimplCont -> Bool
contIsInteresting (Select _ _ alts _ _)       = not (just_default alts)
contIsInteresting (CoerceIt _ cont)           = contIsInteresting cont
contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
contIsInteresting (ApplyTo _ _	      _ _)    = True
238 239

contIsInteresting (ArgOf _ _ _)		      = False
240 241 242 243 244 245 246
	-- If this call is the arg of a strict function, the context
	-- is a bit interesting.  If we inline here, we may get useful
	-- evaluation information to avoid repeated evals: e.g.
	--	x + (y * z)
	-- Here the contIsInteresting makes the '*' keener to inline,
	-- which in turn exposes a constructor which makes the '+' inline.
	-- Assuming that +,* aren't small enough to inline regardless.
247 248 249 250 251 252 253
	--
	-- HOWEVER, I put this back to False when I discovered that strings
	-- were getting inlined straight back into applications of 'error'
	-- because the latter is strict.
	--	s = "foo"
	--	f = \x -> ...(error s)...

254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289
contIsInteresting (InlinePlease _)	      = True
contIsInteresting other		              = False

just_default [(DEFAULT,_,_)] = True	-- See notes below for why we look
just_default alts	     = False	-- for this special case
\end{code}


\begin{code}
pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
pushArgs se []         cont = cont
pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)

discardCont :: SimplCont	-- A continuation, expecting
	    -> SimplCont	-- Replace the continuation with a suitable coerce
discardCont (Stop to_ty) = Stop to_ty
discardCont cont	 = CoerceIt to_ty (Stop to_ty)
			 where
			   to_ty = contResultType cont

contResultType :: SimplCont -> OutType
contResultType (Stop to_ty)	     = to_ty
contResultType (ArgOf _ to_ty _)     = to_ty
contResultType (ApplyTo _ _ _ cont)  = contResultType cont
contResultType (CoerceIt _ cont)     = contResultType cont
contResultType (InlinePlease cont)   = contResultType cont
contResultType (Select _ _ _ _ cont) = contResultType cont

countValArgs :: SimplCont -> Int
countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
countValArgs (ApplyTo _ val_arg   se cont) = 1 + countValArgs cont
countValArgs other			   = 0

countArgs :: SimplCont -> Int
countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
countArgs other			  = 0
290 291 292
\end{code}


293 294
%************************************************************************
%*									*
295
\subsection{Monad plumbing}
296 297 298 299 300 301 302
%*									*
%************************************************************************

For the simplifier monad, we want to {\em thread} a unique supply and a counter.
(Command-line switches move around through the explicitly-passed SimplEnv.)

\begin{code}
303 304 305 306 307 308 309 310
type SimplM result		-- We thread the unique supply because
  =  SimplEnv			-- constantly splitting it is rather expensive
  -> UniqSupply
  -> SimplCount 
  -> (result, UniqSupply, SimplCount)

data SimplEnv
  = SimplEnv {
311 312 313 314
	seChkr      :: SwitchChecker,
	seCC        :: CostCentreStack,	-- The enclosing CCS (when profiling)
	seBlackList :: Id -> Bool,	-- True =>  don't inline this Id
	seSubst     :: Subst		-- The current substitution
315
    }
316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331
	-- The range of the substitution is OutType and OutExpr resp
	-- 
	-- The substitution is idempotent
	-- It *must* be applied; things in its domain simply aren't
	-- bound in the result.
	--
	-- The substitution usually maps an Id to its clone,
	-- but if the orig defn is a let-binding, and
	-- the RHS of the let simplifies to an atom,
	-- we just add the binding to the substitution and elide the let.

	-- The in-scope part of Subst includes *all* in-scope TyVars and Ids
	-- The elements of the set may have better IdInfo than the
	-- occurrences of in-scope Ids, and (more important) they will
	-- have a correctly-substituted type.  So we use a lookup in this
	-- set to replace occurrences
332 333 334
\end{code}

\begin{code}
335 336
initSmpl :: SwitchChecker
	 -> UniqSupply		-- No init count; set to 0
337 338
	 -> VarSet		-- In scope (usually empty, but useful for nested calls)
	 -> (Id -> Bool)	-- Black-list function
339 340 341
	 -> SimplM a
	 -> (a, SimplCount)

342 343 344
initSmpl chkr us in_scope black_list m
  = case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of 
	(result, _, count) -> (result, count)
345 346 347 348 349 350


{-# INLINE thenSmpl #-}
{-# INLINE thenSmpl_ #-}
{-# INLINE returnSmpl #-}

351 352
returnSmpl :: a -> SimplM a
returnSmpl e env us sc = (e, us, sc)
353

354 355
thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
356

357 358 359
thenSmpl m k env us0 sc0
  = case (m env us0 sc0) of 
	(m_result, us1, sc1) -> k m_result env us1 sc1
360

361 362 363 364
thenSmpl_ m k env us0 sc0
  = case (m env us0 sc0) of 
	(_, us1, sc1) -> k env us1 sc1
\end{code}
365

366 367 368 369

\begin{code}
mapSmpl	    	:: (a -> SimplM b) -> [a] -> SimplM [b]
mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
370 371 372 373 374 375 376 377 378 379 380 381

mapSmpl f [] = returnSmpl []
mapSmpl f (x:xs)
  = f x		    `thenSmpl` \ x'  ->
    mapSmpl f xs    `thenSmpl` \ xs' ->
    returnSmpl (x':xs')

mapAndUnzipSmpl f [] = returnSmpl ([],[])
mapAndUnzipSmpl f (x:xs)
  = f x			    `thenSmpl` \ (r1,  r2)  ->
    mapAndUnzipSmpl f xs    `thenSmpl` \ (rs1, rs2) ->
    returnSmpl (r1:rs1, r2:rs2)
382 383 384 385 386

mapAccumLSmpl f acc []     = returnSmpl (acc, [])
mapAccumLSmpl f acc (x:xs) = f acc x	`thenSmpl` \ (acc', x') ->
			     mapAccumLSmpl f acc' xs	`thenSmpl` \ (acc'', xs') ->
			     returnSmpl (acc'', x':xs')
387
\end{code}
388 389


390 391 392 393 394 395 396 397 398 399 400 401 402 403
%************************************************************************
%*									*
\subsection{The unique supply}
%*									*
%************************************************************************

\begin{code}
getUniqueSmpl :: SimplM Unique
getUniqueSmpl env us sc = case splitUniqSupply us of
				(us1, us2) -> (uniqFromSupply us1, us2, sc)

getUniquesSmpl :: Int -> SimplM [Unique]
getUniquesSmpl n env us sc = case splitUniqSupply us of
				(us1, us2) -> (uniqsFromSupply n us1, us2, sc)
404 405 406 407 408
\end{code}


%************************************************************************
%*									*
409
\subsection{Counting up what we've done}
410 411 412
%*									*
%************************************************************************

413 414 415 416
\begin{code}
getSimplCount :: SimplM SimplCount
getSimplCount env us sc = (sc, us, sc)

417 418 419 420 421 422 423 424 425 426 427 428
tick :: Tick -> SimplM ()
tick t env us sc = sc' `seq` ((), us, sc')
		 where
		   sc' = doTick t sc

freeTick :: Tick -> SimplM ()
-- Record a tick, but don't add to the total tick count, which is
-- used to decide when nothing further has happened
freeTick t env us sc = sc' `seq` ((), us, sc')
		 where
		   sc' = doFreeTick t sc
\end{code}
429

430 431 432 433 434 435 436 437 438 439
\begin{code}
verboseSimplStats = opt_PprStyle_Debug		-- For now, anyway

-- Defined both with and without debugging
zeroSimplCount	   :: SimplCount
isZeroSimplCount   :: SimplCount -> Bool
pprSimplCount	   :: SimplCount -> SDoc
doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
\end{code}
440 441

\begin{code}
442 443 444 445 446
#ifndef DEBUG
----------------------------------------------------------
--			Debugging OFF
----------------------------------------------------------
type SimplCount = Int
447

448
zeroSimplCount = 0
449

450
isZeroSimplCount n = n==0
451

452 453
doTick     t n = n+1	-- Very basic when not debugging
doFreeTick t n = n	-- Don't count leaf visits
454

455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470
pprSimplCount n = ptext SLIT("Total ticks:") <+> int n

plusSimplCount n m = n+m

#else
----------------------------------------------------------
--			Debugging ON
----------------------------------------------------------

data SimplCount = SimplCount	{
			ticks   :: !Int,		-- Total ticks
			details :: !TickCounts,		-- How many of each type
			n_log	:: !Int,		-- N
			log1	:: [Tick],		-- Last N events; <= opt_HistorySize
			log2	:: [Tick]		-- Last opt_HistorySize events before that
		  }
471

472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505
type TickCounts = FiniteMap Tick Int

zeroSimplCount = SimplCount {ticks = 0, details = emptyFM,
			     n_log = 0, log1 = [], log2 = []}

isZeroSimplCount sc = ticks sc == 0

doFreeTick tick sc@SimplCount { details = dts } 
  = dts' `seqFM` sc { details = dts' }
  where
    dts' = dts `addTick` tick 

-- Gross hack to persuade GHC 3.03 to do this important seq
seqFM fm x | isEmptyFM fm = x
	   | otherwise    = x

doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
  | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
  | otherwise		  = sc1 { n_log = nl+1, log1 = tick : l1 }
  where
    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }

-- Don't use plusFM_C because that's lazy, and we want to 
-- be pretty strict here!
addTick :: TickCounts -> Tick -> TickCounts
addTick fm tick = case lookupFM fm tick of
			Nothing -> addToFM fm tick 1
			Just n  -> n1 `seq` addToFM fm tick n1
				where
				   n1 = n+1

plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
	       sc2@(SimplCount { ticks = tks2, details = dts2 })
  = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
506
  where
507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665
	-- A hackish way of getting recent log info
    log_base | null (log1 sc2) = sc1	-- Nothing at all in sc2
	     | null (log2 sc2) = sc2 { log2 = log1 sc1 }
	     | otherwise       = sc2


pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
  = vcat [ptext SLIT("Total ticks:    ") <+> int tks,
	  text "",
	  pprTickCounts (fmToList dts),
	  if verboseSimplStats then
		vcat [text "",
		      ptext SLIT("Log (most recent first)"),
		      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
	  else empty
    ]

pprTickCounts :: [(Tick,Int)] -> SDoc
pprTickCounts [] = empty
pprTickCounts ((tick1,n1):ticks)
  = vcat [int tot_n <+> text (tickString tick1),
	  pprTCDetails real_these,
	  pprTickCounts others
    ]
  where
    tick1_tag		= tickToTag tick1
    (these, others)	= span same_tick ticks
    real_these		= (tick1,n1):these
    same_tick (tick2,_) = tickToTag tick2 == tick1_tag
    tot_n		= sum [n | (_,n) <- real_these]

pprTCDetails ticks@((tick,_):_)
  | verboseSimplStats || isRuleFired tick
  = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
  | otherwise
  = empty
#endif
\end{code}

%************************************************************************
%*									*
\subsection{Ticks}
%*									*
%************************************************************************

\begin{code}
data Tick
  = PreInlineUnconditionally	Id
  | PostInlineUnconditionally	Id

  | UnfoldingDone    		Id
  | RuleFired			FAST_STRING	-- Rule name

  | LetFloatFromLet		Id	-- Thing floated out
  | EtaExpansion		Id	-- LHS binder
  | EtaReduction		Id	-- Binder on outer lambda
  | BetaReduction		Id	-- Lambda binder


  | CaseOfCase			Id	-- Bndr on *inner* case
  | KnownBranch			Id	-- Case binder
  | CaseMerge			Id	-- Binder on outer case
  | CaseElim			Id	-- Case binder
  | CaseIdentity		Id	-- Case binder
  | FillInCaseDefault		Id	-- Case binder

  | BottomFound		
  | SimplifierDone		-- Ticked at each iteration of the simplifier

isRuleFired (RuleFired _) = True
isRuleFired other	  = False

instance Outputable Tick where
  ppr tick = text (tickString tick) <+> pprTickCts tick

instance Eq Tick where
  a == b = case a `cmpTick` b of { EQ -> True; other -> False }

instance Ord Tick where
  compare = cmpTick

tickToTag :: Tick -> Int
tickToTag (PreInlineUnconditionally _)	= 0
tickToTag (PostInlineUnconditionally _)	= 1
tickToTag (UnfoldingDone _)		= 2
tickToTag (RuleFired _)			= 3
tickToTag (LetFloatFromLet _)		= 4
tickToTag (EtaExpansion _)		= 5
tickToTag (EtaReduction _)		= 6
tickToTag (BetaReduction _)		= 7
tickToTag (CaseOfCase _)		= 8
tickToTag (KnownBranch _)		= 9
tickToTag (CaseMerge _)			= 10
tickToTag (CaseElim _)			= 11
tickToTag (CaseIdentity _)		= 12
tickToTag (FillInCaseDefault _)		= 13
tickToTag BottomFound			= 14
tickToTag SimplifierDone		= 16

tickString :: Tick -> String
tickString (PreInlineUnconditionally _)	= "PreInlineUnconditionally"
tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
tickString (UnfoldingDone _)		= "UnfoldingDone"
tickString (RuleFired _)		= "RuleFired"
tickString (LetFloatFromLet _)		= "LetFloatFromLet"
tickString (EtaExpansion _)		= "EtaExpansion"
tickString (EtaReduction _)		= "EtaReduction"
tickString (BetaReduction _)		= "BetaReduction"
tickString (CaseOfCase _)		= "CaseOfCase"
tickString (KnownBranch _)		= "KnownBranch"
tickString (CaseMerge _)		= "CaseMerge"
tickString (CaseElim _)			= "CaseElim"
tickString (CaseIdentity _)		= "CaseIdentity"
tickString (FillInCaseDefault _)	= "FillInCaseDefault"
tickString BottomFound			= "BottomFound"
tickString SimplifierDone		= "SimplifierDone"

pprTickCts :: Tick -> SDoc
pprTickCts (PreInlineUnconditionally v)	= ppr v
pprTickCts (PostInlineUnconditionally v)= ppr v
pprTickCts (UnfoldingDone v)		= ppr v
pprTickCts (RuleFired v)		= ppr v
pprTickCts (LetFloatFromLet v)		= ppr v
pprTickCts (EtaExpansion v)		= ppr v
pprTickCts (EtaReduction v)		= ppr v
pprTickCts (BetaReduction v)		= ppr v
pprTickCts (CaseOfCase v)		= ppr v
pprTickCts (KnownBranch v)		= ppr v
pprTickCts (CaseMerge v)		= ppr v
pprTickCts (CaseElim v)			= ppr v
pprTickCts (CaseIdentity v)		= ppr v
pprTickCts (FillInCaseDefault v)	= ppr v
pprTickCts other			= empty

cmpTick :: Tick -> Tick -> Ordering
cmpTick a b = case (tickToTag a `compare` tickToTag b) of
		GT -> GT
		EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
		   | otherwise				-> EQ
		LT -> LT
	-- Always distinguish RuleFired, so that the stats
	-- can report them even in non-verbose mode

cmpEqTick :: Tick -> Tick -> Ordering
cmpEqTick (PreInlineUnconditionally a)	(PreInlineUnconditionally b)	= a `compare` b
cmpEqTick (PostInlineUnconditionally a)	(PostInlineUnconditionally b)	= a `compare` b
cmpEqTick (UnfoldingDone a)		(UnfoldingDone b)		= a `compare` b
cmpEqTick (RuleFired a)			(RuleFired b)			= a `compare` b
cmpEqTick (LetFloatFromLet a)		(LetFloatFromLet b)		= a `compare` b
cmpEqTick (EtaExpansion a)		(EtaExpansion b)		= a `compare` b
cmpEqTick (EtaReduction a)		(EtaReduction b)		= a `compare` b
cmpEqTick (BetaReduction a)		(BetaReduction b)		= a `compare` b
cmpEqTick (CaseOfCase a)		(CaseOfCase b)			= a `compare` b
cmpEqTick (KnownBranch a)		(KnownBranch b)			= a `compare` b
cmpEqTick (CaseMerge a)			(CaseMerge b)			= a `compare` b
cmpEqTick (CaseElim a)			(CaseElim b)			= a `compare` b
cmpEqTick (CaseIdentity a)		(CaseIdentity b)		= a `compare` b
cmpEqTick (FillInCaseDefault a)		(FillInCaseDefault b)		= a `compare` b
cmpEqTick other1			other2				= EQ
666 667 668 669 670 671 672 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 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746
\end{code}


%************************************************************************
%*									*
\subsubsection{Command-line switches}
%*									*
%************************************************************************

\begin{code}
getSwitchChecker :: SimplM SwitchChecker
getSwitchChecker env us sc = (seChkr env, us, sc)

getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
getSimplIntSwitch chkr switch
  = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
\end{code}


@switchOffInlining@ is used to prepare the environment for simplifying
the RHS of an Id that's marked with an INLINE pragma.  It is going to
be inlined wherever they are used, and then all the inlining will take
effect.  Meanwhile, there isn't much point in doing anything to the
as-yet-un-INLINEd rhs.  Furthremore, it's very important to switch off
inlining!  because
	(a) not doing so will inline a worker straight back into its wrapper!

and 	(b) Consider the following example 
	     	let f = \pq -> BIG
	     	in
	     	let g = \y -> f y y
		    {-# INLINE g #-}
	     	in ...g...g...g...g...g...

	Now, if that's the ONLY occurrence of f, it will be inlined inside g,
	and thence copied multiple times when g is inlined.

	Andy disagrees! Example:
		all xs = foldr (&&) True xs
		any p = all . map p  {-# INLINE any #-}
	
	Problem: any won't get deforested, and so if it's exported and
	the importer doesn't use the inlining, (eg passes it as an arg)
	then we won't get deforestation at all.
	We havn't solved this problem yet!

We prepare the envt by simply modifying the in_scope_env, which has all the
unfolding info. At one point we did it by modifying the chkr so that
it said "EssentialUnfoldingsOnly", but that prevented legitmate, and
important, simplifications happening in the body of the RHS.

6/98 update: 

We *don't* prevent inlining from happening for identifiers
that are marked as IMustBeINLINEd. An example of where
doing this is crucial is:
  
   class Bar a => Foo a where
     ...g....
   {-# INLINE f #-}
   f :: Foo a => a -> b
   f x = ....Foo_sc1...
   
If `f' needs to peer inside Foo's superclass, Bar, it refers
to the appropriate super class selector, which is marked as
must-inlineable. We don't generate any code for a superclass
selector, so failing to inline it in the RHS of `f' will
leave a reference to a non-existent id, with bad consequences.

ALSO NOTE that we do all this by modifing the inline-pragma,
not by zapping the unfolding.  The latter may still be useful for
knowing when something is evaluated.

June 98 update: I've gone back to dealing with this by adding
the EssentialUnfoldingsOnly switch.  That doesn't stop essential
unfoldings, nor inlineUnconditionally stuff; and the thing's going
to be inlined at every call site anyway.  Running over the whole
environment seems like wild overkill.

\begin{code}
switchOffInlining :: SimplM a -> SimplM a
747
switchOffInlining m env us sc
748 749
  = m (env { seBlackList = \v -> not (isCompulsoryUnfolding (getIdUnfolding v)) &&
				 ((v `isInScope` subst) || not (isLocallyDefined v))
750 751 752 753 754 755 756 757 758 759 760 761 762
	   }) us sc
	-- Black list anything that is in scope or imported.
	-- The in-scope thing arranges *not* to black list inlinings that are
	-- completely inside the switch-off-inlining block.
	-- This allows simplification to proceed un-hindered inside the block.
	--
	-- At one time I had an exception for constant Ids (constructors, primops)
	--		      && (old_black_list v || not (isConstantId v ))
	-- because (a) some don't have bindings, so we never want not to inline them
	--	   (b) their defns are very seldom big, so there's no size penalty
	--	       to inline them
	-- But that failed because if we inline (say) [] in build's rhs, then
	-- the exported thing doesn't match rules
763 764 765 766 767 768
	--
	-- But we must inline primops (which have compulsory unfoldings) in the
	-- last phase of simplification, because they don't have bindings.
	-- The simplifier now *never* inlines blacklisted things (even if they
	-- have compulsory unfoldings) so we must not black-list compulsory
	-- unfoldings inside INLINE prags.
769 770 771
  where
    subst	   = seSubst env
    old_black_list = seBlackList env
772
\end{code}
sof's avatar
sof committed
773 774


775 776 777 778 779
%************************************************************************
%*									*
\subsubsection{The ``enclosing cost-centre''}
%*									*
%************************************************************************
sof's avatar
sof committed
780

781 782 783
\begin{code}
getEnclosingCC :: SimplM CostCentreStack
getEnclosingCC env us sc = (seCC env, us, sc)
sof's avatar
sof committed
784

785 786 787
setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
\end{code}
sof's avatar
sof committed
788

789

790 791 792 793 794
%************************************************************************
%*									*
\subsubsection{The @SimplEnv@ type}
%*									*
%************************************************************************
sof's avatar
sof committed
795 796


797
\begin{code}
798
emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv
799

800
emptySimplEnv sw_chkr in_scope black_list
801
  = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
802 803
	       seBlackList = black_list,
	       seSubst = mkSubst in_scope emptySubstEnv }
804
	-- The top level "enclosing CC" is "SUBSUMED".
805

806 807 808 809 810 811 812 813
getEnv :: SimplM SimplEnv
getEnv env us sc = (env, us, sc)

setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m 
		    	    (SimplEnv {seSubst = old_subst}) us sc 
  = m (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) us sc

814 815
getSubst :: SimplM Subst
getSubst env us sc = (seSubst env, us, sc)
816

817 818
getBlackList :: SimplM (Id -> Bool)
getBlackList env us sc = (seBlackList env, us, sc)
819

820 821
setSubst :: Subst -> SimplM a -> SimplM a
setSubst subst m env us sc = m (env {seSubst = subst}) us sc
822

823 824
getSubstEnv :: SimplM SubstEnv
getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
825 826

extendInScope :: CoreBndr -> SimplM a -> SimplM a
827 828
extendInScope v m env@(SimplEnv {seSubst = subst}) us sc
  = m (env {seSubst = Subst.extendInScope subst v}) us sc
829 830

extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
831 832 833 834 835 836 837 838 839
extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc
  = m (env {seSubst = Subst.extendInScopes subst vs}) us sc

getInScope :: SimplM InScopeSet
getInScope env us sc = (substInScope (seSubst env), us, sc)

setInScope :: InScopeSet -> SimplM a -> SimplM a
setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
  = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
840

841 842 843
modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
modifyInScope v v' m env@(SimplEnv {seSubst = subst}) us sc 
  = m (env {seSubst = Subst.modifyInScope subst v v'}) us sc
844

845 846 847
extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
  = m (env { seSubst = Subst.extendSubst subst var res  }) us sc
848

849 850 851
extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
  = m (env { seSubst = Subst.extendSubstList subst vars ress  }) us sc
852

853 854 855
setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
  = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
856 857

zapSubstEnv :: SimplM a -> SimplM a
858 859
zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
  = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
860

861 862 863
getSimplBinderStuff :: SimplM (Subst, UniqSupply)
getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
  = ((subst, us), us, sc)
864

865 866 867
setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
setSimplBinderStuff (subst, us) m env _ sc
  = m (env {seSubst = subst}) us sc
868 869 870 871 872 873
\end{code}


\begin{code}
newId :: Type -> (Id -> SimplM a) -> SimplM a
	-- Extends the in-scope-env too
874
newId ty m env@(SimplEnv {seSubst = subst}) us sc
875
  =  case splitUniqSupply us of
876
	(us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
877
		   where
878
		      v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
879 880

newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
881
newIds tys m env@(SimplEnv {seSubst = subst}) us sc
882
  =  case splitUniqSupply us of
883
	(us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
884
		   where
885 886
		      vs = zipWithEqual "newIds" (mkSysLocal SLIT("s")) 
					(uniqsFromSupply (length tys) us1) tys
887

888
\end{code}