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

\begin{code}
#include "HsVersions.h"

module CoreUtils (
	coreExprType, coreAltsType,

12
	substCoreExpr, substCoreBindings
13 14 15 16

	, mkCoreIfThenElse
	, argToExpr
	, unTagBinders, unTagBindersAlts
17
	, manifestlyWHNF, manifestlyBottom
18 19 20
	, maybeErrorApp
	, nonErrorRHSs
	, squashableDictishCcExpr
21 22
	, exprSmallEnoughToDup
{-	
23 24 25 26 27
	coreExprArity,
	isWrapperFor,

-}  ) where

28 29
IMP_Ubiq()
IMPORT_DELOOPER(IdLoop)	-- for pananoia-checking purposes
30 31 32 33

import CoreSyn

import CostCentre	( isDictCC )
34
import Id		( idType, mkSysLocal, getIdArity, isBottomingId,
35
			  toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
36
			  addOneToIdEnv, growIdEnvList, lookupIdEnv,
37
			  isNullIdEnv, SYN_IE(IdEnv),
38 39
			  GenId{-instances-}
			)
40
import IdInfo		( arityMaybe )
41
import Literal		( literalType, isNoRepLit, Literal(..) )
42
import Maybes		( catMaybes, maybeToBool )
43
import PprCore
44
import PprStyle		( PprStyle(..) )
45
import PprType		( GenType{-instances-} )
46
import Pretty		( ppAboves )
47
import PrelVals		( augmentId, buildId )
48
import PrimOp		( primOpType, fragilePrimOp, PrimOp(..) )
49
import SrcLoc		( mkUnknownSrcLoc )
50
import TyVar		( cloneTyVar,
51
			  isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
52
			)
53
import Type		( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
54 55
			  getFunTy_maybe, applyTy, isPrimType,
			  splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
56
			)
57
import TysWiredIn	( trueDataCon, falseDataCon )
58
import UniqSupply	( initUs, returnUs, thenUs,
59
			  mapUs, mapAndUnzipUs, getUnique,
60
			  SYN_IE(UniqSM), UniqSupply
61
			)
62
import Usage		( SYN_IE(UVar) )
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
import Util		( zipEqual, panic, pprPanic, assertPanic )

type TypeEnv = TyVarEnv Type
applyUsage = panic "CoreUtils.applyUsage:ToDo"
\end{code}

%************************************************************************
%*									*
\subsection{Find the type of a Core atom/expression}
%*									*
%************************************************************************

\begin{code}
coreExprType :: CoreExpr -> Type

coreExprType (Var var) = idType   var
coreExprType (Lit lit) = literalType lit

coreExprType (Let _ body)	= coreExprType body
coreExprType (SCC _ expr)	= coreExprType expr
coreExprType (Case _ alts)	= coreAltsType alts

85 86
coreExprType (Coerce _ ty _)	= ty -- that's the whole point!

87 88 89 90 91 92 93
-- a Con is a fully-saturated application of a data constructor
-- a Prim is <ditto> of a PrimOp

coreExprType (Con con args) = applyTypeToArgs (idType    con) args
coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args

coreExprType (Lam (ValBinder binder) expr)
94
  = idType binder `mkFunTy` coreExprType expr
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 122 123 124 125 126 127 128 129 130 131 132 133 134 135

coreExprType (Lam (TyBinder tyvar) expr)
  = mkForAllTy tyvar (coreExprType expr)

coreExprType (Lam (UsageBinder uvar) expr)
  = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)

coreExprType (App expr (TyArg ty))
  = applyTy (coreExprType expr) ty

coreExprType (App expr (UsageArg use))
  = applyUsage (coreExprType expr) use

coreExprType (App expr val_arg)
  = ASSERT(isValArg val_arg)
    let
	fun_ty = coreExprType expr
    in
    case (getFunTy_maybe fun_ty) of
	  Just (_, result_ty) -> result_ty
#ifdef DEBUG
	  Nothing -> pprPanic "coreExprType:\n"
		(ppAboves [ppr PprDebug fun_ty,
			   ppr PprShowAll (App expr val_arg)])
