CoreUtils.lhs 58.2 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5 6

Utility functions on @Core@ syntax
7 8

\begin{code}
9
{-# OPTIONS -fno-warn-incomplete-patterns #-}
10 11 12
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
13
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 15
-- for details

batterseapower's avatar
batterseapower committed
16
-- | Commonly useful utilites for manipulating the Core language
17
module CoreUtils (
batterseapower's avatar
batterseapower committed
18
	-- * Constructing expressions
19
	mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
20
	bindNonRec, needsCaseBinding,
21
	mkAltExpr, mkPiType, mkPiTypes,
22

batterseapower's avatar
batterseapower committed
23
	-- * Taking expressions apart
24
	findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
25

batterseapower's avatar
batterseapower committed
26
	-- * Properties of expressions
27
	exprType, coreAltType, coreAltsType,
28
	exprIsDupable, exprIsTrivial, exprIsCheap, 
29
	exprIsHNF,exprOkForSpeculation, exprIsBig, 
30
	exprIsConApp_maybe, exprIsBottom,
31
	rhsIsStatic,
32

batterseapower's avatar
batterseapower committed
33
	-- * Arity and eta expansion
34 35
	manifestArity, exprArity, 
	exprEtaExpandArity, etaExpand, 
36

batterseapower's avatar
batterseapower committed
37
	-- * Expression and bindings size
38
	coreBindsSize, exprSize,
39

batterseapower's avatar
batterseapower committed
40
	-- * Hashing
41 42
	hashExpr,

batterseapower's avatar
batterseapower committed
43 44
	-- * Equality
	cheapEqExpr, tcEqExpr, tcEqExprX,
45

batterseapower's avatar
batterseapower committed
46 47
	-- * Manipulating data constructors and types
	applyTypeToArgs, applyTypeToArg,
48
        dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
49
    ) where
50

51
#include "HsVersions.h"
52

53
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
54 55 56 57 58
import CoreFVs
import PprCore
import Var
import SrcLoc
import VarSet
59
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
60
import Name
61
import Module
62
#if mingw32_TARGET_OS
Simon Marlow's avatar
Simon Marlow committed
63
import Packages
64
#endif
Simon Marlow's avatar
Simon Marlow committed
65 66 67 68 69 70 71 72 73 74 75 76
import Literal
import DataCon
import PrimOp
import Id
import IdInfo
import NewDemand
import Type
import Coercion
import TyCon
import CostCentre
import BasicTypes
import Unique
77
import Outputable
Simon Marlow's avatar
Simon Marlow committed
78 79 80
import DynFlags
import TysPrim
import FastString
81
import Maybes
Simon Marlow's avatar
Simon Marlow committed
82
import Util
83 84
import Data.Word
import Data.Bits
Simon Marlow's avatar
Simon Marlow committed
85 86

import GHC.Exts		-- For `xori` 
87
\end{code}
88

89

90 91 92 93 94 95 96
%************************************************************************
%*									*
\subsection{Find the type of a Core atom/expression}
%*									*
%************************************************************************

\begin{code}
97
exprType :: CoreExpr -> Type
batterseapower's avatar
batterseapower committed
98 99 100
-- ^ Recover the type of a well-typed Core expression. Fails when
-- applied to the actual 'CoreSyn.Type' expression as it cannot
-- really be said to have a type
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
101 102 103
exprType (Var var)	     = idType var
exprType (Lit lit)	     = literalType lit
exprType (Let _ body)	     = exprType body
104 105 106
exprType (Case _ _ ty _)     = ty
exprType (Cast _ co)         = snd (coercionKind co)
exprType (Note _ e)          = exprType e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
107
exprType (Lam binder expr)   = mkPiType binder (exprType expr)
108
exprType e@(App _ _)
109
  = case collectArgs e of
110
	(fun, args) -> applyTypeToArgs e (exprType fun) args
111

112
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
113

114
coreAltType :: CoreAlt -> Type
batterseapower's avatar
batterseapower committed
115
-- ^ Returns the type of the alternatives right hand side
116
coreAltType (_,_,rhs) = exprType rhs
117 118

coreAltsType :: [CoreAlt] -> Type
batterseapower's avatar
batterseapower committed
119
-- ^ Returns the type of the first alternative, which should be the same as for all alternatives
120 121
coreAltsType (alt:_) = coreAltType alt
coreAltsType []	     = panic "corAltsType"
122 123
\end{code}

124
\begin{code}
batterseapower's avatar
batterseapower committed
125 126 127 128 129
mkPiType  :: Var   -> Type -> Type
-- ^ Makes a @(->)@ type or a forall type, depending
-- on whether it is given a type variable or a term variable.
mkPiTypes :: [Var] -> Type -> Type
-- ^ 'mkPiType' for multiple type or value arguments
130 131

mkPiType v ty
132
   | isId v    = mkFunTy (idType v) ty
133
   | otherwise = mkForAllTy v ty
batterseapower's avatar
batterseapower committed
134 135

mkPiTypes vs ty = foldr mkPiType ty vs
136 137
\end{code}

138
\begin{code}
139
applyTypeToArg :: Type -> CoreExpr -> Type
batterseapower's avatar
batterseapower committed
140
-- ^ Determines the type resulting from applying an expression to a function with the given type
141
applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
142
applyTypeToArg fun_ty _             = funResultTy fun_ty
143

144
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
batterseapower's avatar
batterseapower committed
145 146
-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
-- The first argument is just for debugging, and gives some context
147
applyTypeToArgs _ op_ty [] = op_ty
148

149
applyTypeToArgs e op_ty (Type ty : args)
150
  =	-- Accumulate type arguments so we can instantiate all at once
151
    go [ty] args
152
  where
153 154 155
    go rev_tys (Type ty : args) = go (ty:rev_tys) args
    go rev_tys rest_args        = applyTypeToArgs e op_ty' rest_args
			 	where
156 157
				  op_ty' = applyTysD msg op_ty (reverse rev_tys)
				  msg = panic_msg e op_ty
158

159
applyTypeToArgs e op_ty (_ : args)
160
  = case (splitFunTy_maybe op_ty) of
161
	Just (_, res_ty) -> applyTypeToArgs e res_ty args
162 163 164 165
	Nothing -> pprPanic "applyTypeToArgs" (panic_msg e op_ty)

panic_msg :: CoreExpr -> Type -> SDoc
panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
166 167
\end{code}

168 169
%************************************************************************
%*									*
170
\subsection{Attaching notes}
171 172 173 174 175 176
%*									*
%************************************************************************

mkNote removes redundant coercions, and SCCs where possible

\begin{code}
177
#ifdef UNUSED
178 179 180 181
mkNote :: Note -> CoreExpr -> CoreExpr
mkNote (SCC cc)	expr		   = mkSCC cc expr
mkNote InlineMe expr		   = mkInlineMe expr
mkNote note     expr		   = Note note expr
182
#endif
183 184 185 186 187 188
\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.

189 190 191 192 193 194 195
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.  

196 197 198 199 200 201 202 203 204 205
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.

206
\begin{code}
batterseapower's avatar
batterseapower committed
207 208
-- | Wraps the given expression in an inlining hint unless the expression
-- is trivial in some sense, so that doing so would usually hurt us
209
mkInlineMe :: CoreExpr -> CoreExpr
210 211
mkInlineMe (Var v) = Var v
mkInlineMe e	   = Note InlineMe e
212 213 214
\end{code}

\begin{code}
batterseapower's avatar
batterseapower committed
215
-- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
216 217 218 219
mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
mkCoerceI IdCo e = e
mkCoerceI (ACo co) e = mkCoerce co e

batterseapower's avatar
batterseapower committed
220
-- | Wrap the given expression in the coercion safely, coalescing nested coercions
221 222
mkCoerce :: Coercion -> CoreExpr -> CoreExpr
mkCoerce co (Cast expr co2)
223 224
  = ASSERT(let { (from_ty, _to_ty) = coercionKind co; 
                 (_from_ty2, to_ty2) = coercionKind co2} in
225 226 227 228
           from_ty `coreEqType` to_ty2 )
    mkCoerce (mkTransCoercion co2 co) expr

mkCoerce co expr 
229
  = let (from_ty, _to_ty) = coercionKind co in
230 231 232
--    if to_ty `coreEqType` from_ty
--    then expr
--    else 
233
        ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindPredTy co))
