2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
7 #include "HsVersions.h"
10 coreExprType, coreAltsType,
15 , mkErrorApp, escErrorMsg
17 , unTagBinders, unTagBindersAlts
18 , manifestlyWHNF, manifestlyBottom
19 {- exprSmallEnoughToDup,
24 squashableDictishCcExpr,
29 import IdLoop -- for pananoia-checking purposes
33 import CostCentre ( isDictCC )
34 import Id ( idType, mkSysLocal, getIdArity, isBottomingId,
35 addOneToIdEnv, growIdEnvList, lookupIdEnv,
36 isNullIdEnv, IdEnv(..),
39 import IdInfo ( arityMaybe )
40 import Literal ( literalType, isNoRepLit, Literal(..) )
41 import Maybes ( catMaybes )
42 import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} )
43 import PprStyle ( PprStyle(..) )
44 import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
45 import Pretty ( ppAboves )
46 import PrelInfo ( trueDataCon, falseDataCon,
50 import PrimOp ( primOpType, PrimOp(..) )
51 import SrcLoc ( mkUnknownSrcLoc )
52 import TyVar ( isNullTyVarEnv, TyVarEnv(..), GenTyVar{-instances-} )
53 import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy,
54 getFunTy_maybe, applyTy, splitSigmaTy
56 import Unique ( Unique{-instances-} )
57 import UniqSupply ( initUs, returnUs, thenUs,
59 UniqSM(..), UniqSupply
61 import Util ( zipEqual, panic, pprPanic, assertPanic )
63 type TypeEnv = TyVarEnv Type
64 applyUsage = panic "CoreUtils.applyUsage:ToDo"
65 dup_binder = panic "CoreUtils.dup_binder"
66 applyTypeEnvToTy = panic "CoreUtils.applyTypeEnvToTy"
69 %************************************************************************
71 \subsection{Find the type of a Core atom/expression}
73 %************************************************************************
76 coreExprType :: CoreExpr -> Type
78 coreExprType (Var var) = idType var
79 coreExprType (Lit lit) = literalType lit
81 coreExprType (Let _ body) = coreExprType body
82 coreExprType (SCC _ expr) = coreExprType expr
83 coreExprType (Case _ alts) = coreAltsType alts
85 -- a Con is a fully-saturated application of a data constructor
86 -- a Prim is <ditto> of a PrimOp
88 coreExprType (Con con args) = applyTypeToArgs (idType con) args
89 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
91 coreExprType (Lam (ValBinder binder) expr)
92 = mkFunTys [idType binder] (coreExprType expr)
94 coreExprType (Lam (TyBinder tyvar) expr)
95 = mkForAllTy tyvar (coreExprType expr)
97 coreExprType (Lam (UsageBinder uvar) expr)
98 = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
100 coreExprType (App expr (TyArg ty))
101 = applyTy (coreExprType expr) ty
103 coreExprType (App expr (UsageArg use))
104 = applyUsage (coreExprType expr) use
106 coreExprType (App expr val_arg)
107 = ASSERT(isValArg val_arg)
109 fun_ty = coreExprType expr
111 case (getFunTy_maybe fun_ty) of
112 Just (_, result_ty) -> result_ty
114 Nothing -> pprPanic "coreExprType:\n"
115 (ppAboves [ppr PprDebug fun_ty,
116 ppr PprShowAll (App expr val_arg)])
121 coreAltsType :: CoreCaseAlts -> Type
123 coreAltsType (AlgAlts [] deflt) = default_ty deflt
124 coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
126 coreAltsType (PrimAlts [] deflt) = default_ty deflt
127 coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
129 default_ty NoDefault = panic "coreExprType:Case:default_ty"
130 default_ty (BindDefault _ rhs) = coreExprType rhs
134 applyTypeToArgs = panic "applyTypeToArgs"
137 %************************************************************************
139 \subsection{Routines to manufacture bits of @CoreExpr@}
141 %************************************************************************
144 mkCoreIfThenElse (Var bool) then_expr else_expr
145 | bool == trueDataCon = then_expr
146 | bool == falseDataCon = else_expr
148 mkCoreIfThenElse guard then_expr else_expr
150 (AlgAlts [ (trueDataCon, [], then_expr),
151 (falseDataCon, [], else_expr) ]
156 mkErrorApp :: Type -> Id -> String -> CoreExpr
158 mkErrorApp ty str_var error_msg
159 = Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) (
160 mkApp (Var pAT_ERROR_ID) [] [ty] [VarArg str_var])
163 escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
164 escErrorMsg (x:xs) = x : escErrorMsg xs
167 For making @Apps@ and @Lets@, we must take appropriate evasive
168 action if the thing being bound has unboxed type. @mkCoApp@ requires
169 a name supply to do its work. Other-monad code will call @mkCoApp@
170 through its own interface function (e.g., the desugarer uses
173 @mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the
174 arguments-must-be-atoms constraint.
178 --mkCoApp :: CoreExpr -> CoreExpr -> UniqSM CoreExpr
180 mkCoApp e1 (Var v) = returnUs (App e1 (VarArg v))
181 mkCoApp e1 (Lit l) = returnUs (App e1 (LitArg l))
184 e2_ty = coreExprType e2
186 panic "getUnique" `thenUs` \ uniq ->
188 new_var = mkSysLocal SLIT("a") uniq e2_ty mkUnknownSrcLoc
191 mkCoLetUnboxedToCase (NonRec new_var e2)
192 (App e1 (VarArg new_var))
199 mkCoCon :: Id -> [CoreExpr] -> UniqSM CoreExpr
200 mkCoPrim :: PrimOp -> [CoreExpr] -> UniqSM CoreExpr
202 mkCoCon con args = mkCoThing (Con con) args
203 mkCoPrim op args = mkCoThing (Prim op) args
205 mkCoThing thing arg_exprs
206 = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
207 returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
209 expr_to_arg :: CoreExpr
210 -> UniqSM (CoreArg, Maybe CoreBinding)
212 expr_to_arg (Var v) = returnUs (VarArg v, Nothing)
213 expr_to_arg (Lit l) = returnUs (LitArg l, Nothing)
214 expr_to_arg other_expr
216 e_ty = coreExprType other_expr
218 panic "getUnique" `thenUs` \ uniq ->
220 new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
221 new_atom = VarArg new_var
223 returnUs (new_atom, Just (NonRec new_var other_expr))
229 GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
231 argToExpr (VarArg v) = Var v
232 argToExpr (LitArg lit) = Lit lit
238 -- GenCoreExpr val_bdr val_occ tyvar uvar ->
239 -- [GenCoreExpr val_bdr val_occ tyvar uvar] ->
240 -- UniqSM(GenCoreExpr val_bdr val_occ tyvar uvar)
242 mkCoApps fun [] = returnUs fun
243 mkCoApps fun (arg:args)
244 = mkCoApp fun arg `thenUs` \ new_fun ->
245 mkCoApps new_fun args
249 exprSmallEnoughToDup :: GenCoreExpr binder Id -> Bool
251 exprSmallEnoughToDup (Con _ _ _) = True -- Could check # of args
252 exprSmallEnoughToDup (Prim op _ _) = not (fragilePrimOp op) -- Could check # of args
253 exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
255 exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
256 = case (collectArgs expr) of { (fun, args) ->
258 Var v -> v /= buildId
260 && length args <= 6 -- or 10 or 1 or 4 or anything smallish.
265 Question (ADR): What is the above used for? Is a _ccall_ really small
268 @manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
269 it is obviously in weak head normal form. It isn't a disaster if it
270 errs on the conservative side (returning \tr{False})---I've probably
271 left something out... [WDP]
274 manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool
276 manifestlyWHNF (Var _) = True
277 manifestlyWHNF (Lit _) = True
278 manifestlyWHNF (Con _ _) = True
279 manifestlyWHNF (SCC _ e) = manifestlyWHNF e
280 manifestlyWHNF (Let _ e) = False
281 manifestlyWHNF (Case _ _) = False
283 manifestlyWHNF (Lam (ValBinder _) _) = True
284 manifestlyWHNF (Lam other_binder e) = manifestlyWHNF e
286 manifestlyWHNF other_expr -- look for manifest partial application
287 = case (collectArgs other_expr) of { (fun, args) ->
290 num_val_args = numValArgs args
292 num_val_args == 0 -- Just a type application of
293 -- a variable (f t1 t2 t3);
296 case (arityMaybe (getIdArity f)) of
298 Just arity -> num_val_args < arity
304 @manifestlyBottom@ looks at a Core expression and returns \tr{True} if
305 it is obviously bottom, that is, it will certainly return bottom at
306 some point. It isn't a disaster if it errs on the conservative side
307 (returning \tr{False}).
310 manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
312 manifestlyBottom (Var v) = isBottomingId v
313 manifestlyBottom (Lit _) = False
314 manifestlyBottom (Con _ _) = False
315 manifestlyBottom (Prim _ _) = False
316 manifestlyBottom (SCC _ e) = manifestlyBottom e
317 manifestlyBottom (Let _ e) = manifestlyBottom e
319 -- We do not assume \x.bottom == bottom:
320 manifestlyBottom (Lam (ValBinder _) _) = False
321 manifestlyBottom (Lam other_binder e) = manifestlyBottom e
323 manifestlyBottom (Case e a)
326 AlgAlts alts def -> all mbalg alts && mbdef def
327 PrimAlts alts def -> all mbprim alts && mbdef def
330 mbalg (_,_,e') = manifestlyBottom e'
332 mbprim (_,e') = manifestlyBottom e'
334 mbdef NoDefault = True
335 mbdef (BindDefault _ e') = manifestlyBottom e'
337 manifestlyBottom other_expr -- look for manifest partial application
338 = case (collectArgs other_expr) of { (fun, args) ->
340 Var f | isBottomingId f -> True
341 -- Application of a function which always gives
342 -- bottom; we treat this as a WHNF, because it
343 -- certainly doesn't need to be shared!
351 :: (Id -> Maybe (GenCoreExpr bndr Id))
352 -> GenCoreExpr bndr Id
354 coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
355 coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
356 coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
357 coreExprArity f (CoTyApp expr _) = coreExprArity f expr
358 coreExprArity f (Var v) = max further info
363 Just expr -> coreExprArity f expr
364 info = case (arityMaybe (getIdArity v)) of
367 coreExprArity f _ = 0
370 @isWrapperFor@: we want to see exactly:
372 /\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
375 Probably a little too HACKY [WDP].
378 isWrapperFor :: CoreExpr -> Id -> Bool
380 expr `isWrapperFor` var
381 = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front
382 unravel_casing args body
383 --NO, THANKS: && not (null args)
386 var's_worker = getWorkerId (getIdStrictness var)
388 is_elem = isIn "isWrapperFor"
391 unravel_casing case_ables (Case scrut alts)
392 = case (collectArgs scrut) of { (fun, args) ->
396 scrut_var /= var && all (doesn't_mention var) args
397 && scrut_var `is_elem` case_ables
398 && unravel_alts case_ables alts
405 unravel_casing case_ables other_expr
406 = case (collectArgs other_expr) of { (fun, args) ->
410 -- DOESN'T WORK: wrkr == var's_worker
413 && all (doesn't_mention var) args
414 && all (only_from case_ables) args
422 unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
423 = unravel_casing (params ++ case_ables) rhs
424 unravel_alts case_ables other = False
426 -------------------------
427 doesn't_mention var (ValArg (VarArg v)) = v /= var
428 doesn't_mention var other = True
430 -------------------------
431 only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
432 only_from case_ables other = True
436 All the following functions operate on binders, perform a uniform
437 transformation on them; ie. the function @(\ x -> (x,False))@
438 annotates all binders with False.
441 unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
442 unTagBinders expr = bop_expr fst expr
444 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
445 unTagBindersAlts alts = bop_alts fst alts
449 bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
451 bop_expr f (Var b) = Var b
452 bop_expr f (Lit lit) = Lit lit
453 bop_expr f (Con con args) = Con con args
454 bop_expr f (Prim op args) = Prim op args
455 bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
456 bop_expr f (App expr arg) = App (bop_expr f expr) arg
457 bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
458 bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
459 bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
461 bop_binder f (ValBinder v) = ValBinder (f v)
462 bop_binder f (TyBinder t) = TyBinder t
463 bop_binder f (UsageBinder u) = UsageBinder u
465 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
466 bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
468 bop_alts f (AlgAlts alts deflt)
469 = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
470 | (con, binders, e) <- alts ]
473 bop_alts f (PrimAlts alts deflt)
474 = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
477 bop_deflt f (NoDefault) = NoDefault
478 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
481 OLD (but left here because of the nice example): @singleAlt@ checks
482 whether a bunch of case alternatives is actually just one alternative.
483 It specifically {\em ignores} alternatives which consist of just a
484 call to @error@, because they won't result in any code duplication.
488 case (case <something> of
490 False -> error "Foo") of
496 True -> case <rhs> of
498 False -> case error "Foo" of
504 True -> case <rhs> of
508 Notice that the \tr{<alts>} don't get duplicated.
512 nonErrorRHSs :: GenCoreCaseAlts binder Id -> [GenCoreExpr binder Id]
514 nonErrorRHSs alts = filter not_error_app (find_rhss alts)
516 find_rhss (AlgAlts alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt
517 find_rhss (PrimAlts alts deflt) = [rhs | (_,rhs) <- alts] ++ deflt_rhs deflt
519 deflt_rhs NoDefault = []
520 deflt_rhs (BindDefault _ rhs) = [rhs]
522 not_error_app rhs = case maybeErrorApp rhs Nothing of
527 maybeErrorApp checkes whether an expression is of the form
533 Just (error ty' args)
535 where ty' is supplied as an argument to maybeErrorApp.
537 Here's where it is useful:
539 case (error ty "Foo" e1 e2) of <alts>
543 where ty' is the type of any of the alternatives.
544 You might think this never occurs, but see the comments on
545 the definition of @singleAlt@.
547 Note: we *avoid* the case where ty' might end up as a
548 primitive type: this is very uncool (totally wrong).
550 NOTICE: in the example above we threw away e1 and e2, but
551 not the string "Foo". How did we know to do that?
553 Answer: for now anyway, we only handle the case of a function
554 whose type is of form
556 bottomingFn :: forall a. t1 -> ... -> tn -> a
557 ^---------------------^ NB!
559 Furthermore, we only count a bottomingApp if the function is
560 applied to more than n args. If so, we transform:
562 bottomingFn ty e1 ... en en+1 ... em
564 bottomingFn ty' e1 ... en
566 That is, we discard en+1 .. em
569 maybeErrorApp :: GenCoreExpr bndr Id -- Expr to look at
570 -> Maybe Type -- Just ty => a result type *already cloned*;
571 -- Nothing => don't know result ty; we
572 -- *pretend* that the result ty won't be
573 -- primitive -- somebody later must
575 -> Maybe (GenCoreExpr bndr Id)
577 maybeErrorApp expr result_ty_maybe
578 = case collectArgs expr of
579 (Var fun, (TypeArg ty : other_args))
581 && maybeToBool result_ty_maybe -- we *know* the result type
582 -- (otherwise: live a fairy-tale existence...)
583 && not (isPrimType result_ty) ->
584 case splitSigmaTy (idType fun) of
585 ([tyvar_tmpl], [], tau_ty) ->
586 case (splitTyArgs tau_ty) of { (arg_tys, res_ty) ->
588 n_args_to_keep = length arg_tys
589 args_to_keep = take n_args_to_keep other_args
591 if res_ty == mkTyVarTemplateTy tyvar_tmpl &&
592 n_args_to_keep <= length other_args
594 -- Phew! We're in business
595 Just (mkGenApp (Var fun)
596 (TypeArg result_ty : args_to_keep))
601 other -> -- Function type wrong shape
605 Just result_ty = result_ty_maybe
609 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b -> Bool
611 squashableDictishCcExpr cc expr
612 = if not (isDictCC cc) then
613 False -- that was easy...
615 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
617 squashable (Var _) = True
618 squashable (CoTyApp f _) = squashable f
619 squashable (Con _ _ _) = True -- I think so... WDP 94/09
620 squashable (Prim _ _ _) = True -- ditto
621 squashable other = False
625 %************************************************************************
627 \subsection{Core-renaming utils}
629 %************************************************************************
632 substCoreExpr :: ValEnv
633 -> TypeEnv -- TyVar=>Type
637 substCoreExpr venv tenv expr
638 -- if the envs are empty, then avoid doing anything
639 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
642 do_CoreExpr venv tenv expr
645 The equiv code for @Types@ is in @TyUtils@.
647 Because binders aren't necessarily unique: we don't do @plusEnvs@
648 (which check for duplicates); rather, we use the shadowing version,
649 @growIdEnv@ (and shorthand @addOneToIdEnv@).
651 @do_CoreBindings@ takes into account the semantics of a list of
652 @CoreBindings@---things defined early in the list are visible later in
653 the list, but not vice versa.
656 type ValEnv = IdEnv CoreExpr
658 do_CoreBindings :: ValEnv
661 -> UniqSM [CoreBinding]
663 do_CoreBinding :: ValEnv
666 -> UniqSM (CoreBinding, ValEnv)
668 do_CoreBindings venv tenv [] = returnUs []
669 do_CoreBindings venv tenv (b:bs)
670 = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
671 do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
672 returnUs (new_b : new_bs)
674 do_CoreBinding venv tenv (NonRec binder rhs)
675 = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
677 dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
678 -- now plug new bindings into envs
679 let new_venv = addOneToIdEnv venv old new in
681 returnUs (NonRec new_binder new_rhs, new_venv)
683 do_CoreBinding venv tenv (Rec binds)
684 = -- for letrec, we plug in new bindings BEFORE cloning rhss
685 mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
686 let new_venv = growIdEnvList venv new_maps in
688 mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
689 returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv)
691 (binders, rhss) = unzip binds
700 do_CoreArg venv tenv (LitArg lit) = returnUs (Lit lit)
701 do_CoreArg venv tenv (TyArg ty) = panic "do_CoreArg: TyArg"
702 do_CoreArg venv tenv (UsageArg usage) = panic "do_CoreArg: UsageArg"
703 do_CoreArg venv tenv (VarArg v)
705 case (lookupIdEnv venv v) of
706 Nothing -> --false:ASSERT(toplevelishId v)
713 do_CoreExpr :: ValEnv
718 do_CoreExpr venv tenv orig_expr@(Var var)
720 case (lookupIdEnv venv var) of
721 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
726 do_CoreExpr venv tenv e@(Lit _) = returnUs e
728 do_CoreExpr venv tenv (Con con as)
729 = panic "CoreUtils.do_CoreExpr:Con"
731 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
735 do_CoreExpr venv tenv (Prim op as)
736 = panic "CoreUtils.do_CoreExpr:Prim"
738 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
739 do_PrimOp op `thenUs` \ new_op ->
740 mkCoPrim new_op new_as
742 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
744 new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
745 new_result_ty = applyTypeEnvToTy tenv result_ty
747 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
749 do_PrimOp other_op = returnUs other_op
752 do_CoreExpr venv tenv (Lam binder expr)
753 = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
754 let new_venv = addOneToIdEnv venv old new in
755 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
756 returnUs (Lam new_binder new_expr)
758 do_CoreExpr venv tenv (App expr arg)
759 = panic "CoreUtils.do_CoreExpr:App"
761 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
762 do_CoreArg venv tenv arg `thenUs` \ new_arg ->
763 mkCoApp new_expr new_arg
766 do_CoreExpr venv tenv (Case expr alts)
767 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
768 do_alts venv tenv alts `thenUs` \ new_alts ->
769 returnUs (Case new_expr new_alts)
771 do_alts venv tenv (AlgAlts alts deflt)
772 = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
773 do_default venv tenv deflt `thenUs` \ new_deflt ->
774 returnUs (AlgAlts new_alts new_deflt)
776 do_boxed_alt venv tenv (con, binders, expr)
777 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
778 let new_venv = growIdEnvList venv new_vmaps in
779 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
780 returnUs (con, new_binders, new_expr)
783 do_alts venv tenv (PrimAlts alts deflt)
784 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
785 do_default venv tenv deflt `thenUs` \ new_deflt ->
786 returnUs (PrimAlts new_alts new_deflt)
788 do_unboxed_alt venv tenv (lit, expr)
789 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
790 returnUs (lit, new_expr)
792 do_default venv tenv NoDefault = returnUs NoDefault
794 do_default venv tenv (BindDefault binder expr)
795 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
796 let new_venv = addOneToIdEnv venv old new in
797 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
798 returnUs (BindDefault new_binder new_expr)
800 do_CoreExpr venv tenv (Let core_bind expr)
801 = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
802 -- and do the body of the let
803 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
804 returnUs (Let new_bind new_expr)
806 do_CoreExpr venv tenv (SCC label expr)
807 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
808 returnUs (SCC label new_expr)