#endif
\end{code}

\begin{code}
coreAltsType :: CoreCaseAlts -> Type

coreAltsType (AlgAlts [] deflt)         = default_ty deflt
coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1

coreAltsType (PrimAlts [] deflt)       = default_ty deflt
coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1

default_ty NoDefault           = panic "coreExprType:Case:default_ty"
default_ty (BindDefault _ rhs) = coreExprType rhs
\end{code}

\begin{code}
136 137 138 139 140 141
applyTypeToArgs op_ty args	    = foldl applyTypeToArg op_ty args

applyTypeToArg op_ty (TyArg ty)     = applyTy op_ty ty
applyTypeToArg op_ty (UsageArg _)   = panic "applyTypeToArg: UsageArg"
applyTypeToArg op_ty val_or_lit_arg = case (getFunTy_maybe op_ty) of
					Just (_, res_ty) -> res_ty
142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
\end{code}

%************************************************************************
%*									*
\subsection{Routines to manufacture bits of @CoreExpr@}
%*									*
%************************************************************************

\begin{code}
mkCoreIfThenElse (Var bool) then_expr else_expr
    | bool == trueDataCon   = then_expr
    | bool == falseDataCon  = else_expr

mkCoreIfThenElse guard then_expr else_expr
  = Case guard
      (AlgAlts [ (trueDataCon,  [], then_expr),
		 (falseDataCon, [], else_expr) ]
       NoDefault )
\end{code}

For making @Apps@ and @Lets@, we must take appropriate evasive
action if the thing being bound has unboxed type.  @mkCoApp@ requires
164
a name supply to do its work.
165

166
@mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
167 168 169
arguments-must-be-atoms constraint.

\begin{code}
170 171 172 173 174 175 176 177
data CoreArgOrExpr
  = AnArg   CoreArg
  | AnExpr  CoreExpr

mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
mkCoCon  :: Id       -> [CoreArgOrExpr] -> UniqSM CoreExpr
mkCoPrim :: PrimOp   -> [CoreArgOrExpr] -> UniqSM CoreExpr

178 179 180 181 182 183 184
mkCoApps fun args = co_thing (mkGenApp fun) args
mkCoCon  con args = co_thing (Con  con)     args
mkCoPrim  op args = co_thing (Prim op)      args 

co_thing :: ([CoreArg] -> CoreExpr)
	 -> [CoreArgOrExpr]
	 -> UniqSM CoreExpr
185

186
co_thing thing arg_exprs
187 188 189
  = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
    returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
  where
190 191
    expr_to_arg :: CoreArgOrExpr
		-> UniqSM (CoreArg, Maybe CoreBinding)
192

193 194 195 196
    expr_to_arg (AnArg  arg)     = returnUs (arg,      Nothing)
    expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
    expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
    expr_to_arg (AnExpr other_expr)
197 198 199
      = let
	    e_ty = coreExprType other_expr
	in
200
	getUnique `thenUs` \ uniq ->
201 202 203
	let
	    new_var  = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
	in
204
	returnUs (VarArg new_var, Just (NonRec new_var other_expr))
205 206 207 208 209 210 211 212 213 214 215
\end{code}

\begin{code}
argToExpr ::
  GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar

argToExpr (VarArg v)   = Var v
argToExpr (LitArg lit) = Lit lit
\end{code}

\begin{code}
216 217 218 219 220 221 222 223 224
exprSmallEnoughToDup (Con _ _)   = True	-- Could check # of args
exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
exprSmallEnoughToDup (Lit lit)   = not (isNoRepLit lit)
exprSmallEnoughToDup expr
  = case (collectArgs expr) of { (fun, _, _, vargs) ->
    case fun of
      Var v | length vargs == 0 -> True
      _				-> False
    }
225

226 227
{- LATER:
WAS: MORE CLEVER:
228
exprSmallEnoughToDup expr  -- for now, just: <var> applied to <args>
229
  = case (collectArgs expr) of { (fun, _, _, vargs) ->
230 231 232
    case fun of
      Var v -> v /= buildId
		 && v /= augmentId
233
		 && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
234 235
      _       -> False
    }
236
-}
237 238 239 240 241 242 243 244 245 246
\end{code}
Question (ADR): What is the above used for?  Is a _ccall_ really small
enough?