234
         (Cast expr co)
235 236 237
\end{code}

\begin{code}
batterseapower's avatar
batterseapower committed
238 239
-- | Wraps the given expression in the cost centre unless
-- in a way that maximises their utility to the user
240 241
mkSCC :: CostCentre -> Expr b -> Expr b
	-- Note: Nested SCC's *are* preserved for the benefit of
242
	--       cost centre stack profiling
243
mkSCC _  (Lit lit)          = Lit lit
244 245 246
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
247
mkSCC cc (Cast e co)        = Cast (mkSCC cc e) co -- Move _scc_ inside cast
248
mkSCC cc expr	    	    = Note (SCC cc) expr
249 250 251
\end{code}


252 253 254 255 256 257 258 259
%************************************************************************
%*									*
\subsection{Other expression construction}
%*									*
%************************************************************************

\begin{code}
bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
batterseapower's avatar
batterseapower committed
260 261 262 263 264 265 266
-- ^ @bindNonRec x r b@ produces either:
--
-- > let x = r in b
--
-- or:
--
-- > case r of x { _DEFAULT_ -> b }
267
--
batterseapower's avatar
batterseapower committed
268 269
-- depending on whether we have to use a @case@ or @let@
-- binding for the expression (see 'needsCaseBinding').
270
-- It's used by the desugarer to avoid building bindings
batterseapower's avatar
batterseapower committed
271 272 273
-- that give Core Lint a heart attack, although actually
-- the simplifier deals with them perfectly well. See
-- also 'MkCore.mkCoreLet'
274
bindNonRec bndr rhs body 
batterseapower's avatar
batterseapower committed
275
  | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
