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 PrelVals ( augmentId, buildId )
47 import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) )
48 import SrcLoc ( mkUnknownSrcLoc )
49 import TyVar ( isNullTyVarEnv, TyVarEnv(..) )
50 import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
51 getFunTy_maybe, applyTy, isPrimType,
52 splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
54 import TysWiredIn ( trueDataCon, falseDataCon )
55 import UniqSupply ( initUs, returnUs, thenUs,
56 mapUs, mapAndUnzipUs, getUnique,
57 UniqSM(..), UniqSupply
59 import Usage ( UVar(..) )
60 import Util ( zipEqual, panic, pprPanic, assertPanic )
62 type TypeEnv = TyVarEnv Type
63 applyUsage = panic "CoreUtils.applyUsage:ToDo"
64 dup_binder = panic "CoreUtils.dup_binder"
67 %************************************************************************
69 \subsection{Find the type of a Core atom/expression}
71 %************************************************************************
74 coreExprType :: CoreExpr -> Type
76 coreExprType (Var var) = idType var
77 coreExprType (Lit lit) = literalType lit
79 coreExprType (Let _ body) = coreExprType body
80 coreExprType (SCC _ expr) = coreExprType expr
81 coreExprType (Case _ alts) = coreAltsType alts
83 coreExprType (Coerce _ ty _) = ty -- that's the whole point!
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 op_ty args = foldl applyTypeToArg op_ty args
136 applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
137 applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg"
138 applyTypeToArg op_ty val_or_lit_arg = case (getFunTy_maybe op_ty) of
139 Just (_, res_ty) -> res_ty
142 %************************************************************************
144 \subsection{Routines to manufacture bits of @CoreExpr@}
146 %************************************************************************
149 mkCoreIfThenElse (Var bool) then_expr else_expr
150 | bool == trueDataCon = then_expr
151 | bool == falseDataCon = else_expr
153 mkCoreIfThenElse guard then_expr else_expr
155 (AlgAlts [ (trueDataCon, [], then_expr),
156 (falseDataCon, [], else_expr) ]
160 For making @Apps@ and @Lets@, we must take appropriate evasive
161 action if the thing being bound has unboxed type. @mkCoApp@ requires
162 a name supply to do its work.
164 @mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
165 arguments-must-be-atoms constraint.
172 mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
173 mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
174 mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
176 mkCoApps fun args = co_thing (mkGenApp fun) args
177 mkCoCon con args = co_thing (Con con) args
178 mkCoPrim op args = co_thing (Prim op) args
180 co_thing :: ([CoreArg] -> CoreExpr)
184 co_thing thing arg_exprs
185 = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
186 returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
188 expr_to_arg :: CoreArgOrExpr
189 -> UniqSM (CoreArg, Maybe CoreBinding)
191 expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
192 expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
193 expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
194 expr_to_arg (AnExpr other_expr)
196 e_ty = coreExprType other_expr
198 getUnique `thenUs` \ uniq ->
200 new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
202 returnUs (VarArg new_var, Just (NonRec new_var other_expr))
207 GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
209 argToExpr (VarArg v) = Var v
210 argToExpr (LitArg lit) = Lit lit
214 exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
215 exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
216 exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
217 exprSmallEnoughToDup expr
218 = case (collectArgs expr) of { (fun, _, _, vargs) ->
220 Var v | length vargs == 0 -> True
226 exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
227 = case (collectArgs expr) of { (fun, _, _, vargs) ->
229 Var v -> v /= buildId
231 && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
236 Question (ADR): What is the above used for? Is a _ccall_ really small
239 @manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
240 it is obviously in weak head normal form. It isn't a disaster if it
241 errs on the conservative side (returning \tr{False})---I've probably
242 left something out... [WDP]
245 manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool
247 manifestlyWHNF (Var _) = True
248 manifestlyWHNF (Lit _) = True
249 manifestlyWHNF (Con _ _) = True
250 manifestlyWHNF (SCC _ e) = manifestlyWHNF e
251 manifestlyWHNF (Coerce _ _ e) = _trace "manifestlyWHNF:Coerce" $ manifestlyWHNF e
252 manifestlyWHNF (Let _ e) = False
253 manifestlyWHNF (Case _ _) = False
255 manifestlyWHNF (Lam x e) = if isValBinder x then True else manifestlyWHNF e
257 manifestlyWHNF other_expr -- look for manifest partial application
258 = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
261 num_val_args = length vargs
263 num_val_args == 0 -- Just a type application of
264 -- a variable (f t1 t2 t3);
267 case (arityMaybe (getIdArity f)) of
269 Just arity -> num_val_args < arity
275 @manifestlyBottom@ looks at a Core expression and returns \tr{True} if
276 it is obviously bottom, that is, it will certainly return bottom at
277 some point. It isn't a disaster if it errs on the conservative side
278 (returning \tr{False}).
281 manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
283 manifestlyBottom (Var v) = isBottomingId v
284 manifestlyBottom (Lit _) = False
285 manifestlyBottom (Con _ _) = False
286 manifestlyBottom (Prim _ _) = False
287 manifestlyBottom (SCC _ e) = manifestlyBottom e
288 manifestlyBottom (Coerce _ _ e) = _trace "manifestlyBottom:Coerce" $ manifestlyBottom e
289 manifestlyBottom (Let _ e) = manifestlyBottom e
291 -- We do not assume \x.bottom == bottom:
292 manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e
294 manifestlyBottom (Case e a)
297 AlgAlts alts def -> all mbalg alts && mbdef def
298 PrimAlts alts def -> all mbprim alts && mbdef def
301 mbalg (_,_,e') = manifestlyBottom e'
303 mbprim (_,e') = manifestlyBottom e'
305 mbdef NoDefault = True
306 mbdef (BindDefault _ e') = manifestlyBottom e'
308 manifestlyBottom other_expr -- look for manifest partial application
309 = case (collectArgs other_expr) of { (fun, _, _, _) ->
311 Var f | isBottomingId f -> True
312 -- Application of a function which always gives
313 -- bottom; we treat this as a WHNF, because it
314 -- certainly doesn't need to be shared!
322 :: (Id -> Maybe (GenCoreExpr bndr Id))
323 -> GenCoreExpr bndr Id
325 coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
326 coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
327 coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
328 coreExprArity f (CoTyApp expr _) = coreExprArity f expr
329 coreExprArity f (Var v) = max further info
334 Just expr -> coreExprArity f expr
335 info = case (arityMaybe (getIdArity v)) of
338 coreExprArity f _ = 0
341 @isWrapperFor@: we want to see exactly:
343 /\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
346 Probably a little too HACKY [WDP].
349 isWrapperFor :: CoreExpr -> Id -> Bool
351 expr `isWrapperFor` var
352 = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front
353 unravel_casing args body
354 --NO, THANKS: && not (null args)
357 var's_worker = getWorkerId (getIdStrictness var)
359 is_elem = isIn "isWrapperFor"
362 unravel_casing case_ables (Case scrut alts)
363 = case (collectArgs scrut) of { (fun, _, _, vargs) ->
367 scrut_var /= var && all (doesn't_mention var) vargs
368 && scrut_var `is_elem` case_ables
369 && unravel_alts case_ables alts
376 unravel_casing case_ables other_expr
377 = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
381 -- DOESN'T WORK: wrkr == var's_worker
384 && all (doesn't_mention var) vargs
385 && all (only_from case_ables) vargs
393 unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
394 = unravel_casing (params ++ case_ables) rhs
395 unravel_alts case_ables other = False
397 -------------------------
398 doesn't_mention var (ValArg (VarArg v)) = v /= var
399 doesn't_mention var other = True
401 -------------------------
402 only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
403 only_from case_ables other = True
407 All the following functions operate on binders, perform a uniform
408 transformation on them; ie. the function @(\ x -> (x,False))@
409 annotates all binders with False.
412 unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
413 unTagBinders expr = bop_expr fst expr
415 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
416 unTagBindersAlts alts = bop_alts fst alts
420 bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
422 bop_expr f (Var b) = Var b
423 bop_expr f (Lit lit) = Lit lit
424 bop_expr f (Con con args) = Con con args
425 bop_expr f (Prim op args) = Prim op args
426 bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
427 bop_expr f (App expr arg) = App (bop_expr f expr) arg
428 bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
429 bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
430 bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
431 bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
433 bop_binder f (ValBinder v) = ValBinder (f v)
434 bop_binder f (TyBinder t) = TyBinder t
435 bop_binder f (UsageBinder u) = UsageBinder u
437 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
438 bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
440 bop_alts f (AlgAlts alts deflt)
441 = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
442 | (con, binders, e) <- alts ]
445 bop_alts f (PrimAlts alts deflt)
446 = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
449 bop_deflt f (NoDefault) = NoDefault
450 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
453 OLD (but left here because of the nice example): @singleAlt@ checks
454 whether a bunch of case alternatives is actually just one alternative.
455 It specifically {\em ignores} alternatives which consist of just a
456 call to @error@, because they won't result in any code duplication.
460 case (case <something> of
462 False -> error "Foo") of
468 True -> case <rhs> of
470 False -> case error "Foo" of
476 True -> case <rhs> of
480 Notice that the \tr{<alts>} don't get duplicated.
483 nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
486 = filter not_error_app (find_rhss alts)
488 find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
489 find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
491 deflt_rhs NoDefault = []
492 deflt_rhs (BindDefault _ rhs) = [rhs]
495 = case (maybeErrorApp rhs Nothing) of
500 maybeErrorApp checks whether an expression is of the form
506 Just (error ty' args)
508 where ty' is supplied as an argument to maybeErrorApp.
510 Here's where it is useful:
512 case (error ty "Foo" e1 e2) of <alts>
516 where ty' is the type of any of the alternatives. You might think
517 this never occurs, but see the comments on the definition of
520 Note: we *avoid* the case where ty' might end up as a primitive type:
521 this is very uncool (totally wrong).
523 NOTICE: in the example above we threw away e1 and e2, but not the
524 string "Foo". How did we know to do that?
526 Answer: for now anyway, we only handle the case of a function whose
529 bottomingFn :: forall a. t1 -> ... -> tn -> a
530 ^---------------------^ NB!
532 Furthermore, we only count a bottomingApp if the function is applied
533 to more than n args. If so, we transform:
535 bottomingFn ty e1 ... en en+1 ... em
537 bottomingFn ty' e1 ... en
539 That is, we discard en+1 .. em
543 :: GenCoreExpr a Id TyVar UVar -- Expr to look at
544 -> Maybe Type -- Just ty => a result type *already cloned*;
545 -- Nothing => don't know result ty; we
546 -- *pretend* that the result ty won't be
547 -- primitive -- somebody later must
549 -> Maybe (GenCoreExpr a Id TyVar UVar)
551 maybeErrorApp expr result_ty_maybe
552 = case (collectArgs expr) of
553 (Var fun, [{-no usage???-}], [ty], other_args)
555 && maybeToBool result_ty_maybe -- we *know* the result type
556 -- (otherwise: live a fairy-tale existence...)
557 && not (isPrimType result_ty) ->
559 case (splitSigmaTy (idType fun)) of
560 ([tyvar], [], tau_ty) ->
561 case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
563 n_args_to_keep = length arg_tys
564 args_to_keep = take n_args_to_keep other_args
566 if (res_ty `eqTy` mkTyVarTy tyvar)
567 && n_args_to_keep <= length other_args
569 -- Phew! We're in business
570 Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
575 other -> Nothing -- Function type wrong shape
578 Just result_ty = result_ty_maybe
582 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
584 squashableDictishCcExpr cc expr
585 = if not (isDictCC cc) then
586 False -- that was easy...
588 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
590 squashable (Var _) = True
591 squashable (Con _ _) = True -- I think so... WDP 94/09
592 squashable (Prim _ _) = True -- ditto
594 | notValArg a = squashable f
595 squashable other = False
598 %************************************************************************
600 \subsection{Core-renaming utils}
602 %************************************************************************
605 substCoreBindings :: ValEnv
606 -> TypeEnv -- TyVar=>Type
608 -> UniqSM [CoreBinding]
610 substCoreExpr :: ValEnv
611 -> TypeEnv -- TyVar=>Type
615 substCoreBindings venv tenv binds
616 -- if the envs are empty, then avoid doing anything
617 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
620 do_CoreBindings venv tenv binds
622 substCoreExpr venv tenv expr
623 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
626 do_CoreExpr venv tenv expr
629 The equiv code for @Types@ is in @TyUtils@.
631 Because binders aren't necessarily unique: we don't do @plusEnvs@
632 (which check for duplicates); rather, we use the shadowing version,
633 @growIdEnv@ (and shorthand @addOneToIdEnv@).
635 @do_CoreBindings@ takes into account the semantics of a list of
636 @CoreBindings@---things defined early in the list are visible later in
637 the list, but not vice versa.
640 type ValEnv = IdEnv CoreExpr
642 do_CoreBindings :: ValEnv
645 -> UniqSM [CoreBinding]
647 do_CoreBinding :: ValEnv
650 -> UniqSM (CoreBinding, ValEnv)
652 do_CoreBindings venv tenv [] = returnUs []
653 do_CoreBindings venv tenv (b:bs)
654 = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
655 do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
656 returnUs (new_b : new_bs)
658 do_CoreBinding venv tenv (NonRec binder rhs)
659 = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
661 dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
662 -- now plug new bindings into envs
663 let new_venv = addOneToIdEnv venv old new in
665 returnUs (NonRec new_binder new_rhs, new_venv)
667 do_CoreBinding venv tenv (Rec binds)
668 = -- for letrec, we plug in new bindings BEFORE cloning rhss
669 mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
670 let new_venv = growIdEnvList venv new_maps in
672 mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
673 returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
675 (binders, rhss) = unzip binds
682 -> UniqSM CoreArgOrExpr
684 do_CoreArg venv tenv a@(VarArg v)
686 case (lookupIdEnv venv v) of
688 Just expr -> AnExpr expr
691 do_CoreArg venv tenv (TyArg ty)
692 = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
694 do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
698 do_CoreExpr :: ValEnv
703 do_CoreExpr venv tenv orig_expr@(Var var)
705 case (lookupIdEnv venv var) of
706 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
711 do_CoreExpr venv tenv e@(Lit _) = returnUs e
713 do_CoreExpr venv tenv (Con con as)
714 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
717 do_CoreExpr venv tenv (Prim op as)
718 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
719 do_PrimOp op `thenUs` \ new_op ->
720 mkCoPrim new_op new_as
722 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
724 new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
725 new_result_ty = applyTypeEnvToTy tenv result_ty
727 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
729 do_PrimOp other_op = returnUs other_op
731 do_CoreExpr venv tenv (Lam binder expr)
732 = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
733 let new_venv = addOneToIdEnv venv old new in
734 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
735 returnUs (Lam new_binder new_expr)
737 do_CoreExpr venv tenv (App expr arg)
738 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
739 do_CoreArg venv tenv arg `thenUs` \ new_arg ->
740 mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
742 do_CoreExpr venv tenv (Case expr alts)
743 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
744 do_alts venv tenv alts `thenUs` \ new_alts ->
745 returnUs (Case new_expr new_alts)
747 do_alts venv tenv (AlgAlts alts deflt)
748 = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
749 do_default venv tenv deflt `thenUs` \ new_deflt ->
750 returnUs (AlgAlts new_alts new_deflt)
752 do_boxed_alt venv tenv (con, binders, expr)
753 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
754 let new_venv = growIdEnvList venv new_vmaps in
755 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
756 returnUs (con, new_binders, new_expr)
759 do_alts venv tenv (PrimAlts alts deflt)
760 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
761 do_default venv tenv deflt `thenUs` \ new_deflt ->
762 returnUs (PrimAlts new_alts new_deflt)
764 do_unboxed_alt venv tenv (lit, expr)
765 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
766 returnUs (lit, new_expr)
768 do_default venv tenv NoDefault = returnUs NoDefault
770 do_default venv tenv (BindDefault binder expr)
771 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
772 let new_venv = addOneToIdEnv venv old new in
773 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
774 returnUs (BindDefault new_binder new_expr)
776 do_CoreExpr venv tenv (Let core_bind expr)
777 = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
778 -- and do the body of the let
779 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
780 returnUs (Let new_bind new_expr)
782 do_CoreExpr venv tenv (SCC label expr)
783 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
784 returnUs (SCC label new_expr)
786 do_CoreExpr venv tenv (Coerce c ty expr)
787 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
788 returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)