@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
it is obviously in weak head normal form.  It isn't a disaster if it
errs on the conservative side (returning \tr{False})---I've probably
left something out... [WDP]

\begin{code}
247 248
manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool

249 250 251 252
manifestlyWHNF (Var _)	      = True
manifestlyWHNF (Lit _)	      = True
manifestlyWHNF (Con _ _)      = True
manifestlyWHNF (SCC _ e)      = manifestlyWHNF e
253
manifestlyWHNF (Coerce _ _ e) = manifestlyWHNF e
254 255
manifestlyWHNF (Let _ e)      = False
manifestlyWHNF (Case _ _)     = False
256

257
manifestlyWHNF (Lam x e)  = if isValBinder x then True else manifestlyWHNF e
258 259

manifestlyWHNF other_expr   -- look for manifest partial application
260
  = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
261
    case fun of
262
      Var f ->  let
263
		    num_val_args = length vargs
264 265 266 267 268 269 270 271
		in
		num_val_args == 0 -- Just a type application of
				  -- a variable (f t1 t2 t3);
				  -- counts as WHNF.
		||
		case (arityMaybe (getIdArity f)) of
		  Nothing     -> False
		  Just arity  -> num_val_args < arity
272 273 274 275 276 277 278 279 280 281 282

      _ -> False
    }
\end{code}

@manifestlyBottom@ looks at a Core expression and returns \tr{True} if
it is obviously bottom, that is, it will certainly return bottom at
some point.  It isn't a disaster if it errs on the conservative side
(returning \tr{False}).

\begin{code}
283
manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
284

285 286 287 288 289
manifestlyBottom (Var v)     	= isBottomingId v
manifestlyBottom (Lit _)     	= False
manifestlyBottom (Con  _ _)  	= False
manifestlyBottom (Prim _ _)  	= False
manifestlyBottom (SCC _ e)   	= manifestlyBottom e
290
manifestlyBottom (Coerce _ _ e) = manifestlyBottom e
291
manifestlyBottom (Let _ e)	= manifestlyBottom e
292

293
  -- We do not assume \x.bottom == bottom:
294
manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e
295