276 277
  | otherwise			       = Let (NonRec bndr rhs) body

batterseapower's avatar
batterseapower committed
278 279
-- | Tests whether we have to use a @case@ rather than @let@ binding for this expression
-- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"
280
needsCaseBinding :: Type -> CoreExpr -> Bool
281 282 283 284
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)
285 286 287
\end{code}

\begin{code}
batterseapower's avatar
batterseapower committed
288 289 290 291 292 293
mkAltExpr :: AltCon     -- ^ Case alternative constructor
          -> [CoreBndr] -- ^ Things bound by the pattern match
          -> [Type]     -- ^ The type arguments to the case alternative
          -> CoreExpr
-- ^ This guy constructs the value that the scrutinee must have
-- given that you are in one particular branch of a case
294
mkAltExpr (DataAlt con) args inst_tys
295
  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
296 297
mkAltExpr (LitAlt lit) [] []
  = Lit lit
298 299
mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
300 301
\end{code}

302 303 304 305 306 307 308

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

309 310
The default alternative must be first, if it exists at all.
This makes it easy to find, though it makes matching marginally harder.
311 312

\begin{code}
batterseapower's avatar
batterseapower committed
313
-- | Extract the default case alternative
314
findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
315 316
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
findDefault alts			= 		      (alts, Nothing)
317

batterseapower's avatar
batterseapower committed
318 319
-- | Find the case alternative corresponding to a particular 
-- constructor: panics if no such constructor exists
320 321
findAlt :: AltCon -> [CoreAlt] -> CoreAlt
findAlt con alts
322 323
  = case alts of
	(deflt@(DEFAULT,_,_):alts) -> go alts deflt
324
        _                          -> go alts panic_deflt
325
  where
326
    panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
327

328 329 330 331 332 333
    go []	 	       deflt = deflt
    go (alt@(con1,_,_) : alts) deflt
      =	case con `cmpAltCon` con1 of
	  LT -> deflt	-- Missed it already; the alts are in increasing order
	  EQ -> alt
	  GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
334 335 336

isDefaultAlt :: CoreAlt -> Bool
isDefaultAlt (DEFAULT, _, _) = True
337
isDefaultAlt _               = False
338 339 340

---------------------------------
mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
batterseapower's avatar
batterseapower committed
341 342
-- ^ Merge alternatives preserving order; alternatives in
-- the first argument shadow ones in the second
343 344 345 346 347 348 349
mergeAlts [] as2 = as2
mergeAlts as1 [] = as1
mergeAlts (a1:as1) (a2:as2)
  = case a1 `cmpAlt` a2 of
	LT -> a1 : mergeAlts as1      (a2:as2)
	EQ -> a1 : mergeAlts as1      as2	-- Discard a2
	GT -> a2 : mergeAlts (a1:as1) as2
