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,
12 substCoreExpr, substCoreBindings
16 , unTagBinders, unTagBindersAlts
17 , manifestlyWHNF, manifestlyBottom
20 , squashableDictishCcExpr
21 , exprSmallEnoughToDup
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, maybeToBool )
42 import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} )
43 import PprStyle ( PprStyle(..) )
44 import PprType ( GenType{-instances-} )
45 import Pretty ( ppAboves )
46 import PrelInfo ( trueDataCon, falseDataCon,
49 import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) )
50 import SrcLoc ( mkUnknownSrcLoc )
51 import TyVar ( isNullTyVarEnv, TyVarEnv(..) )
52 import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
53 getFunTy_maybe, applyTy, isPrimType,
54 splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
56 import UniqSupply ( initUs, returnUs, thenUs,
57 mapUs, mapAndUnzipUs, getUnique,
58 UniqSM(..), UniqSupply
60 import Usage ( UVar(..) )
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"
68 %************************************************************************
70 \subsection{Find the type of a Core atom/expression}
72 %************************************************************************
75 coreExprType :: CoreExpr -> Type
77 coreExprType (Var var) = idType var
78 coreExprType (Lit lit) = literalType lit
80 coreExprType (Let _ body) = coreExprType body
81 coreExprType (SCC _ expr) = coreExprType expr
82 coreExprType (Case _ alts) = coreAltsType alts
84 coreExprType (Coerce _ ty _) = ty -- that's the whole point!
86 -- a Con is a fully-saturated application of a data constructor
87 -- a Prim is <ditto> of a PrimOp
89 coreExprType (Con con args) = applyTypeToArgs (idType con) args
90 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
92 coreExprType (Lam (ValBinder binder) expr)
93 = mkFunTys [idType binder] (coreExprType expr)
95 coreExprType (Lam (TyBinder tyvar) expr)
96 = mkForAllTy tyvar (coreExprType expr)
98 coreExprType (Lam (UsageBinder uvar) expr)
99 = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
101 coreExprType (App expr (TyArg ty))
102 = applyTy (coreExprType expr) ty
104 coreExprType (App expr (UsageArg use))
105 = applyUsage (coreExprType expr) use
107 coreExprType (App expr val_arg)
108 = ASSERT(isValArg val_arg)
110 fun_ty = coreExprType expr
112 case (getFunTy_maybe fun_ty) of
113 Just (_, result_ty) -> result_ty
115 Nothing -> pprPanic "coreExprType:\n"
116 (ppAboves [ppr PprDebug fun_ty,
117 ppr PprShowAll (App expr val_arg)])
122 coreAltsType :: CoreCaseAlts -> Type
124 coreAltsType (AlgAlts [] deflt) = default_ty deflt
125 coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
127 coreAltsType (PrimAlts [] deflt) = default_ty deflt
128 coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
130 default_ty NoDefault = panic "coreExprType:Case:default_ty"
131 default_ty (BindDefault _ rhs) = coreExprType rhs
135 applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args
137 applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
138 applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg"
139 applyTypeToArg op_ty val_or_lit_arg = case (getFunTy_maybe op_ty) of
140 Just (_, res_ty) -> res_ty
143 %************************************************************************
145 \subsection{Routines to manufacture bits of @CoreExpr@}
147 %************************************************************************
150 mkCoreIfThenElse (Var bool) then_expr else_expr
151 | bool == trueDataCon = then_expr
152 | bool == falseDataCon = else_expr
154 mkCoreIfThenElse guard then_expr else_expr
156 (AlgAlts [ (trueDataCon, [], then_expr),
157 (falseDataCon, [], else_expr) ]
161 For making @Apps@ and @Lets@, we must take appropriate evasive
162 action if the thing being bound has unboxed type. @mkCoApp@ requires
163 a name supply to do its work.
165 @mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
166 arguments-must-be-atoms constraint.
173 mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
174 mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
175 mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
177 mkCoApps fun args = co_thing (mkGenApp fun) args
178 mkCoCon con args = co_thing (Con con) args
179 mkCoPrim op args = co_thing (Prim op) args
181 co_thing :: ([CoreArg] -> CoreExpr)
185 co_thing thing arg_exprs
186 = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
187 returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
189 expr_to_arg :: CoreArgOrExpr
190 -> UniqSM (CoreArg, Maybe CoreBinding)
192 expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
193 expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
194 expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
195 expr_to_arg (AnExpr other_expr)
197 e_ty = coreExprType other_expr
199 getUnique `thenUs` \ uniq ->
201 new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
203 returnUs (VarArg new_var, Just (NonRec new_var other_expr))
208 GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
210 argToExpr (VarArg v) = Var v
211 argToExpr (LitArg lit) = Lit lit
215 exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
216 exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
217 exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
218 exprSmallEnoughToDup expr
219 = case (collectArgs expr) of { (fun, _, _, vargs) ->
221 Var v | length vargs == 0 -> True
227 exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
228 = case (collectArgs expr) of { (fun, _, _, vargs) ->
230 Var v -> v /= buildId
232 && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
237 Question (ADR): What is the above used for? Is a _ccall_ really small
240 @manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
241 it is obviously in weak head normal form. It isn't a disaster if it
242 errs on the conservative side (returning \tr{False})---I've probably
243 left something out... [WDP]
246 manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool
248 manifestlyWHNF (Var _) = True
249 manifestlyWHNF (Lit _) = True
250 manifestlyWHNF (Con _ _) = True
251 manifestlyWHNF (SCC _ e) = manifestlyWHNF e
252 manifestlyWHNF (Coerce _ _ e) = _trace "manifestlyWHNF:Coerce" $ manifestlyWHNF e
253 manifestlyWHNF (Let _ e) = False
254 manifestlyWHNF (Case _ _) = False
256 manifestlyWHNF (Lam x e) = if isValBinder x then True else manifestlyWHNF e
258 manifestlyWHNF other_expr -- look for manifest partial application
259 = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
262 num_val_args = length vargs
264 num_val_args == 0 -- Just a type application of
265 -- a variable (f t1 t2 t3);
268 case (arityMaybe (getIdArity f)) of
270 Just arity -> num_val_args < arity
276 @manifestlyBottom@ looks at a Core expression and returns \tr{True} if
277 it is obviously bottom, that is, it will certainly return bottom at
278 some point. It isn't a disaster if it errs on the conservative side
279 (returning \tr{False}).
282 manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
284 manifestlyBottom (Var v) = isBottomingId v
285 manifestlyBottom (Lit _) = False
286 manifestlyBottom (Con _ _) = False
287 manifestlyBottom (Prim _ _) = False
288 manifestlyBottom (SCC _ e) = manifestlyBottom e
289 manifestlyBottom (Coerce _ _ e) = _trace "manifestlyBottom:Coerce" $ manifestlyBottom e
290 manifestlyBottom (Let _ e) = manifestlyBottom e
292 -- We do not assume \x.bottom == bottom:
293 manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e
295 manifestlyBottom (Case e a)
298 AlgAlts alts def -> all mbalg alts && mbdef def
299 PrimAlts alts def -> all mbprim alts && mbdef def
302 mbalg (_,_,e') = manifestlyBottom e'
304 mbprim (_,e') = manifestlyBottom e'
306 mbdef NoDefault = True
307 mbdef (BindDefault _ e') = manifestlyBottom e'
309 manifestlyBottom other_expr -- look for manifest partial application
310 = case (collectArgs other_expr) of { (fun, _, _, _) ->
312 Var f | isBottomingId f -> True
313 -- Application of a function which always gives
314 -- bottom; we treat this as a WHNF, because it
315 -- certainly doesn't need to be shared!
323 :: (Id -> Maybe (GenCoreExpr bndr Id))
324 -> GenCoreExpr bndr Id
326 coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
327 coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
328 coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
329 coreExprArity f (CoTyApp expr _) = coreExprArity f expr
330 coreExprArity f (Var v) = max further info
335 Just expr -> coreExprArity f expr
336 info = case (arityMaybe (getIdArity v)) of
339 coreExprArity f _ = 0
342 @isWrapperFor@: we want to see exactly:
344 /\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
347 Probably a little too HACKY [WDP].
350 isWrapperFor :: CoreExpr -> Id -> Bool
352 expr `isWrapperFor` var
353 = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front
354 unravel_casing args body
355 --NO, THANKS: && not (null args)
358 var's_worker = getWorkerId (getIdStrictness var)
360 is_elem = isIn "isWrapperFor"
363 unravel_casing case_ables (Case scrut alts)
364 = case (collectArgs scrut) of { (fun, _, _, vargs) ->
368 scrut_var /= var && all (doesn't_mention var) vargs
369 && scrut_var `is_elem` case_ables
370 && unravel_alts case_ables alts
377 unravel_casing case_ables other_expr
378 = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
382 -- DOESN'T WORK: wrkr == var's_worker
385 && all (doesn't_mention var) vargs
386 && all (only_from case_ables) vargs
394 unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
395 = unravel_casing (params ++ case_ables) rhs
396 unravel_alts case_ables other = False
398 -------------------------
399 doesn't_mention var (ValArg (VarArg v)) = v /= var
400 doesn't_mention var other = True
402 -------------------------
403 only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
404 only_from case_ables other = True
408 All the following functions operate on binders, perform a uniform
409 transformation on them; ie. the function @(\ x -> (x,False))@
410 annotates all binders with False.
413 unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
414 unTagBinders expr = bop_expr fst expr
416 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
417 unTagBindersAlts alts = bop_alts fst alts
421 bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
423 bop_expr f (Var b) = Var b
424 bop_expr f (Lit lit) = Lit lit
425 bop_expr f (Con con args) = Con con args
426 bop_expr f (Prim op args) = Prim op args
427 bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
428 bop_expr f (App expr arg) = App (bop_expr f expr) arg
429 bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
430 bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
431 bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
432 bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
434 bop_binder f (ValBinder v) = ValBinder (f v)
435 bop_binder f (TyBinder t) = TyBinder t
436 bop_binder f (UsageBinder u) = UsageBinder u
438 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
439 bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
441 bop_alts f (AlgAlts alts deflt)
442 = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
443 | (con, binders, e) <- alts ]
446 bop_alts f (PrimAlts alts deflt)
447 = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
450 bop_deflt f (NoDefault) = NoDefault
451 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
454 OLD (but left here because of the nice example): @singleAlt@ checks
455 whether a bunch of case alternatives is actually just one alternative.
456 It specifically {\em ignores} alternatives which consist of just a
457 call to @error@, because they won't result in any code duplication.
461 case (case <something> of
463 False -> error "Foo") of
469 True -> case <rhs> of
471 False -> case error "Foo" of
477 True -> case <rhs> of
481 Notice that the \tr{<alts>} don't get duplicated.
484 nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
487 = filter not_error_app (find_rhss alts)
489 find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
490 find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
492 deflt_rhs NoDefault = []
493 deflt_rhs (BindDefault _ rhs) = [rhs]
496 = case (maybeErrorApp rhs Nothing) of
501 maybeErrorApp checks whether an expression is of the form
507 Just (error ty' args)
509 where ty' is supplied as an argument to maybeErrorApp.
511 Here's where it is useful:
513 case (error ty "Foo" e1 e2) of <alts>
517 where ty' is the type of any of the alternatives. You might think
518 this never occurs, but see the comments on the definition of
521 Note: we *avoid* the case where ty' might end up as a primitive type:
522 this is very uncool (totally wrong).
524 NOTICE: in the example above we threw away e1 and e2, but not the
525 string "Foo". How did we know to do that?
527 Answer: for now anyway, we only handle the case of a function whose
530 bottomingFn :: forall a. t1 -> ... -> tn -> a
531 ^---------------------^ NB!
533 Furthermore, we only count a bottomingApp if the function is applied
534 to more than n args. If so, we transform:
536 bottomingFn ty e1 ... en en+1 ... em
538 bottomingFn ty' e1 ... en
540 That is, we discard en+1 .. em
544 :: GenCoreExpr a Id TyVar UVar -- Expr to look at
545 -> Maybe Type -- Just ty => a result type *already cloned*;
546 -- Nothing => don't know result ty; we
547 -- *pretend* that the result ty won't be
548 -- primitive -- somebody later must
550 -> Maybe (GenCoreExpr a Id TyVar UVar)
552 maybeErrorApp expr result_ty_maybe
553 = case (collectArgs expr) of
554 (Var fun, [{-no usage???-}], [ty], other_args)
556 && maybeToBool result_ty_maybe -- we *know* the result type
557 -- (otherwise: live a fairy-tale existence...)
558 && not (isPrimType result_ty) ->
560 case (splitSigmaTy (idType fun)) of
561 ([tyvar], [], tau_ty) ->
562 case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
564 n_args_to_keep = length arg_tys
565 args_to_keep = take n_args_to_keep other_args
567 if (res_ty `eqTy` mkTyVarTy tyvar)
568 && n_args_to_keep <= length other_args
570 -- Phew! We're in business
571 Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
576 other -> Nothing -- Function type wrong shape
579 Just result_ty = result_ty_maybe
583 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
585 squashableDictishCcExpr cc expr
586 = if not (isDictCC cc) then
587 False -- that was easy...
589 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
591 squashable (Var _) = True
592 squashable (Con _ _) = True -- I think so... WDP 94/09
593 squashable (Prim _ _) = True -- ditto
595 | notValArg a = squashable f
596 squashable other = False
599 %************************************************************************
601 \subsection{Core-renaming utils}
603 %************************************************************************
606 substCoreBindings :: ValEnv
607 -> TypeEnv -- TyVar=>Type
609 -> UniqSM [CoreBinding]
611 substCoreExpr :: ValEnv
612 -> TypeEnv -- TyVar=>Type
616 substCoreBindings venv tenv binds
617 -- if the envs are empty, then avoid doing anything
618 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
621 do_CoreBindings venv tenv binds
623 substCoreExpr venv tenv expr
624 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
627 do_CoreExpr venv tenv expr
630 The equiv code for @Types@ is in @TyUtils@.
632 Because binders aren't necessarily unique: we don't do @plusEnvs@
633 (which check for duplicates); rather, we use the shadowing version,
634 @growIdEnv@ (and shorthand @addOneToIdEnv@).
636 @do_CoreBindings@ takes into account the semantics of a list of
637 @CoreBindings@---things defined early in the list are visible later in
638 the list, but not vice versa.
641 type ValEnv = IdEnv CoreExpr
643 do_CoreBindings :: ValEnv
646 -> UniqSM [CoreBinding]
648 do_CoreBinding :: ValEnv
651 -> UniqSM (CoreBinding, ValEnv)
653 do_CoreBindings venv tenv [] = returnUs []
654 do_CoreBindings venv tenv (b:bs)
655 = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
656 do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
657 returnUs (new_b : new_bs)
659 do_CoreBinding venv tenv (NonRec binder rhs)
660 = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
662 dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
663 -- now plug new bindings into envs
664 let new_venv = addOneToIdEnv venv old new in
666 returnUs (NonRec new_binder new_rhs, new_venv)
668 do_CoreBinding venv tenv (Rec binds)
669 = -- for letrec, we plug in new bindings BEFORE cloning rhss
670 mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
671 let new_venv = growIdEnvList venv new_maps in
673 mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
674 returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv)
676 (binders, rhss) = unzip binds
683 -> UniqSM CoreArgOrExpr
685 do_CoreArg venv tenv a@(VarArg v)
687 case (lookupIdEnv venv v) of
689 Just expr -> AnExpr expr
692 do_CoreArg venv tenv (TyArg ty)
693 = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
695 do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
699 do_CoreExpr :: ValEnv
704 do_CoreExpr venv tenv orig_expr@(Var var)
706 case (lookupIdEnv venv var) of
707 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
712 do_CoreExpr venv tenv e@(Lit _) = returnUs e
714 do_CoreExpr venv tenv (Con con as)
715 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
718 do_CoreExpr venv tenv (Prim op as)
719 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
720 do_PrimOp op `thenUs` \ new_op ->
721 mkCoPrim new_op new_as
723 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
725 new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
726 new_result_ty = applyTypeEnvToTy tenv result_ty
728 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
730 do_PrimOp other_op = returnUs other_op
732 do_CoreExpr venv tenv (Lam binder expr)
733 = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
734 let new_venv = addOneToIdEnv venv old new in
735 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
736 returnUs (Lam new_binder new_expr)
738 do_CoreExpr venv tenv (App expr arg)
739 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
740 do_CoreArg venv tenv arg `thenUs` \ new_arg ->
741 mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
743 do_CoreExpr venv tenv (Case expr alts)
744 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
745 do_alts venv tenv alts `thenUs` \ new_alts ->
746 returnUs (Case new_expr new_alts)
748 do_alts venv tenv (AlgAlts alts deflt)
749 = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
750 do_default venv tenv deflt `thenUs` \ new_deflt ->
751 returnUs (AlgAlts new_alts new_deflt)
753 do_boxed_alt venv tenv (con, binders, expr)
754 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
755 let new_venv = growIdEnvList venv new_vmaps in
756 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
757 returnUs (con, new_binders, new_expr)
760 do_alts venv tenv (PrimAlts alts deflt)
761 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
762 do_default venv tenv deflt `thenUs` \ new_deflt ->
763 returnUs (PrimAlts new_alts new_deflt)
765 do_unboxed_alt venv tenv (lit, expr)
766 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
767 returnUs (lit, new_expr)
769 do_default venv tenv NoDefault = returnUs NoDefault
771 do_default venv tenv (BindDefault binder expr)
772 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
773 let new_venv = addOneToIdEnv venv old new in
774 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
775 returnUs (BindDefault new_binder new_expr)
777 do_CoreExpr venv tenv (Let core_bind expr)
778 = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
779 -- and do the body of the let
780 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
781 returnUs (Let new_bind new_expr)
783 do_CoreExpr venv tenv (SCC label expr)
784 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
785 returnUs (SCC label new_expr)
787 do_CoreExpr venv tenv (Coerce c ty expr)
788 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
789 returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)