CoreUtils.lhs 37.4 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 4 5 6 7
%
\section[CoreUtils]{Utility functions on @Core@ syntax}

\begin{code}
module CoreUtils (
8
	-- Construction
9
	mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
10
	bindNonRec, needsCaseBinding,
11
	mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
12

13
	-- Taking expressions apart
14
	findDefault, findAlt, hasDefault,
15

16
	-- Properties of expressions
17
	exprType, coreAltsType, 
18
	exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, 
19
	exprIsValue,exprOkForSpeculation, exprIsBig, 
20
	exprIsConApp_maybe, exprIsAtom,
21 22
	idAppIsBottom, idAppIsCheap,

23 24 25 26

	-- Arity and eta expansion
	manifestArity, exprArity, 
	exprEtaExpandArity, etaExpand, 
27

28 29 30 31
	-- Size
	coreBindsSize,

	-- Hashing
32 33
	hashExpr,

34
	-- Equality
35
	cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
36
    ) where
37

38
#include "HsVersions.h"
39 40


41
import GLAEXTS		-- For `xori` 
42

43
import CoreSyn
44
import PprCore		( pprCoreExpr )
45
import Var		( Var, isId, isTyVar )
46
import VarEnv
47
import Name		( hashName )
48
import Literal		( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit )
49
import DataCon		( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon )
50
import PrimOp		( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
51
import Id		( Id, idType, globalIdDetails, idNewStrictness, 
52
			  mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
53
			  isDataConWorkId_maybe, mkSysLocal, isDataConWorkId, isBottomingId
54
			)
55
import IdInfo		( GlobalIdDetails(..),
56
			  megaSeqIdInfo )
57
import NewDemand	( appIsBottom )
58
import Type		( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
59
			  applyTys, isUnLiftedType, seqType, mkTyVarTy,
60
			  splitForAllTy_maybe, isForAllTy, splitNewType_maybe, 
61 62
			  splitTyConApp_maybe, eqType, funResultTy, applyTy,
			  funResultTy, applyTy
63
			)
64
import TyCon		( tyConArity )
65
import TysWiredIn	( boolTy, trueDataCon, falseDataCon )
66
import CostCentre	( CostCentre )
67 68
import BasicTypes	( Arity )
import Unique		( Unique )
69
import Outputable
70
import TysPrim		( alphaTy )	-- Debugging only
sof's avatar
sof committed
71
import Util             ( equalLength, lengthAtLeast )
72
import TysPrim		( statePrimTyCon )
73
\end{code}
74

75

76 77 78 79 80 81 82
%************************************************************************
%*									*
\subsection{Find the type of a Core atom/expression}
%*									*
%************************************************************************

\begin{code}
83 84 85 86 87 88 89 90
exprType :: CoreExpr -> Type

exprType (Var var)		= idType var
exprType (Lit lit)		= literalType lit
exprType (Let _ body)	   	= exprType body
exprType (Case _ _ alts)        = coreAltsType alts
exprType (Note (Coerce ty _) e) = ty  -- **! should take usage from e
exprType (Note other_note e)    = exprType e
91
exprType (Lam binder expr)      = mkPiType binder (exprType expr)
92
exprType e@(App _ _)
93
  = case collectArgs e of
94
	(fun, args) -> applyTypeToArgs e (exprType fun) args
95

96
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
97 98

coreAltsType :: [CoreAlt] -> Type
99
coreAltsType ((_,_,rhs) : _) = exprType rhs
100 101
\end{code}

102 103 104 105 106 107
@mkPiType@ makes a (->) type or a forall type, depending on whether
it is given a type variable or a term variable.  We cleverly use the
lbvarinfo field to figure out the right annotation for the arrove in
case of a term variable.

\begin{code}
108 109 110 111 112 113
mkPiType  :: Var   -> Type -> Type	-- The more polymorphic version
mkPiTypes :: [Var] -> Type -> Type	--    doesn't work...

mkPiTypes vs ty = foldr mkPiType ty vs

mkPiType v ty
114
   | isId v    = mkFunTy (idType v) ty
115
   | otherwise = mkForAllTy v ty
116 117
\end{code}

118
\begin{code}
119 120 121 122
applyTypeToArg :: Type -> CoreExpr -> Type
applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
applyTypeToArg fun_ty other_arg     = funResultTy fun_ty

123
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
124 125 126
-- A more efficient version of applyTypeToArg 
-- when we have several args
-- The first argument is just for debugging
127
applyTypeToArgs e op_ty [] = op_ty
128

129
applyTypeToArgs e op_ty (Type ty : args)
130
  =	-- Accumulate type arguments so we can instantiate all at once
131
    go [ty] args
132
  where
133 134 135 136
    go rev_tys (Type ty : args) = go (ty:rev_tys) args
    go rev_tys rest_args        = applyTypeToArgs e op_ty' rest_args
			 	where
				  op_ty' = applyTys op_ty (reverse rev_tys)
137

138
applyTypeToArgs e op_ty (other_arg : args)
139
  = case (splitFunTy_maybe op_ty) of
140
	Just (_, res_ty) -> applyTypeToArgs e res_ty args
141
	Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
142 143
\end{code}

144 145 146 147


%************************************************************************
%*									*
148
\subsection{Attaching notes}
149 150 151 152 153 154 155
%*									*
%************************************************************************

mkNote removes redundant coercions, and SCCs where possible

\begin{code}
mkNote :: Note -> CoreExpr -> CoreExpr
156
mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
157 158 159 160 161 162 163 164 165 166 167 168 169 170 171
mkNote (SCC cc)	expr		   = mkSCC cc expr
mkNote InlineMe expr		   = mkInlineMe expr
mkNote note     expr		   = Note note expr

-- Slide InlineCall in around the function
--	No longer necessary I think (SLPJ Apr 99)
-- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
-- mkNote InlineCall (Var v)   = Note InlineCall (Var v)
-- mkNote InlineCall expr      = expr
\end{code}

Drop trivial InlineMe's.  This is somewhat important, because if we have an unfolding
that looks like	(Note InlineMe (Var v)), the InlineMe doesn't go away because it may
not be *applied* to anything.

172 173 174 175 176 177 178
We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
bindings like
	fw = ...
	f  = inline_me (coerce t fw)
As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
We want the split, so that the coerces can cancel at the call site.  

179 180 181 182 183 184 185 186 187 188
However, we can get left with tiresome type applications.  Notably, consider
	f = /\ a -> let t = e in (t, w)
Then lifting the let out of the big lambda gives
	t' = /\a -> e
	f = /\ a -> let t = inline_me (t' a) in (t, w)
The inline_me is to stop the simplifier inlining t' right back
into t's RHS.  In the next phase we'll substitute for t (since
its rhs is trivial) and *then* we could get rid of the inline_me.
But it hardly seems worth it, so I don't bother.

189
\begin{code}
190 191
mkInlineMe (Var v) = Var v
mkInlineMe e	   = Note InlineMe e
192 193 194 195 196
\end{code}



\begin{code}
197 198
mkCoerce :: Type -> CoreExpr -> CoreExpr
mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
199

200 201
mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
202
  = ASSERT( from_ty `eqType` to_ty2 )
203
    mkCoerce2 to_ty from_ty2 expr
204

205
mkCoerce2 to_ty from_ty expr
206 207 208
  | to_ty `eqType` from_ty = expr
  | otherwise	  	   = ASSERT( from_ty `eqType` exprType expr )
			     Note (Coerce to_ty from_ty) expr
209 210 211 212 213
\end{code}

\begin{code}
mkSCC :: CostCentre -> Expr b -> Expr b
	-- Note: Nested SCC's *are* preserved for the benefit of
214 215 216 217 218 219
	--       cost centre stack profiling
mkSCC cc (Lit lit)  	    = Lit lit
mkSCC cc (Lam x e)  	    = Lam x (mkSCC cc e)  -- Move _scc_ inside lambda
mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
mkSCC cc (Note n e) 	    = Note n (mkSCC cc e) -- Move _scc_ inside notes
mkSCC cc expr	    	    = Note (SCC cc) expr
220 221 222
\end{code}


223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240
%************************************************************************
%*									*
\subsection{Other expression construction}
%*									*
%************************************************************************

\begin{code}
bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
-- (bindNonRec x r b) produces either
--	let x = r in b
-- or
--	case r of x { _DEFAULT_ -> b }
--
-- depending on whether x is unlifted or not
-- It's used by the desugarer to avoid building bindings
-- that give Core Lint a heart attack.  Actually the simplifier
-- deals with them perfectly well.
bindNonRec bndr rhs body 
241 242 243 244 245 246 247
  | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
  | otherwise			       = Let (NonRec bndr rhs) body

needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
	-- Make a case expression instead of a let
	-- These can arise either from the desugarer,
	-- or from beta reductions: (\x.e) (x +# y)
248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265
\end{code}

\begin{code}
mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
	-- This guy constructs the value that the scrutinee must have
	-- when you are in one particular branch of a case
mkAltExpr (DataAlt con) args inst_tys
  = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
mkAltExpr (LitAlt lit) [] []
  = Lit lit

mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse guard then_expr else_expr
  = Case guard (mkWildId boolTy) 
	 [ (DataAlt trueDataCon,  [], then_expr),
	   (DataAlt falseDataCon, [], else_expr) ]
\end{code}

266 267 268 269 270 271 272

%************************************************************************
%*									*
\subsection{Taking expressions apart}
%*									*
%************************************************************************

273 274
The default alternative must be first, if it exists at all.
This makes it easy to find, though it makes matching marginally harder.
275 276

\begin{code}
277 278 279 280
hasDefault :: [CoreAlt] -> Bool
hasDefault ((DEFAULT,_,_) : alts) = True
hasDefault _			  = False

281
findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
282 283
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
findDefault alts			= 		      (alts, Nothing)
284 285 286

findAlt :: AltCon -> [CoreAlt] -> CoreAlt
findAlt con alts
287 288 289 290
  = case alts of
	(deflt@(DEFAULT,_,_):alts) -> go alts deflt
	other			   -> go alts panic_deflt

291
  where
292
    panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
293

294 295 296 297
    go []	 	       deflt 		   = deflt
    go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
				     | otherwise   = ASSERT( not (con1 == DEFAULT) )
						     go alts deflt
298 299 300
\end{code}


301 302
%************************************************************************
%*									*
303
\subsection{Figuring out things about expressions}
304 305 306
%*									*
%************************************************************************

307 308 309 310 311
@exprIsTrivial@ is true of expressions we are unconditionally happy to
		duplicate; simple variables and constants, and type
		applications.  Note that primop Ids aren't considered
		trivial unless 

312
@exprIsBottom@	is true of expressions that are guaranteed to diverge
313

314

315 316 317 318 319 320 321 322 323 324 325
There used to be a gruesome test for (hasNoBinding v) in the
Var case:
	exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
The idea here is that a constructor worker, like $wJust, is
really short for (\x -> $wJust x), becuase $wJust has no binding.
So it should be treated like a lambda.  Ditto unsaturated primops.
But now constructor workers are not "have-no-binding" Ids.  And
completely un-applied primops and foreign-call Ids are sufficiently
rare that I plan to allow them to be duplicated and put up with
saturating them.

326
\begin{code}
327 328
exprIsTrivial (Var v)	   = True	-- See notes above
exprIsTrivial (Type _)	   = True
329
exprIsTrivial (Lit lit)    = litIsTrivial lit
330 331 332 333
exprIsTrivial (App e arg)  = not (isRuntimeArg arg) && exprIsTrivial e
exprIsTrivial (Note _ e)   = exprIsTrivial e
exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
exprIsTrivial other	   = False
334 335 336 337 338 339 340

exprIsAtom :: CoreExpr -> Bool
-- Used to decide whether to let-binding an STG argument
-- when compiling to ILX => type applications are not allowed
exprIsAtom (Var v)    = True	-- primOpIsDupable?
exprIsAtom (Lit lit)  = True
exprIsAtom (Type ty)  = True
341
exprIsAtom (Note (SCC _) e) = False
342 343
exprIsAtom (Note _ e) = exprIsAtom e
exprIsAtom other      = False
344 345 346
\end{code}


347
@exprIsDupable@	is true of expressions that can be duplicated at a modest
348
		cost in code size.  This will only happen in different case
349
		branches, so there's no issue about duplicating work.
350 351 352 353

		That is, exprIsDupable returns True of (f x) even if
		f is very very expensive to call.

354 355 356 357
		Its only purpose is to avoid fruitless let-binding
		and then inlining of case join points


358
\begin{code}
359 360 361 362 363
exprIsDupable (Type _)	     	= True
exprIsDupable (Var v)	     	= True
exprIsDupable (Lit lit)      	= litIsDupable lit
exprIsDupable (Note InlineMe e) = True
exprIsDupable (Note _ e)        = exprIsDupable e
364 365 366 367 368 369 370 371
exprIsDupable expr	     
  = go expr 0
  where
    go (Var v)   n_args = True
    go (App f a) n_args =  n_args < dupAppSize
			&& exprIsDupable a
			&& go f (n_args+1)
    go other n_args 	= False
372 373 374 375

dupAppSize :: Int
dupAppSize = 4		-- Size of application we are prepared to duplicate
\end{code}
376

377 378 379 380
@exprIsCheap@ looks at a Core expression and returns \tr{True} if
it is obviously in weak head normal form, or is cheap to get to WHNF.
[Note that that's not the same as exprIsDupable; an expression might be
big, and hence not dupable, but still cheap.]
381 382 383 384 385 386 387

By ``cheap'' we mean a computation we're willing to:
	push inside a lambda, or
	inline at more than one place
That might mean it gets evaluated more than once, instead of being
shared.  The main examples of things which aren't WHNF but are
``cheap'' are:
388 389 390

  * 	case e of
	  pi -> ei
391
	(where e, and all the ei are cheap)
392

393 394
  *	let x = e in b
	(where e and b are cheap)
395 396

  *	op x1 ... xn
397
	(where op is a cheap primitive operator)
398

399
  *	error "foo"
400
	(because we are happy to substitute it inside a lambda)
401

402 403 404
Notice that a variable is considered 'cheap': we can push it inside a lambda,
because sharing will make sure it is only evaluated once.

405 406
\begin{code}
exprIsCheap :: CoreExpr -> Bool
407 408 409
exprIsCheap (Lit lit) 		  = True
exprIsCheap (Type _)        	  = True
exprIsCheap (Var _)         	  = True
410
exprIsCheap (Note InlineMe e)  	  = True
411
exprIsCheap (Note _ e)      	  = exprIsCheap e
412
exprIsCheap (Lam x e)       	  = isRuntimeVar x || exprIsCheap e
413 414
exprIsCheap (Case e _ alts)       = exprIsCheap e && 
				    and [exprIsCheap rhs | (_,_,rhs) <- alts]
415
	-- Experimentally, treat (case x of ...) as cheap
416
	-- (and case __coerce x etc.)
417 418
	-- This improves arities of overloaded functions where
	-- there is only dictionary selection (no construction) involved
419 420 421 422 423 424
exprIsCheap (Let (NonRec x _) e)  
      | isUnLiftedType (idType x) = exprIsCheap e
      | otherwise		  = False
	-- strict lets always have cheap right hand sides, and
	-- do no allocation.

425 426 427 428 429 430 431 432 433
exprIsCheap other_expr 
  = go other_expr 0 True
  where
    go (Var f) n_args args_cheap 
	= (idAppIsCheap f n_args && args_cheap)
			-- A constructor, cheap primop, or partial application

	  || idAppIsBottom f n_args 
			-- Application of a function which
434 435
			-- always gives bottom; we treat this as cheap
			-- because it certainly doesn't need to be shared!
436 437
	
    go (App f a) n_args args_cheap 
438
	| not (isRuntimeArg a) = go f n_args 	  args_cheap
439
	| otherwise            = go f (n_args + 1) (exprIsCheap a && args_cheap)
440 441 442 443 444 445

    go other   n_args args_cheap = False

idAppIsCheap :: Id -> Int -> Bool
idAppIsCheap id n_val_args 
  | n_val_args == 0 = True	-- Just a type application of
446 447
				-- a variable (f t1 t2 t3)
				-- counts as WHNF
448
  | otherwise = case globalIdDetails id of
449 450
		  DataConWorkId _ -> True			
		  RecordSelId _   -> True	-- I'm experimenting with making record selection
451
		  ClassOpId _     -> True	-- look cheap, so we will substitute it inside a
452
						-- lambda.  Particularly for dictionary field selection
453 454 455 456 457 458

		  PrimOpId op   -> primOpIsCheap op	-- In principle we should worry about primops
		 					-- that return a type variable, since the result
							-- might be applied to something, but I'm not going
							-- to bother to check the number of args
		  other	      -> n_val_args < idArity id
459 460
\end{code}

461 462 463 464 465 466 467 468 469 470 471
exprOkForSpeculation returns True of an expression that it is

	* safe to evaluate even if normal order eval might not 
	  evaluate the expression at all, or

	* safe *not* to evaluate even if normal order would do so

It returns True iff

	the expression guarantees to terminate, 
	soon, 
472 473
	without raising an exception,
	without causing a side effect (e.g. writing a mutable variable)
474 475

E.G.
476 477 478 479 480 481 482
	let x = case y# +# 1# of { r# -> I# r# }
	in E
==>
	case y# +# 1# of { r# -> 
	let x = I# r#
	in E 
	}
483

484 485 486 487 488
We can only do this if the (y+1) is ok for speculation: it has no
side effects, and can't diverge or raise an exception.

\begin{code}
exprOkForSpeculation :: CoreExpr -> Bool
489
exprOkForSpeculation (Lit _)    = True
490
exprOkForSpeculation (Type _)   = True
491 492 493
exprOkForSpeculation (Var v)    = isUnLiftedType (idType v)
exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
exprOkForSpeculation other_expr
494 495 496 497
  = case collectArgs other_expr of
	(Var f, args) -> spec_ok (globalIdDetails f) args
	other	      -> False
 
498
  where
499
    spec_ok (DataConWorkId _) args
500 501 502 503 504 505 506 507 508 509 510 511 512 513
      = True	-- The strictness of the constructor has already
		-- been expressed by its "wrapper", so we don't need
		-- to take the arguments into account

    spec_ok (PrimOpId op) args
      | isDivOp op,		-- Special case for dividing operations that fail
	[arg1, Lit lit] <- args	-- only if the divisor is zero
      = not (isZeroLit lit) && exprOkForSpeculation arg1
		-- Often there is a literal divisor, and this 
		-- can get rid of a thunk in an inner looop

      | otherwise
      = primOpOkForSpeculation op && 
	all exprOkForSpeculation args
514 515 516
				-- A bit conservative: we don't really need
				-- to care about lazy arguments, but this is easy

517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533
    spec_ok other args = False

isDivOp :: PrimOp -> Bool
-- True of dyadic operators that can fail 
-- only if the second arg is zero
-- This function probably belongs in PrimOp, or even in 
-- an automagically generated file.. but it's such a 
-- special case I thought I'd leave it here for now.
isDivOp IntQuotOp	 = True
isDivOp IntRemOp	 = True
isDivOp WordQuotOp	 = True
isDivOp WordRemOp	 = True
isDivOp IntegerQuotRemOp = True
isDivOp IntegerDivModOp  = True
isDivOp FloatDivOp       = True
isDivOp DoubleDivOp      = True
isDivOp other		 = False
534 535
\end{code}

536

537
\begin{code}
538
exprIsBottom :: CoreExpr -> Bool	-- True => definitely bottom
539 540 541 542 543 544 545 546
exprIsBottom e = go 0 e
	       where
		-- n is the number of args
		 go n (Note _ e)   = go n e
		 go n (Let _ e)    = go n e
		 go n (Case e _ _) = go 0 e	-- Just check the scrut
		 go n (App e _)    = go (n+1) e
		 go n (Var v)      = idAppIsBottom v n
547
		 go n (Lit _)      = False
548
		 go n (Lam _ _)	   = False
549 550

idAppIsBottom :: Id -> Int -> Bool
551
idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
552 553
\end{code}

554
@exprIsValue@ returns true for expressions that are certainly *already* 
555 556 557
evaluated to *head* normal form.  This is used to decide whether it's ok 
to change

558 559 560 561
	case x of _ -> e   ===>   e

and to decide whether it's safe to discard a `seq`

562 563 564
So, it does *not* treat variables as evaluated, unless they say they are.

But it *does* treat partial applications and constructor applications
565 566
as values, even if their arguments are non-trivial, provided the argument
type is lifted; 
567 568 569 570
	e.g.  (:) (f x) (map f xs)	is a value
	      map (...redex...)		is a value
Because `seq` on such things completes immediately

571
For unlifted argument types, we have to be careful:
572
		C (f x :: Int#)
573 574 575
Suppose (f x) diverges; then C (f x) is not a value.  True, but
this form is illegal (see the invariants in CoreSyn).  Args of unboxed
type must be ok-for-speculation (or trivial).
576 577 578

\begin{code}
exprIsValue :: CoreExpr -> Bool		-- True => Value-lambda, constructor, PAP
579
exprIsValue (Var v) 	-- NB: There are no value args at this point
580
  =  isDataConWorkId v 	-- Catches nullary constructors, 
581 582 583 584
			--	so that [] and () are values, for example
  || idArity v > 0 	-- Catches (e.g.) primops that don't have unfoldings
  || isEvaldUnfolding (idUnfolding v)
	-- Check the thing's unfolding; it might be bound to a value
585 586
	-- A worry: what if an Id's unfolding is just itself: 
	-- then we could get an infinite loop...
587 588 589 590 591 592 593 594 595 596 597 598

exprIsValue (Lit l)	     = True
exprIsValue (Type ty)	     = True	-- Types are honorary Values; 
					-- we don't mind copying them
exprIsValue (Lam b e)  	     = isRuntimeVar b || exprIsValue e
exprIsValue (Note _ e) 	     = exprIsValue e
exprIsValue (App e (Type _)) = exprIsValue e
exprIsValue (App e a)        = app_is_value e [a]
exprIsValue other	     = False

-- There is at least one value argument
app_is_value (Var fun) args
599
  |  isDataConWorkId fun 			-- Constructor apps are values
600 601 602 603 604 605 606 607 608 609 610 611 612
  || idArity fun > valArgCount args	-- Under-applied function
  = check_args (idType fun) args
app_is_value (App f a) as = app_is_value f (a:as)
app_is_value other     as = False

	-- 'check_args' checks that unlifted-type args
	-- are in fact guaranteed non-divergent
check_args fun_ty []	          = True
check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
				      Just (_, ty) -> check_args ty args
check_args fun_ty (arg : args)
  | isUnLiftedType arg_ty = exprOkForSpeculation arg
  | otherwise		  = check_args res_ty args
613
  where
614
    (arg_ty, res_ty) = splitFunTy fun_ty
615 616
\end{code}

617 618
\begin{code}
exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
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
exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
  = 	-- Maybe this is over the top, but here we try to turn
	-- 	coerce (S,T) ( x, y )
	-- effectively into 
	--	( coerce S x, coerce T y )
	-- This happens in anger in PrelArrExts which has a coerce
	--	case coerce memcpy a b of
	--	  (# r, s #) -> ...
	-- where the memcpy is in the IO monad, but the call is in
	-- the (ST s) monad
    case exprIsConApp_maybe expr of {
	Nothing 	  -> Nothing ;
	Just (dc, args)   -> 
  
    case splitTyConApp_maybe to_ty of {
	Nothing -> Nothing ;
	Just (tc, tc_arg_tys) | tc /= dataConTyCon dc   -> Nothing
			      | isExistentialDataCon dc -> Nothing
			      | otherwise	        ->
		-- Type constructor must match
		-- We knock out existentials to keep matters simple(r)
    let
	arity   	 = tyConArity tc
	val_args	 = drop arity args
	to_arg_tys 	 = dataConArgTys dc tc_arg_tys
644
	mk_coerce ty arg = mkCoerce ty arg
645 646 647
	new_val_args	 = zipWith mk_coerce to_arg_tys val_args
    in
    ASSERT( all isTypeArg (take arity args) )
sof's avatar
sof committed
648
    ASSERT( equalLength val_args to_arg_tys )
649 650 651 652 653
    Just (dc, map Type tc_arg_tys ++ new_val_args)
    }}

exprIsConApp_maybe (Note _ expr)
  = exprIsConApp_maybe expr
654 655 656 657
    -- We ignore InlineMe notes in case we have
    --	x = __inline_me__ (a,b)
    -- All part of making sure that INLINE pragmas never hurt
    -- Marcin tripped on this one when making dictionaries more inlinable
658 659 660 661 662 663
    --
    -- In fact, we ignore all notes.  For example,
    --  	case _scc_ "foo" (C a b) of
    --			C a b -> e
    -- should be optimised away, but it will be only if we look
    -- through the SCC note.
664 665

exprIsConApp_maybe expr = analyse (collectArgs expr)
666 667
  where
    analyse (Var fun, args)
668
	| Just con <- isDataConWorkId_maybe fun,
sof's avatar
sof committed
669
	  args `lengthAtLeast` dataConRepArity con
670 671
		-- Might be > because the arity excludes type args
	= Just (con,args)
672

673 674
	-- Look through unfoldings, but only cheap ones, because
	-- we are effectively duplicating the unfolding
675
    analyse (Var fun, [])
676 677 678
	| let unf = idUnfolding fun,
	  isCheapUnfolding unf
	= exprIsConApp_maybe (unfoldingTemplate unf)
679 680

    analyse other = Nothing
681 682
\end{code}

683

684

685 686 687 688 689 690
%************************************************************************
%*									*
\subsection{Eta reduction and expansion}
%*									*
%************************************************************************

691
\begin{code}
692
exprEtaExpandArity :: CoreExpr -> Arity
693 694
-- The Int is number of value args the thing can be 
-- 	applied to without doing much work
695
--
696 697 698 699 700 701 702
-- This is used when eta expanding
--	e  ==>  \xy -> e x y
--
-- It returns 1 (or more) to:
--	case x of p -> \s -> ...
-- because for I/O ish things we really want to get that \s to the top.
-- We are prepared to evaluate x each time round the loop in order to get that
703 704 705

-- It's all a bit more subtle than it looks.  Consider one-shot lambdas
-- 		let x = expensive in \y z -> E
706
-- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725
-- Hence the ArityType returned by arityType

-- NB: this is particularly important/useful for IO state 
-- transformers, where we often get
-- 	let x = E in \ s -> ...
-- and the \s is a real-world state token abstraction.  Such 
-- abstractions are almost invariably 1-shot, so we want to
-- pull the \s out, past the let x=E.  
-- The hack is in Id.isOneShotLambda
--
-- Consider also 
--	f = \x -> error "foo"
-- Here, arity 1 is fine.  But if it is
--	f = \x -> case e of 
--			True  -> error "foo"
--			False -> \y -> x+y
-- then we want to get arity 2.
-- Hence the ABot/ATop in ArityType

726

727
exprEtaExpandArity e = arityDepth (arityType e)
728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743

-- A limited sort of function type
data ArityType = AFun Bool ArityType	-- True <=> one-shot
	       | ATop			-- Know nothing
	       | ABot			-- Diverges

arityDepth :: ArityType -> Arity
arityDepth (AFun _ ty) = 1 + arityDepth ty
arityDepth ty	       = 0

andArityType ABot	    at2		  = at2
andArityType ATop	    at2		  = ATop
andArityType (AFun t1 at1)  (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
andArityType at1	    at2		  = andArityType at2 at1

arityType :: CoreExpr -> ArityType
744 745 746 747
	-- (go1 e) = [b1,..,bn]
	-- means expression can be rewritten \x_b1 -> ... \x_bn -> body
	-- where bi is True <=> the lambda is one-shot

748 749 750 751
arityType (Note n e) = arityType e
--	Not needed any more: etaExpand is cleverer
--  | ok_note n = arityType e
--  | otherwise = ATop
752 753 754 755 756 757 758 759 760 761 762

arityType (Var v) 
  = mk (idArity v)
  where
    mk :: Arity -> ArityType
    mk 0 | isBottomingId v  = ABot
         | otherwise	    = ATop
    mk n 		    = AFun False (mk (n-1))

			-- When the type of the Id encodes one-shot-ness,
			-- use the idinfo here
763 764

	-- Lambdas; increase arity
765
arityType (Lam x e) | isId x    = AFun (isOneShotLambda x || isStateHack x) (arityType e)
766
		    | otherwise	= arityType e
767 768

	-- Applications; decrease arity
769 770
arityType (App f (Type _)) = arityType f
arityType (App f a)  	   = case arityType f of
771
				AFun one_shot xs | exprIsCheap a -> xs
772
				other				 -> ATop
773 774 775
							   
	-- Case/Let; keep arity if either the expression is cheap
	-- or it's a 1-shot lambda
776 777 778 779 780 781 782 783 784 785 786 787
arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
				  xs@(AFun one_shot _) | one_shot -> xs
				  xs | exprIsCheap scrut	  -> xs
				     | otherwise	 	  -> ATop

arityType (Let b e) = case arityType e of
		        xs@(AFun one_shot _) | one_shot			      -> xs
		        xs		     | all exprIsCheap (rhssOfBind b) -> xs
					     | otherwise		      -> ATop

arityType other = ATop

788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809
isStateHack id = case splitTyConApp_maybe (idType id) of
                     Just (tycon,_) | tycon == statePrimTyCon -> True
                     other                                    -> False

	-- The last clause is a gross hack.  It claims that 
	-- every function over realWorldStatePrimTy is a one-shot
	-- function.  This is pretty true in practice, and makes a big
	-- difference.  For example, consider
	--	a `thenST` \ r -> ...E...
	-- The early full laziness pass, if it doesn't know that r is one-shot
	-- will pull out E (let's say it doesn't mention r) to give
	--	let lvl = E in a `thenST` \ r -> ...lvl...
	-- When `thenST` gets inlined, we end up with
	--	let lvl = E in \s -> case a s of (r, s') -> ...lvl...
	-- and we don't re-inline E.
	--
	-- It would be better to spot that r was one-shot to start with, but
	-- I don't want to rely on that.
	--
	-- Another good example is in fill_in in PrelPack.lhs.  We should be able to
	-- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.

810
{- NOT NEEDED ANY MORE: etaExpand is cleverer
811 812 813 814 815 816 817 818 819 820 821
ok_note InlineMe = False
ok_note other    = True
    -- Notice that we do not look through __inline_me__
    -- This may seem surprising, but consider
    --		f = _inline_me (\x -> e)
    -- We DO NOT want to eta expand this to
    --		f = \x -> (_inline_me (\x -> e)) x
    -- because the _inline_me gets dropped now it is applied, 
    -- giving just
    --		f = \x -> e
    -- A Bad Idea
822
-}
823 824 825
\end{code}


826
\begin{code}
827
etaExpand :: Arity	  	-- Result should have this number of value args
828
	  -> [Unique]
829
	  -> CoreExpr -> Type	-- Expression and its type
830 831 832
	  -> CoreExpr
-- (etaExpand n us e ty) returns an expression with 
-- the same meaning as 'e', but with arity 'n'.  
833
--
834 835 836
-- Given e' = etaExpand n us e ty
-- We should have
--	ty = exprType e = exprType e'
837 838 839 840 841
--
-- Note that SCCs are not treated specially.  If we have
--	etaExpand 2 (\x -> scc "foo" e)
--	= (\xy -> (scc "foo" e) y)
-- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
842 843 844 845 846 847 848 849 850 851 852 853 854

etaExpand n us expr ty
  | manifestArity expr >= n = expr		-- The no-op case
  | otherwise 		    = eta_expand n us expr ty
  where

-- manifestArity sees how many leading value lambdas there are
manifestArity :: CoreExpr -> Arity
manifestArity (Lam v e) | isId v    = 1 + manifestArity e
			| otherwise = manifestArity e
manifestArity (Note _ e)	    = manifestArity e
manifestArity e			    = 0

855
-- etaExpand deals with for-alls. For example:
856
--		etaExpand 1 E
857
-- where  E :: forall a. a -> a
858
-- would return
859 860 861 862
--	(/\b. \y::a -> E b y)
--
-- It deals with coerces too, though they are now rare
-- so perhaps the extra code isn't worth it
863

864
eta_expand n us expr ty
865 866 867 868
  | n == 0 && 
    -- The ILX code generator requires eta expansion for type arguments
    -- too, but alas the 'n' doesn't tell us how many of them there 
    -- may be.  So we eagerly eta expand any big lambdas, and just
869
    -- cross our fingers about possible loss of sharing in the ILX case. 
870 871 872 873
    -- The Right Thing is probably to make 'arity' include
    -- type variables throughout the compiler.  (ToDo.)
    not (isForAllTy ty)	
    -- Saturated, so nothing to do
874 875
  = expr

876 877
	-- Short cut for the case where there already
	-- is a lambda; no point in gratuitously adding more
878 879 880 881 882 883 884
eta_expand n us (Lam v body) ty
  | isTyVar v
  = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))

  | otherwise
  = Lam v (eta_expand (n-1) us body (funResultTy ty))

885 886 887 888 889 890 891 892 893 894 895 896 897
-- We used to have a special case that stepped inside Coerces here,
-- thus:  eta_expand n us (Note note@(Coerce _ ty) e) _  
--		= Note note (eta_expand n us e ty)
-- BUT this led to an infinite loop
-- Example: 	newtype T = MkT (Int -> Int)
--	eta_expand 1 (coerce (Int->Int) e)
--	--> coerce (Int->Int) (eta_expand 1 T e)
--		by the bogus eqn
--	--> coerce (Int->Int) (coerce T 
--		(\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
--		by the splitNewType_maybe case below
--	and round we go

898
eta_expand n us expr ty
899
  = case splitForAllTy_maybe ty of { 
900
 	  Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
901

902
 	; Nothing ->
903 904
  
    	case splitFunTy_maybe ty of {
905
 	  Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
906
				where
907
				   arg1	      = mkSysLocal FSLIT("eta") uniq arg_ty
908
 				   (uniq:us2) = us
909
				   
910 911
	; Nothing ->

912 913 914 915 916 917 918
		-- Given this:
		-- 	newtype T = MkT (Int -> Int)
		-- Consider eta-expanding this
		--  	eta_expand 1 e T
		-- We want to get
		--	coerce T (\x::Int -> (coerce (Int->Int) e) x)

919
    	case splitNewType_maybe ty of {
920
 	  Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
921 922
 	  Nothing  -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
    	}}}
923
\end{code}
924

925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945
exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
It tells how many things the expression can be applied to before doing
any work.  It doesn't look inside cases, lets, etc.  The idea is that
exprEtaExpandArity will do the hard work, leaving something that's easy
for exprArity to grapple with.  In particular, Simplify uses exprArity to
compute the ArityInfo for the Id. 

Originally I thought that it was enough just to look for top-level lambdas, but
it isn't.  I've seen this

	foo = PrelBase.timesInt

We want foo to get arity 2 even though the eta-expander will leave it
unchanged, in the expectation that it'll be inlined.  But occasionally it
isn't, because foo is blacklisted (used in a rule).  

Similarly, see the ok_note check in exprEtaExpandArity.  So 
	f = __inline_me (\x -> e)
won't be eta-expanded.

And in any case it seems more robust to have exprArity be a bit more intelligent.
946 947
But note that 	(\x y z -> f x y z)
should have arity 3, regardless of f's arity.
948 949

\begin{code}
950
exprArity :: CoreExpr -> Arity
951
exprArity e = go e
952
	    where
953
	      go (Var v) 	       	   = idArity v
954 955
	      go (Lam x e) | isId x    	   = go e + 1
			   | otherwise 	   = go e
956
	      go (Note n e) 		   = go e
957
	      go (App e (Type t))      	   = go e
958
	      go (App f a) | exprIsCheap a = (go f - 1) `max` 0
959 960 961
		-- NB: exprIsCheap a!  
		--	f (fac x) does not have arity 2, 
		-- 	even if f has arity 3!
962 963
		-- NB: `max 0`!  (\x y -> f x) has arity 2, even if f is
		--		 unknown, hence arity 0
964
	      go _		       	   = 0
965 966
\end{code}

967 968 969 970 971 972
%************************************************************************
%*									*
\subsection{Equality}
%*									*
%************************************************************************

973 974 975
@cheapEqExpr@ is a cheap equality test which bales out fast!
	True  => definitely equal
	False => may or may not be equal
976 977

\begin{code}
978
cheapEqExpr :: Expr b -> Expr b -> Bool
979

980 981
cheapEqExpr (Var v1)   (Var v2)   = v1==v2
cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
982
cheapEqExpr (Type t1)  (Type t2)  = t1 `eqType` t2
983 984 985

cheapEqExpr (App f1 a1) (App f2 a2)
  = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
986

987
cheapEqExpr _ _ = False
988 989 990

exprIsBig :: Expr b -> Bool
-- Returns True of expressions that are too big to be compared by cheapEqExpr
991
exprIsBig (Lit _)      = False
992 993 994 995
exprIsBig (Var v)      = False
exprIsBig (Type t)     = False
exprIsBig (App f a)    = exprIsBig f || exprIsBig a
exprIsBig other	       = True
996 997 998
\end{code}


999
\begin{code}
1000 1001
eqExpr :: CoreExpr -> CoreExpr -> Bool
	-- Works ok at more general type, but only needed at CoreExpr
1002 1003 1004
	-- Used in rule matching, so when we find a type we use
	-- eqTcType, which doesn't look through newtypes
	-- [And it doesn't risk falling into a black hole either.]
1005 1006
eqExpr e1 e2
  = eq emptyVarEnv e1 e2
1007
  where
1008 1009 1010 1011 1012 1013 1014
  -- The "env" maps variables in e1 to variables in ty2
  -- So when comparing lambdas etc, 
  -- we in effect substitute v2 for v1 in e1 before continuing
    eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
				  Just v1' -> v1' == v2
				  Nothing  -> v1  == v2

1015
    eq env (Lit lit1)   (Lit lit2)   = lit1 == lit2
1016 1017 1018 1019 1020
    eq env (App f1 a1)  (App f2 a2)  = eq env f1 f2 && eq env a1 a2
    eq env (Lam v1 e1)  (Lam v2 e2)  = eq (extendVarEnv env v1 v2) e1 e2
    eq env (Let (NonRec v1 r1) e1)
	   (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
    eq env (Let (Rec ps1) e1)
sof's avatar
sof committed
1021
	   (Let (Rec ps2) e2)        = equalLength ps1 ps2 &&
1022 1023 1024 1025 1026 1027 1028
				       and (zipWith eq_rhs ps1 ps2) &&
				       eq env' e1 e2
				     where
				       env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
				       eq_rhs (_,r1) (_,r2) = eq env' r1 r2
    eq env (Case e1 v1 a1)
	   (Case e2 v2 a2)	     = eq env e1 e2 &&
sof's avatar
sof committed
1029
				       equalLength a1 a2 &&
1030 1031 1032 1033 1034
				       and (zipWith (eq_alt env') a1 a2)
				     where
				       env' = extendVarEnv env v1 v2

    eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
1035
    eq env (Type t1)    (Type t2)    = t1 `eqType` t2
1036 1037 1038 1039 1040 1041 1042 1043 1044 1045
    eq env e1		e2	     = False
				         
    eq_list env []	 []	  = True
    eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
    eq_list env es1      es2      = False
    
    eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
					 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2

    eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
1046
    eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
1047
    eq_note env InlineCall     InlineCall     = True
1048
    eq_note env (CoreNote s1)  (CoreNote s2)  = s1 == s2
1049
    eq_note env other1	       other2	      = False
1050
\end{code}
sof's avatar
sof committed
1051

1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065

%************************************************************************
%*									*
\subsection{The size of an expression}
%*									*
%************************************************************************

\begin{code}
coreBindsSize :: [CoreBind] -> Int
coreBindsSize bs = foldr ((+) . bindSize) 0 bs

exprSize :: CoreExpr -> Int
	-- A measure of the size of the expressions
	-- It also forces the expression pretty drastically as a side effect
1066
exprSize (Var v)       = v `seq` 1
1067
exprSize (Lit lit)     = lit `seq` 1
1068 1069 1070
exprSize (App f a)     = exprSize f + exprSize a
exprSize (Lam b e)     = varSize b + exprSize e
exprSize (Let b e)     = bindSize b + exprSize e
1071 1072 1073 1074 1075 1076 1077 1078
exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
exprSize (Note n e)    = noteSize n + exprSize e
exprSize (Type t)      = seqType t `seq` 1

noteSize (SCC cc)       = cc `seq` 1
noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
noteSize InlineCall     = 1
noteSize InlineMe       = 1
1079
noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
1080 1081

varSize :: Var -> Int
1082 1083 108