350 351 352 353


---------------------------------
trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
batterseapower's avatar
batterseapower committed
354 355 356 357 358 359
-- ^ Given:
--
-- > case (C a b x y) of
-- >        C b x y -> ...
--
-- We want to drop the leading type argument of the scrutinee
360 361 362
-- leaving the arguments to match agains the pattern

trimConArgs DEFAULT      args = ASSERT( null args ) []
363
trimConArgs (LitAlt _)   args = ASSERT( null args ) []
364
trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
365 366 367
\end{code}


368 369
%************************************************************************
%*									*
370
\subsection{Figuring out things about expressions}
371 372 373
%*									*
%************************************************************************

374 375 376 377 378
@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 

379 380 381
There used to be a gruesome test for (hasNoBinding v) in the
Var case:
	exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
batterseapower's avatar
batterseapower committed
382 383
The idea here is that a constructor worker, like \$wJust, is
really short for (\x -> \$wJust x), becuase \$wJust has no binding.
384 385 386 387 388 389
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.

390 391 392 393 394
SCC notes.  We do not treat (_scc_ "foo" x) as trivial, because 
  a) it really generates code, (and a heap object when it's 
     a function arg) to capture the cost centre
  b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind

395
\begin{code}
396 397 398 399 400 401
exprIsTrivial :: CoreExpr -> Bool
exprIsTrivial (Var _)          = True        -- See notes above
exprIsTrivial (Type _)         = True
exprIsTrivial (Lit lit)        = litIsTrivial lit
exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
exprIsTrivial (Note (SCC _) _) = False       -- See notes above
402
exprIsTrivial (Note _       e) = exprIsTrivial e
403 404 405
exprIsTrivial (Cast e _)       = exprIsTrivial e
exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
exprIsTrivial _                = False
406 407 408
\end{code}


409
@exprIsDupable@	is true of expressions that can be duplicated at a modest
410
		cost in code size.  This will only happen in different case
411
		branches, so there's no issue about duplicating work.
412 413 414 415

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

416 417 418 419
		Its only purpose is to avoid fruitless let-binding
		and then inlining of case join points


420
\begin{code}
421 422 423 424 425
exprIsDupable :: CoreExpr -> Bool
exprIsDupable (Type _)          = True
exprIsDupable (Var _)           = True
exprIsDupable (Lit lit)         = litIsDupable lit
exprIsDupable (Note InlineMe _) = True
426
exprIsDupable (Note _ e)        = exprIsDupable e
427 428
exprIsDupable (Cast e _)        = exprIsDupable e
exprIsDupable expr
429 430
  = go expr 0
  where
431
    go (Var _)   _      = True
432 433 434
    go (App f a) n_args =  n_args < dupAppSize
			&& exprIsDupable a
			&& go f (n_args+1)
435
    go _         _      = False
436 437 438 439

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

441 442 443 444
@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.]
445 446 447 448 449 450 451

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:
452 453 454

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

457 458
  *	let x = e in b
	(where e and b are cheap)
459 460

  *	op x1 ... xn
461
	(where op is a cheap primitive operator)
462

463
  *	error "foo"
464
	(because we are happy to substitute it inside a lambda)
465

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

469 470
\begin{code}
exprIsCheap :: CoreExpr -> Bool
471
exprIsCheap (Lit _)           = True
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
472 473
exprIsCheap (Type _)          = True
exprIsCheap (Var _)           = True
474
exprIsCheap (Note InlineMe _) = True
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
475
exprIsCheap (Note _ e)        = exprIsCheap e
476
exprIsCheap (Cast e _)        = exprIsCheap e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
477 478 479
exprIsCheap (Lam x e)         = isRuntimeVar x || exprIsCheap e
exprIsCheap (Case e _ _ alts) = exprIsCheap e && 
				and [exprIsCheap rhs | (_,_,rhs) <- alts]
480
	-- Experimentally, treat (case x of ...) as cheap
481
	-- (and case __coerce x etc.)
482 483
	-- This improves arities of overloaded functions where
	-- there is only dictionary selection (no construction) involved
484 485 486
exprIsCheap (Let (NonRec x _) e)  
      | isUnLiftedType (idType x) = exprIsCheap e
      | otherwise		  = False