296 297 298 299 300 301 302 303 304 305 306 307 308 309 310
manifestlyBottom (Case e a)
  = manifestlyBottom e
  || (case a of
	AlgAlts  alts def -> all mbalg  alts && mbdef def
	PrimAlts alts def -> all mbprim alts && mbdef def
     )
  where
    mbalg  (_,_,e') = manifestlyBottom e'

    mbprim (_,e')   = manifestlyBottom e'

    mbdef NoDefault          = True
    mbdef (BindDefault _ e') = manifestlyBottom e'

manifestlyBottom other_expr   -- look for manifest partial application
311
  = case (collectArgs other_expr) of { (fun, _, _, _) ->
312
    case fun of
313 314 315 316
      Var f | isBottomingId f -> True
		-- Application of a function which always gives
		-- bottom; we treat this as a WHNF, because it
		-- certainly doesn't need to be shared!
317 318 319 320 321
      _ -> False
    }
\end{code}

\begin{code}
322
{-LATER:
323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353
coreExprArity
	:: (Id -> Maybe (GenCoreExpr bndr Id))
	-> GenCoreExpr bndr Id
	-> Int
coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
coreExprArity f (CoTyApp expr _) = coreExprArity f expr
coreExprArity f (Var v) = max further info
   where
	further
	     = case f v of
		Nothing -> 0
		Just expr -> coreExprArity f expr
	info = case (arityMaybe (getIdArity v)) of
		Nothing    -> 0
		Just arity -> arity
coreExprArity f _ = 0
\end{code}

@isWrapperFor@: we want to see exactly:
\begin{verbatim}
/\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
\end{verbatim}

Probably a little too HACKY [WDP].

\begin{code}
isWrapperFor :: CoreExpr -> Id -> Bool

expr `isWrapperFor` var
354
  = case (collectBinders  expr) of { (_, _, args, body) -> -- lambdas off the front
355 356 357 358 359 360 361 362 363 364
    unravel_casing args body
    --NO, THANKS: && not (null args)
    }
  where
    var's_worker = getWorkerId (getIdStrictness var)

    is_elem = isIn "isWrapperFor"

    --------------
    unravel_casing case_ables (Case scrut alts)
365
      = case (collectArgs scrut) of { (fun, _, _, vargs) ->
366 367 368
	case fun of
	  Var scrut_var -> let
				answer =
369
				     scrut_var /= var && all (doesn't_mention var) vargs
370 371 372 373 374 375 376 377 378
				  && scrut_var `is_elem` case_ables
				  && unravel_alts case_ables alts
			     in
			     answer

	  _ -> False
	}

    unravel_casing case_ables other_expr
379
      = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
380 381 382 383 384 385
	case fun of
	  Var wrkr -> let
			    answer =
				-- DOESN'T WORK: wrkr == var's_worker
				wrkr /= var
			     && isWorkerId wrkr
386 387
			     && all (doesn't_mention var)  vargs
			     && all (only_from case_ables) vargs
388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430
			in
			answer

	  _ -> False
	}

    --------------
    unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
      = unravel_casing (params ++ case_ables) rhs
    unravel_alts case_ables other = False

    -------------------------
    doesn't_mention var (ValArg (VarArg v)) = v /= var
    doesn't_mention var other = True

    -------------------------
    only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
    only_from case_ables other = True
-}
\end{code}

All the following functions operate on binders, perform a uniform
transformation on them; ie. the function @(\ x -> (x,False))@
annotates all binders with False.

\begin{code}
unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
unTagBinders expr = bop_expr fst expr

unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
unTagBindersAlts alts = bop_alts fst alts
\end{code}

\begin{code}
bop_expr  :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv

bop_expr f (Var b)	     = Var b
bop_expr f (Lit lit)	     = Lit lit
bop_expr f (Con con args)    = Con con args
bop_expr f (Prim op args)    = Prim op args
bop_expr f (Lam binder expr) = Lam  (bop_binder f binder) (bop_expr f expr)
bop_expr f (App expr arg)    = App  (bop_expr f expr) arg
bop_expr f (SCC label expr)  = SCC  label (bop_expr f expr)
431
bop_expr f (Coerce c ty e)   = Coerce c ty (bop_expr f e)
432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484
bop_expr f (Let bind expr)   = Let  (bop_bind f bind) (bop_expr f expr)
bop_expr f (Case expr alts)  = Case (bop_expr f expr) (bop_alts f alts)

bop_binder f (ValBinder   v) = ValBinder (f v)
bop_binder f (TyBinder    t) = TyBinder    t
bop_binder f (UsageBinder u) = UsageBinder u

bop_bind f (NonRec b e)	= NonRec (f b) (bop_expr f e)
bop_bind f (Rec pairs)	= Rec [(f b, bop_expr f e) | (b, e) <- pairs]

bop_alts f (AlgAlts alts deflt)
  = AlgAlts  [ (con, [f b | b <- binders], bop_expr f e)
	     | (con, binders, e) <- alts ]
	     (bop_deflt f deflt)

bop_alts f (PrimAlts alts deflt)
  = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
    	     (bop_deflt f deflt)

bop_deflt f (NoDefault)		 = NoDefault
bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
\end{code}

OLD (but left here because of the nice example): @singleAlt@ checks
whether a bunch of case alternatives is actually just one alternative.
It specifically {\em ignores} alternatives which consist of just a
call to @error@, because they won't result in any code duplication.

Example:
\begin{verbatim}
	case (case <something> of
		True  -> <rhs>
		False -> error "Foo") of
	<alts>

===>

	case <something> of
	   True ->  case <rhs> of
		    <alts>
	   False -> case error "Foo" of
		    <alts>

===>

	case <something> of
	   True ->  case <rhs> of
		    <alts>
	   False -> error "Foo"
\end{verbatim}
Notice that the \tr{<alts>} don't get duplicated.

\begin{code}
485
nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
486

487 488
nonErrorRHSs alts
  = filter not_error_app (find_rhss alts)
489
  where
490 491
    find_rhss (AlgAlts  as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
    find_rhss (PrimAlts as deflt) = [rhs | (_,rhs)   <- as] ++ deflt_rhs deflt
492 493 494 495

    deflt_rhs NoDefault           = []
    deflt_rhs (BindDefault _ rhs) = [rhs]

496 497 498 499
    not_error_app rhs
      = case (maybeErrorApp rhs Nothing) of
	  Just _  -> False
	  Nothing -> True
500 501
\end{code}

502
maybeErrorApp checks whether an expression is of the form
503 504 505 506 507 508 509 510 511 512 513 514 515 516 517

	error ty args

If so, it returns

	Just (error ty' args)

where ty' is supplied as an argument to maybeErrorApp.

Here's where it is useful:

		case (error ty "Foo" e1 e2) of <alts>
 ===>
		error ty' "Foo"

518 519 520
where ty' is the type of any of the alternatives.  You might think
this never occurs, but see the comments on the definition of
@singleAlt@.
521

522 523
Note: we *avoid* the case where ty' might end up as a primitive type:
this is very uncool (totally wrong).
524

525 526
NOTICE: in the example above we threw away e1 and e2, but not the
string "Foo".  How did we know to do that?
527

528 529
Answer: for now anyway, we only handle the case of a function whose
type is of form
530 531 532 533

	bottomingFn :: forall a. t1 -> ... -> tn -> a
	    	    	      ^---------------------^ NB!

534 535
Furthermore, we only count a bottomingApp if the function is applied
to more than n args.  If so, we transform:
536 537 538 539 540 541 542 543

	bottomingFn ty e1 ... en en+1 ... em
to
	bottomingFn ty' e1 ... en

That is, we discard en+1 .. em

\begin{code}
544 545 546 547 548 549 550 551
maybeErrorApp
	:: GenCoreExpr a Id TyVar UVar	-- Expr to look at
	-> Maybe Type			-- Just ty => a result type *already cloned*;
					-- Nothing => don't know result ty; we
					-- *pretend* that the result ty won't be
					-- primitive -- somebody later must
					-- ensure this.
	-> Maybe (GenCoreExpr a Id TyVar UVar)
552 553

maybeErrorApp expr result_ty_maybe
554 555
  = case (collectArgs expr) of
      (Var fun, [{-no usage???-}], [ty], other_args)
556 557 558 559
	| isBottomingId fun
	&& maybeToBool result_ty_maybe -- we *know* the result type
				       -- (otherwise: live a fairy-tale existence...)
	&& not (isPrimType result_ty) ->
560 561 562 563

	case (splitSigmaTy (idType fun)) of
	  ([tyvar], [], tau_ty) ->
	      case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
564 565 566 567
	      let
		  n_args_to_keep = length arg_tys
		  args_to_keep   = take n_args_to_keep other_args
	      in
568 569
	      if  (res_ty `eqTy` mkTyVarTy tyvar)
	       && n_args_to_keep <= length other_args
570 571
	      then
		    -- Phew!  We're in business
572
		  Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
573 574 575 576
	      else
		  Nothing
	      }

577
	  other -> Nothing  -- Function type wrong shape
578 579 580 581 582 583
      other -> Nothing
  where
    Just result_ty = result_ty_maybe
\end{code}

\begin{code}
584
squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
585 586 587 588 589 590 591 592

squashableDictishCcExpr cc expr
  = if not (isDictCC cc) then
	False -- that was easy...
    else
	squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
  where
    squashable (Var _)      = True
593 594 595 596 597
    squashable (Con  _ _)   = True -- I think so... WDP 94/09
    squashable (Prim _ _)   = True -- ditto
    squashable (App f a)
      | notValArg a	    = squashable f
    squashable other	    = False
598 599 600 601 602 603 604 605 606
\end{code}

%************************************************************************
%*									*
\subsection{Core-renaming utils}
%*									*
%************************************************************************

\begin{code}
607 608 609 610 611
substCoreBindings :: ValEnv
		-> TypeEnv -- TyVar=>Type
		-> [CoreBinding]
		-> UniqSM [CoreBinding]

612 613 614 615 616
substCoreExpr	:: ValEnv
		-> TypeEnv -- TyVar=>Type
		-> CoreExpr
		-> UniqSM CoreExpr

617
substCoreBindings venv tenv binds
618
  -- if the envs are empty, then avoid doing anything
619 620 621 622 623 624
  = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
       returnUs binds
    else
       do_CoreBindings venv tenv binds

substCoreExpr venv tenv expr
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 666 667 668 669 670 671 672 673 674
  = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
       returnUs expr
    else
       do_CoreExpr venv tenv expr
\end{code}

The equiv code for @Types@ is in @TyUtils@.

Because binders aren't necessarily unique: we don't do @plusEnvs@
(which check for duplicates); rather, we use the shadowing version,
@growIdEnv@ (and shorthand @addOneToIdEnv@).

@do_CoreBindings@ takes into account the semantics of a list of
@CoreBindings@---things defined early in the list are visible later in
the list, but not vice versa.

\begin{code}
type ValEnv  = IdEnv CoreExpr

do_CoreBindings :: ValEnv
		-> TypeEnv
		-> [CoreBinding]
		-> UniqSM [CoreBinding]

do_CoreBinding :: ValEnv
	       -> TypeEnv
	       -> CoreBinding
	       -> UniqSM (CoreBinding, ValEnv)

do_CoreBindings venv tenv [] = returnUs []
do_CoreBindings venv tenv (b:bs)
  = do_CoreBinding  venv     tenv b	`thenUs` \ (new_b,  new_venv) ->
    do_CoreBindings new_venv tenv bs	`thenUs` \  new_bs ->
    returnUs (new_b : new_bs)

do_CoreBinding venv tenv (NonRec binder rhs)
  = do_CoreExpr venv tenv rhs	`thenUs` \ new_rhs ->

    dup_binder tenv binder	`thenUs` \ (new_binder, (old, new)) ->
    -- now plug new bindings into envs
    let  new_venv = addOneToIdEnv venv old new  in

    returnUs (NonRec new_binder new_rhs, new_venv)

do_CoreBinding venv tenv (Rec binds)
  = -- for letrec, we plug in new bindings BEFORE cloning rhss
    mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
    let  new_venv = growIdEnvList venv new_maps in

    mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
675
    returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
676 677 678 679 680 681 682 683
  where
    (binders, rhss) = unzip binds
\end{code}

\begin{code}
do_CoreArg :: ValEnv
	    -> TypeEnv
	    -> CoreArg
684
	    -> UniqSM CoreArgOrExpr
685

686
do_CoreArg venv tenv a@(VarArg v)
687 688
  = returnUs (
      case (lookupIdEnv venv v) of
689 690
	Nothing   -> AnArg  a
	Just expr -> AnExpr expr
691
    )
692 693 694 695 696

do_CoreArg venv tenv (TyArg ty)
  = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))

do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
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
\end{code}

\begin{code}
do_CoreExpr :: ValEnv
	    -> TypeEnv
	    -> CoreExpr
	    -> UniqSM CoreExpr

do_CoreExpr venv tenv orig_expr@(Var var)
  = returnUs (
      case (lookupIdEnv venv var) of
	Nothing	    -> --false:ASSERT(toplevelishId var) (SIGH)
		       orig_expr
	Just expr   -> expr
    )

do_CoreExpr venv tenv e@(Lit _) = returnUs e

do_CoreExpr venv tenv (Con con as)
  = mapUs  (do_CoreArg venv tenv) as `thenUs`  \ new_as ->
    mkCoCon con new_as

do_CoreExpr venv tenv (Prim op as)
  = mapUs  (do_CoreArg venv tenv) as 	`thenUs`  \ new_as ->
    do_PrimOp op			`thenUs`  \ new_op ->
    mkCoPrim new_op new_as
  where
    do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
      = let
	    new_arg_tys   = map (applyTypeEnvToTy tenv) arg_tys
	    new_result_ty = applyTypeEnvToTy tenv result_ty
	in
	returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)

    do_PrimOp other_op = returnUs other_op

733
do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
734 735 736
  = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
    let  new_venv = addOneToIdEnv venv old new  in
    do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
737 738 739 740 741 742 743 744 745 746 747
    returnUs (Lam (ValBinder new_binder) new_expr)

do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
  = dup_tyvar tyvar	   `thenUs` \ (new_tyvar, (old, new)) ->
    let
	new_tenv = addOneToTyVarEnv tenv old new
    in
    do_CoreExpr venv new_tenv expr  `thenUs` \ new_expr ->
    returnUs (Lam (TyBinder new_tyvar) new_expr)

do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder"
748 749 750 751

do_CoreExpr venv tenv (App expr arg)
  = do_CoreExpr venv tenv expr	`thenUs` \ new_expr ->
    do_CoreArg  venv tenv arg   `thenUs` \ new_arg  ->
752
    mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796

do_CoreExpr venv tenv (Case expr alts)
  = do_CoreExpr venv tenv expr	    `thenUs` \ new_expr ->
    do_alts venv tenv alts	    `thenUs` \ new_alts ->
    returnUs (Case new_expr new_alts)
  where
    do_alts venv tenv (AlgAlts alts deflt)
      = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
    	do_default venv tenv deflt	    `thenUs` \ new_deflt ->
	returnUs (AlgAlts new_alts new_deflt)
      where
	do_boxed_alt venv tenv (con, binders, expr)
	  = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
	    let  new_venv = growIdEnvList venv new_vmaps  in
	    do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
	    returnUs (con, new_binders, new_expr)


    do_alts venv tenv (PrimAlts alts deflt)
      = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
    	do_default venv tenv deflt	      `thenUs` \ new_deflt ->
	returnUs (PrimAlts new_alts new_deflt)
      where
	do_unboxed_alt venv tenv (lit, expr)
	  = do_CoreExpr venv tenv expr	`thenUs` \ new_expr ->
	    returnUs (lit, new_expr)

    do_default venv tenv NoDefault = returnUs NoDefault

    do_default venv tenv (BindDefault binder expr)
      =	dup_binder tenv binder		`thenUs` \ (new_binder, (old, new)) ->
	let  new_venv = addOneToIdEnv venv old new  in
	do_CoreExpr new_venv tenv expr	`thenUs` \ new_expr ->
	returnUs (BindDefault new_binder new_expr)

do_CoreExpr venv tenv (Let core_bind expr)
  = do_CoreBinding venv tenv core_bind	`thenUs` \ (new_bind, new_venv) ->
    -- and do the body of the let
    do_CoreExpr new_venv tenv expr  	`thenUs` \ new_expr ->
    returnUs (Let new_bind new_expr)

do_CoreExpr venv tenv (SCC label expr)
  = do_CoreExpr venv tenv expr	    	`thenUs` \ new_expr ->
    returnUs (SCC label new_expr)
797 798 799 800

do_CoreExpr venv tenv (Coerce c ty expr)
  = do_CoreExpr venv tenv expr	    	`thenUs` \ new_expr ->
    returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
801
\end{code}
802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826

\begin{code}
dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
dup_tyvar tyvar
  = getUnique			`thenUs` \ uniq ->
    let  new_tyvar = cloneTyVar tyvar uniq  in
    returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))

-- same thing all over again --------------------

dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
dup_binder tenv b
  = if (toplevelishId b) then
	-- binder is "top-level-ish"; -- it should *NOT* be renamed
	-- ToDo: it's unsavoury that we return something to heave in env
	returnUs (b, (b, Var b))

    else -- otherwise, the full business
	getUnique			    `thenUs`  \ uniq ->
	let
	    new_b1 = mkIdWithNewUniq b uniq
	    new_b2 = applyTypeEnvToId tenv new_b1
	in
	returnUs (new_b2, (b, Var new_b2))
\end{code}