487 488
	-- strict lets always have cheap right hand sides,
	-- and do no allocation.
489

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
490 491
exprIsCheap other_expr 	-- Applications and variables
  = go other_expr []
492
  where
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
493 494 495 496
	-- Accumulate value arguments, then decide
    go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
			  | otherwise      = go f val_args

497
    go (Var _) [] = True	-- Just a type application of a variable
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
498 499 500 501 502 503 504 505
				-- (f t1 t2 t3) counts as WHNF
    go (Var f) args
 	= case globalIdDetails f of
		RecordSelId {} -> go_sel args
		ClassOpId _    -> go_sel args
		PrimOpId op    -> go_primop op args

		DataConWorkId _ -> go_pap args
506
		_ | length args < idArity f -> go_pap args
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
507

508
	        _ -> isBottomingId f
509
			-- Application of a function which
510 511
			-- always gives bottom; we treat this as cheap
			-- because it certainly doesn't need to be shared!
512
	
513
    go _ _ = False
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529
 
    --------------
    go_pap args = all exprIsTrivial args
 	-- For constructor applications and primops, check that all
 	-- the args are trivial.  We don't want to treat as cheap, say,
 	-- 	(1:2:3:4:5:[])
 	-- We'll put up with one constructor application, but not dozens
 	
    --------------
    go_primop op args = primOpIsCheap op && all exprIsCheap args
 	-- 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
 
    --------------
530
    go_sel [arg] = exprIsCheap arg	-- I'm experimenting with making record selection
531
    go_sel _     = False		-- look cheap, so we will substitute it inside a
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
532 533 534
 					-- lambda.  Particularly for dictionary field selection.
  		-- BUT: Take care with (sel d x)!  The (sel d) might be cheap, but
  		--	there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)
535 536 537
\end{code}

\begin{code}
batterseapower's avatar
batterseapower committed
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
-- | 'exprOkForSpeculation' returns True of an expression that 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
--
-- Precisely, it returns @True@ iff:
--
--  * The expression guarantees to terminate, 
--
--  * soon, 
--
--  * without raising an exception,
--
--  * without causing a side effect (e.g. writing a mutable variable)
--
-- Note that if @exprIsHNF e@, then @exprOkForSpecuation e@.
-- As an example of the considerations in this test, consider:
--
-- > let x = case y# +# 1# of { r# -> I# r# }
-- > in E
--
-- being translated to:
--
-- > case y# +# 1# of { r# -> 
-- >    let x = I# r#
-- >    in E 
-- > }
-- 
-- 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.
570
exprOkForSpeculation :: CoreExpr -> Bool
571 572
exprOkForSpeculation (Lit _)     = True
exprOkForSpeculation (Type _)    = True
573
    -- Tick boxes are *not* suitable for speculation
574
exprOkForSpeculation (Var v)     = isUnLiftedType (idType v)
575
				 && not (isTickBoxOp v)
576
exprOkForSpeculation (Note _ e)  = exprOkForSpeculation e
577
exprOkForSpeculation (Cast e _)  = exprOkForSpeculation e
578
exprOkForSpeculation other_expr
579 580
  = case collectArgs other_expr of
	(Var f, args) -> spec_ok (globalIdDetails f) args
581
        _             -> False
582
 
583
  where
584
    spec_ok (DataConWorkId _) _
585 586 587 588 589 590 591 592 593 594 595 596 597 598
      = 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
599 600 601
				-- A bit conservative: we don't really need
				-- to care about lazy arguments, but this is easy

602
    spec_ok _ _ = False
603

batterseapower's avatar
batterseapower committed
604
-- | True of dyadic operators that can fail only if the second arg is zero!
605 606 607 608 609 610 611 612 613 614 615 616
isDivOp :: PrimOp -> Bool
-- 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
617
isDivOp _                = False
618 619 620
\end{code}

\begin{code}
batterseapower's avatar
batterseapower committed
621 622
-- | True of expressions that are guaranteed to diverge upon execution
exprIsBottom :: CoreExpr -> Bool
623
exprIsBottom e = go 0 e
624 625 626 627 628 629 630 631 632 633 634
               where
                -- n is the number of args
                 go n (Note _ e)     = go n e
                 go n (Cast e _)     = go n e
                 go n (Let _ e)      = go n e
                 go _ (Case e _ _ _) = go 0 e   -- Just check the scrut
                 go n (App e _)      = go (n+1) e
                 go n (Var v)        = idAppIsBottom v n
                 go _ (Lit _)        = False
                 go _ (Lam _ _)      = False
                 go _ (Type _)       = False
635 636

idAppIsBottom :: Id -> Int -> Bool
637
idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
638 639
\end{code}

640
\begin{code}
batterseapower's avatar
batterseapower committed
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 666 667 668 669

-- | This returns true for expressions that are certainly /already/ 
-- evaluated to /head/ normal form.  This is used to decide whether it's ok 
-- to change:
--
-- > case x of _ -> e
--
-- into:
--
-- > e
--
-- and to decide whether it's safe to discard a 'seq'.
-- So, it does /not/ treat variables as evaluated, unless they say they are.
-- However, it /does/ treat partial applications and constructor applications
-- as values, even if their arguments are non-trivial, provided the argument
-- type is lifted. For example, both of these are values:
--
-- > (:) (f x) (map f xs)
-- > map (...redex...)
--
-- Because 'seq' on such things completes immediately.
--
-- For unlifted argument types, we have to be careful:
--
-- > C (f x :: Int#)
--
-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't 
-- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
-- unboxed type must be ok-for-speculation (or trivial).
670 671
exprIsHNF :: CoreExpr -> Bool		-- True => Value-lambda, constructor, PAP
exprIsHNF (Var v) 	-- NB: There are no value args at this point
672
  =  isDataConWorkId v 	-- Catches nullary constructors, 
673 674 675 676
			--	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
677 678
	-- A worry: what if an Id's unfolding is just itself: 
	-- then we could get an infinite loop...
679

680 681 682 683 684 685
exprIsHNF (Lit _)          = True
exprIsHNF (Type _)         = True       -- Types are honorary Values;
                                        -- we don't mind copying them
exprIsHNF (Lam b e)        = isRuntimeVar b || exprIsHNF e
exprIsHNF (Note _ e)       = exprIsHNF e
exprIsHNF (Cast e _)       = exprIsHNF e
686 687
exprIsHNF (App e (Type _)) = exprIsHNF e
exprIsHNF (App e a)        = app_is_value e [a]
688
exprIsHNF _                = False
689 690

-- There is at least one value argument
691
app_is_value :: CoreExpr -> [CoreArg] -> Bool
692
app_is_value (Var fun) args
693 694
  = idArity fun > valArgCount args	-- Under-applied function
    ||  isDataConWorkId fun 		--  or data constructor
695
app_is_value (Note _ f) as = app_is_value f as
696 697
app_is_value (Cast f _) as = app_is_value f as
app_is_value (App f a)  as = app_is_value f (a:as)
698
app_is_value _          _  = False
699 700
\end{code}

batterseapower's avatar
batterseapower committed
701 702
These InstPat functions go here to avoid circularity between DataCon and Id

703
\begin{code}
704 705
dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
batterseapower's avatar
batterseapower committed
706

Ian Lynagh's avatar
Ian Lynagh committed
707
dataConRepInstPat   = dataConInstPat dataConRepArgTys (repeat ((fsLit "ipv")))
708
dataConRepFSInstPat = dataConInstPat dataConRepArgTys
Ian Lynagh's avatar
Ian Lynagh committed
709
dataConOrigInstPat  = dataConInstPat dc_arg_tys       (repeat ((fsLit "ipv")))
710
  where 
711
    dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc
712
	-- Remember to include the existential dictionaries
713 714 715 716 717 718 719

dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
                  -> [FastString]          -- A long enough list of FSs to use for names
                  -> [Unique]              -- An equally long list of uniques, at least one for each binder
                  -> DataCon
	          -> [Type]                -- Types to instantiate the universally quantified tyvars
	       -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
720
-- dataConInstPat arg_fun fss us con inst_tys returns a triple 
721
-- (ex_tvs, co_tvs, arg_ids),
722 723 724 725 726
--
--   ex_tvs are intended to be used as binders for existential type args
--
--   co_tvs are intended to be used as binders for coercion args and the kinds
--     of these vars have been instantiated by the inst_tys and the ex_tys
727 728
--     The co_tvs include both GADT equalities (dcEqSpec) and 
--     programmer-specified equalities (dcEqTheta)
729
--
730 731 732 733
--   arg_ids are indended to be used as binders for value arguments, 
--     and their types have been instantiated with inst_tys and ex_tys
--     The arg_ids include both dicts (dcDictTheta) and
--     programmer-specified arguments (after rep-ing) (deRepArgTys)
734 735 736 737 738 739 740 741 742
--
-- Example.
--  The following constructor T1
--
--  data T a where
--    T1 :: forall b. Int -> b -> T(a,b)
--    ...
--
--  has representation type 
743
--   forall a. forall a1. forall b. (a :=: (a1,b)) => 
744 745
--     Int -> b -> T a
--
746
--  dataConInstPat fss us T1 (a1',b') will return
747
--
748
--  ([a1'', b''], [c :: (a1', b'):=:(a1'', b'')], [x :: Int, y :: b''])
749
--
750 751
--  where the double-primed variables are created with the FastStrings and
--  Uniques given as fss and us
752
dataConInstPat arg_fun fss uniqs con inst_tys 
753
  = (ex_bndrs, co_bndrs, arg_ids)
754 755 756
  where 
    univ_tvs = dataConUnivTyVars con
    ex_tvs   = dataConExTyVars con
757
    arg_tys  = arg_fun con
758
    eq_spec  = dataConEqSpec con
759 760
    eq_theta = dataConEqTheta con
    eq_preds = eqSpecPreds eq_spec ++ eq_theta
761 762

    n_ex = length ex_tvs
763
    n_co = length eq_preds
764

765
      -- split the Uniques and FastStrings
766
    (ex_uniqs, uniqs')   = splitAt n_ex uniqs
767 768
    (co_uniqs, id_uniqs) = splitAt n_co uniqs'

769 770
    (ex_fss, fss')     = splitAt n_ex fss
    (co_fss, id_fss)   = splitAt n_co fss'
771

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
772 773
      -- Make existential type variables
    ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
774
    mk_ex_var uniq fs var = mkTyVar new_name kind
775
      where
776
        new_name = mkSysTvName uniq fs
777 778
        kind     = tyVarKind var

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
779 780
      -- Make the instantiating substitution
    subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
781

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
782 783
      -- Make new coercion vars, instantiating kind
    co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
784
    mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
785
       where
786
         new_name = mkSysTvName uniq fs
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
787
         co_kind  = substTy subst (mkPredTy eq_pred)
788 789

      -- make value vars, instantiating types
790
    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
791
    arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
792

batterseapower's avatar
batterseapower committed
793 794
-- | Returns @Just (dc, [x1..xn])@ if the argument expression is 
-- a constructor application of the form @dc x1 .. xn@
795
exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
796
exprIsConApp_maybe (Cast expr co)
797
  =     -- Here we do the KPush reduction rule as described in the FC paper
798
    case exprIsConApp_maybe expr of {
799 800 801 802 803 804 805 806 807 808
	Nothing 	   -> Nothing ;
	Just (dc, dc_args) -> 

	-- The transformation applies iff we have
	--	(C e1 ... en) `cast` co
	-- where co :: (T t1 .. tn) :=: (T s1 ..sn)
	-- That is, with a T at the top of both sides
	-- The left-hand one must be a T, because exprIsConApp returned True
	-- but the right-hand one might not be.  (Though it usually will.)

809 810
    let (from_ty, to_ty)	   = coercionKind co
	(from_tc, from_tc_arg_tys) = splitTyConApp from_ty
811 812
  		-- The inner one must be a TyConApp
    in
813 814
    case splitTyConApp_maybe to_ty of {
	Nothing -> Nothing ;
815 816 817 818 819 820 821 822 823
	Just (to_tc, to_tc_arg_tys) 
		| from_tc /= to_tc -> Nothing
		-- These two Nothing cases are possible; we might see 
		--	(C x y) `cast` (g :: T a ~ S [a]),
		-- where S is a type function.  In fact, exprIsConApp
		-- will probably not be called in such circumstances,
		-- but there't nothing wrong with it 

	 	| otherwise  ->
824
    let
825
	tc_arity = tyConArity from_tc
826

827 828 829 830
        (univ_args, rest1)        = splitAt tc_arity dc_args
        (ex_args, rest2)          = splitAt n_ex_tvs rest1
	(co_args_spec, rest3)     = splitAt n_cos_spec rest2
	(co_args_theta, val_args) = splitAt n_cos_theta rest3
831

832
        arg_tys 	    = dataConRepArgTys dc
833
	dc_univ_tyvars	    = dataConUnivTyVars dc
834
        dc_ex_tyvars        = dataConExTyVars dc
835
	dc_eq_spec	    = dataConEqSpec dc
836
        dc_eq_theta         = dataConEqTheta dc
837 838
        dc_tyvars           = dc_univ_tyvars ++ dc_ex_tyvars
        n_ex_tvs            = length dc_ex_tyvars
839 840
	n_cos_spec	    = length dc_eq_spec
	n_cos_theta	    = length dc_eq_theta
841 842 843 844 845 846 847

	-- Make the "theta" from Fig 3 of the paper
        gammas              = decomposeCo tc_arity co
        new_tys             = gammas ++ map (\ (Type t) -> t) ex_args
        theta               = zipOpenTvSubst dc_tyvars new_tys

          -- First we cast the existential coercion arguments
848 849 850 851 852 853 854 855 856
        cast_co_spec (tv, ty) co 
          = cast_co_theta (mkEqPred (mkTyVarTy tv, ty)) co
        cast_co_theta eqPred (Type co) 
          | (ty1, ty2) <- getEqPredTys eqPred
          = Type $ mkSymCoercion (substTy theta ty1)
		   `mkTransCoercion` co
		   `mkTransCoercion` (substTy theta ty2)
        new_co_args = zipWith cast_co_spec  dc_eq_spec  co_args_spec ++
                      zipWith cast_co_theta dc_eq_theta co_args_theta
857
  
858 859 860 861
          -- ...and now value arguments
	new_val_args = zipWith cast_arg arg_tys val_args
	cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg

862
    in
863
    ASSERT( length univ_args == tc_arity )
864 865
    ASSERT( from_tc == dataConTyCon dc )
    ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) )
866 867 868
    ASSERT( all isTypeArg (univ_args ++ ex_args) )
    ASSERT2( equalLength val_args arg_tys, ppr dc $$ ppr dc_tyvars $$ ppr dc_ex_tyvars $$ ppr arg_tys $$ ppr dc_args $$ ppr univ_args $$ ppr ex_args $$ ppr val_args $$ ppr arg_tys  )

869
    Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
870
    }}
871

872
{-
andy@galois.com's avatar
andy@galois.com committed
873 874 875 876 877 878 879
-- We do not want to tell the world that we have a
-- Cons, to *stop* Case of Known Cons, which removes
-- the TickBox.
exprIsConApp_maybe (Note (TickBox {}) expr)
  = Nothing
exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
  = Nothing
880
-}
andy@galois.com's avatar
andy@galois.com committed
881

882 883
exprIsConApp_maybe (Note _ expr)
  = exprIsConApp_maybe expr
884 885 886 887
    -- 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
888 889 890 891 892 893
    --
    -- 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.
894 895

exprIsConApp_maybe expr = analyse (collectArgs expr)
896 897
  where
    analyse (Var fun, args)
898
	| Just con <- isDataConWorkId_maybe fun,
sof's avatar
sof committed
899
	  args `lengthAtLeast` dataConRepArity con
900 901
		-- Might be > because the arity excludes type args
	= Just (con,args)
902

903 904
	-- Look through unfoldings, but only cheap ones, because
	-- we are effectively duplicating the unfolding
905
    analyse (Var fun, [])
906 907 908
	| let unf = idUnfolding fun,
	  isCheapUnfolding unf
	= exprIsConApp_maybe (unfoldingTemplate unf)
909

910
    analyse _ = Nothing
911 912
\end{code}

913

914

915 916 917 918 919 920
%************************************************************************
%*									*
\subsection{Eta reduction and expansion}
%*									*
%************************************************************************

921
\begin{code}
batterseapower's avatar
batterseapower committed
922 923
-- ^ The Arity returned is the number of value args the 
-- expression can be applied to without doing much work
924
exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
batterseapower's avatar
batterseapower committed
925
{- 
926 927 928 929 930