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 {- exprSmallEnoughToDup,
19 manifestlyWHNF, manifestlyBottom,
24 squashableDictishCcExpr,
29 import IdLoop -- for pananoia-checking purposes
33 import CostCentre ( isDictCC )
34 import Id ( idType, mkSysLocal,
35 addOneToIdEnv, growIdEnvList, lookupIdEnv,
36 isNullIdEnv, IdEnv(..),
39 import Literal ( literalType, isNoRepLit, Literal(..) )
40 import Maybes ( catMaybes )
41 import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} )
42 import PprStyle ( PprStyle(..) )
43 import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
44 import Pretty ( ppAboves )
45 import PrelInfo ( trueDataCon, falseDataCon,
49 import PrimOp ( primOpType, PrimOp(..) )
50 import SrcLoc ( mkUnknownSrcLoc )
51 import TyVar ( isNullTyVarEnv, TyVarEnv(..), GenTyVar{-instances-} )
52 import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy,
53 getFunTy_maybe, applyTy, splitSigmaTy
55 import Unique ( Unique{-instances-} )
56 import UniqSupply ( initUs, returnUs, thenUs,
58 UniqSM(..), UniqSupply
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"
65 applyTypeEnvToTy = panic "CoreUtils.applyTypeEnvToTy"
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 -- a Con is a fully-saturated application of a data constructor
85 -- a Prim is <ditto> of a PrimOp
87 coreExprType (Con con args) = applyTypeToArgs (idType con) args
88 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
90 coreExprType (Lam (ValBinder binder) expr)
91 = mkFunTys [idType binder] (coreExprType expr)
93 coreExprType (Lam (TyBinder tyvar) expr)
94 = mkForAllTy tyvar (coreExprType expr)
96 coreExprType (Lam (UsageBinder uvar) expr)
97 = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
99 coreExprType (App expr (TyArg ty))
100 = applyTy (coreExprType expr) ty
102 coreExprType (App expr (UsageArg use))
103 = applyUsage (coreExprType expr) use
105 coreExprType (App expr val_arg)
106 = ASSERT(isValArg val_arg)
108 fun_ty = coreExprType expr
110 case (getFunTy_maybe fun_ty) of
111 Just (_, result_ty) -> result_ty
113 Nothing -> pprPanic "coreExprType:\n"
114 (ppAboves [ppr PprDebug fun_ty,
115 ppr PprShowAll (App expr val_arg)])
120 coreAltsType :: CoreCaseAlts -> Type
122 coreAltsType (AlgAlts [] deflt) = default_ty deflt
123 coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
125 coreAltsType (PrimAlts [] deflt) = default_ty deflt
126 coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
128 default_ty NoDefault = panic "coreExprType:Case:default_ty"
129 default_ty (BindDefault _ rhs) = coreExprType rhs
133 applyTypeToArgs = panic "applyTypeToArgs"
136 %************************************************************************
138 \subsection{Routines to manufacture bits of @CoreExpr@}
140 %************************************************************************
143 mkCoreIfThenElse (Var bool) then_expr else_expr
144 | bool == trueDataCon = then_expr
145 | bool == falseDataCon = else_expr
147 mkCoreIfThenElse guard then_expr else_expr
149 (AlgAlts [ (trueDataCon, [], then_expr),
150 (falseDataCon, [], else_expr) ]
155 mkErrorApp :: Type -> Id -> String -> CoreExpr
157 mkErrorApp ty str_var error_msg
158 = Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) (
159 mkApp (Var pAT_ERROR_ID) [] [ty] [VarArg str_var])
162 escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
163 escErrorMsg (x:xs) = x : escErrorMsg xs
166 For making @Apps@ and @Lets@, we must take appropriate evasive
167 action if the thing being bound has unboxed type. @mkCoApp@ requires
168 a name supply to do its work. Other-monad code will call @mkCoApp@
169 through its own interface function (e.g., the desugarer uses
172 @mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the
173 arguments-must-be-atoms constraint.
177 --mkCoApp :: CoreExpr -> CoreExpr -> UniqSM CoreExpr
179 mkCoApp e1 (Var v) = returnUs (App e1 (VarArg v))
180 mkCoApp e1 (Lit l) = returnUs (App e1 (LitArg l))
183 e2_ty = coreExprType e2
185 panic "getUnique" `thenUs` \ uniq ->
187 new_var = mkSysLocal SLIT("a") uniq e2_ty mkUnknownSrcLoc
190 mkCoLetUnboxedToCase (NonRec new_var e2)
191 (App e1 (VarArg new_var))
198 mkCoCon :: Id -> [CoreExpr] -> UniqSM CoreExpr
199 mkCoPrim :: PrimOp -> [CoreExpr] -> UniqSM CoreExpr
201 mkCoCon con args = mkCoThing (Con con) args
202 mkCoPrim op args = mkCoThing (Prim op) args
204 mkCoThing thing arg_exprs
205 = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
206 returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
208 expr_to_arg :: CoreExpr
209 -> UniqSM (CoreArg, Maybe CoreBinding)
211 expr_to_arg (Var v) = returnUs (VarArg v, Nothing)
212 expr_to_arg (Lit l) = returnUs (LitArg l, Nothing)
213 expr_to_arg other_expr
215 e_ty = coreExprType other_expr
217 panic "getUnique" `thenUs` \ uniq ->
219 new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
220 new_atom = VarArg new_var
222 returnUs (new_atom, Just (NonRec new_var other_expr))
228 GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
230 argToExpr (VarArg v) = Var v
231 argToExpr (LitArg lit) = Lit lit
237 -- GenCoreExpr val_bdr val_occ tyvar uvar ->
238 -- [GenCoreExpr val_bdr val_occ tyvar uvar] ->
239 -- UniqSM(GenCoreExpr val_bdr val_occ tyvar uvar)
241 mkCoApps fun [] = returnUs fun
242 mkCoApps fun (arg:args)
243 = mkCoApp fun arg `thenUs` \ new_fun ->
244 mkCoApps new_fun args
248 exprSmallEnoughToDup :: GenCoreExpr binder Id -> Bool
250 exprSmallEnoughToDup (Con _ _ _) = True -- Could check # of args
251 exprSmallEnoughToDup (Prim op _ _) = not (fragilePrimOp op) -- Could check # of args
252 exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
254 exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
255 = case (collectArgs expr) of { (fun, args) ->
257 Var v -> v /= buildId
259 && length args <= 6 -- or 10 or 1 or 4 or anything smallish.
263 Question (ADR): What is the above used for? Is a _ccall_ really small
266 @manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
267 it is obviously in weak head normal form. It isn't a disaster if it
268 errs on the conservative side (returning \tr{False})---I've probably
269 left something out... [WDP]
272 manifestlyWHNF :: GenCoreExpr bndr Id -> Bool
274 manifestlyWHNF (Var _) = True
275 manifestlyWHNF (Lit _) = True
276 manifestlyWHNF (Con _ _ _) = True -- ToDo: anything for Prim?
277 manifestlyWHNF (Lam _ _) = True
278 manifestlyWHNF (CoTyLam _ e) = manifestlyWHNF e
279 manifestlyWHNF (SCC _ e) = manifestlyWHNF e
280 manifestlyWHNF (Let _ e) = False
281 manifestlyWHNF (Case _ _) = False
283 manifestlyWHNF other_expr -- look for manifest partial application
284 = case (collectArgs other_expr) of { (fun, args) ->
287 num_val_args = length [ a | (ValArg a) <- args ]
289 num_val_args == 0 || -- Just a type application of
290 -- a variable (f t1 t2 t3)
292 case (arityMaybe (getIdArity f)) of
294 Just arity -> num_val_args < arity
300 @manifestlyBottom@ looks at a Core expression and returns \tr{True} if
301 it is obviously bottom, that is, it will certainly return bottom at
302 some point. It isn't a disaster if it errs on the conservative side
303 (returning \tr{False}).
306 manifestlyBottom :: GenCoreExpr bndr Id -> Bool
308 manifestlyBottom (Var v) = isBottomingId v
309 manifestlyBottom (Lit _) = False
310 manifestlyBottom (Con _ _ _) = False
311 manifestlyBottom (Prim _ _ _)= False
312 manifestlyBottom (Lam _ _) = False -- we do not assume \x.bottom == bottom. should we? ToDo
313 manifestlyBottom (CoTyLam _ e) = manifestlyBottom e
314 manifestlyBottom (SCC _ e) = manifestlyBottom e
315 manifestlyBottom (Let _ e) = manifestlyBottom e
317 manifestlyBottom (Case e a)
320 AlgAlts alts def -> all mbalg alts && mbdef def
321 PrimAlts alts def -> all mbprim alts && mbdef def
324 mbalg (_,_,e') = manifestlyBottom e'
326 mbprim (_,e') = manifestlyBottom e'
328 mbdef NoDefault = True
329 mbdef (BindDefault _ e') = manifestlyBottom e'
331 manifestlyBottom other_expr -- look for manifest partial application
332 = case (collectArgs other_expr) of { (fun, args) ->
334 Var f | isBottomingId f -> True -- Application of a function which
335 -- always gives bottom; we treat this as
336 -- a WHNF, because it certainly doesn't
337 -- need to be shared!
344 :: (Id -> Maybe (GenCoreExpr bndr Id))
345 -> GenCoreExpr bndr Id
347 coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
348 coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
349 coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
350 coreExprArity f (CoTyApp expr _) = coreExprArity f expr
351 coreExprArity f (Var v) = max further info
356 Just expr -> coreExprArity f expr
357 info = case (arityMaybe (getIdArity v)) of
360 coreExprArity f _ = 0
363 @isWrapperFor@: we want to see exactly:
365 /\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
368 Probably a little too HACKY [WDP].
371 isWrapperFor :: CoreExpr -> Id -> Bool
373 expr `isWrapperFor` var
374 = case (digForLambdas expr) of { (_, _, args, body) -> -- lambdas off the front
375 unravel_casing args body
376 --NO, THANKS: && not (null args)
379 var's_worker = getWorkerId (getIdStrictness var)
381 is_elem = isIn "isWrapperFor"
384 unravel_casing case_ables (Case scrut alts)
385 = case (collectArgs scrut) of { (fun, args) ->
389 scrut_var /= var && all (doesn't_mention var) args
390 && scrut_var `is_elem` case_ables
391 && unravel_alts case_ables alts
398 unravel_casing case_ables other_expr
399 = case (collectArgs other_expr) of { (fun, args) ->
403 -- DOESN'T WORK: wrkr == var's_worker
406 && all (doesn't_mention var) args
407 && all (only_from case_ables) args
415 unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
416 = unravel_casing (params ++ case_ables) rhs
417 unravel_alts case_ables other = False
419 -------------------------
420 doesn't_mention var (ValArg (VarArg v)) = v /= var
421 doesn't_mention var other = True
423 -------------------------
424 only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
425 only_from case_ables other = True
429 All the following functions operate on binders, perform a uniform
430 transformation on them; ie. the function @(\ x -> (x,False))@
431 annotates all binders with False.
434 unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
435 unTagBinders expr = bop_expr fst expr
437 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
438 unTagBindersAlts alts = bop_alts fst alts
442 bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
444 bop_expr f (Var b) = Var b
445 bop_expr f (Lit lit) = Lit lit
446 bop_expr f (Con con args) = Con con args
447 bop_expr f (Prim op args) = Prim op args
448 bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
449 bop_expr f (App expr arg) = App (bop_expr f expr) arg
450 bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
451 bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
452 bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
454 bop_binder f (ValBinder v) = ValBinder (f v)
455 bop_binder f (TyBinder t) = TyBinder t
456 bop_binder f (UsageBinder u) = UsageBinder u
458 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
459 bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
461 bop_alts f (AlgAlts alts deflt)
462 = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
463 | (con, binders, e) <- alts ]
466 bop_alts f (PrimAlts alts deflt)
467 = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
470 bop_deflt f (NoDefault) = NoDefault
471 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
474 OLD (but left here because of the nice example): @singleAlt@ checks
475 whether a bunch of case alternatives is actually just one alternative.
476 It specifically {\em ignores} alternatives which consist of just a
477 call to @error@, because they won't result in any code duplication.
481 case (case <something> of
483 False -> error "Foo") of
489 True -> case <rhs> of
491 False -> case error "Foo" of
497 True -> case <rhs> of
501 Notice that the \tr{<alts>} don't get duplicated.
505 nonErrorRHSs :: GenCoreCaseAlts binder Id -> [GenCoreExpr binder Id]
507 nonErrorRHSs alts = filter not_error_app (find_rhss alts)
509 find_rhss (AlgAlts alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt
510 find_rhss (PrimAlts alts deflt) = [rhs | (_,rhs) <- alts] ++ deflt_rhs deflt
512 deflt_rhs NoDefault = []
513 deflt_rhs (BindDefault _ rhs) = [rhs]
515 not_error_app rhs = case maybeErrorApp rhs Nothing of
520 maybeErrorApp checkes whether an expression is of the form
526 Just (error ty' args)
528 where ty' is supplied as an argument to maybeErrorApp.
530 Here's where it is useful:
532 case (error ty "Foo" e1 e2) of <alts>
536 where ty' is the type of any of the alternatives.
537 You might think this never occurs, but see the comments on
538 the definition of @singleAlt@.
540 Note: we *avoid* the case where ty' might end up as a
541 primitive type: this is very uncool (totally wrong).
543 NOTICE: in the example above we threw away e1 and e2, but
544 not the string "Foo". How did we know to do that?
546 Answer: for now anyway, we only handle the case of a function
547 whose type is of form
549 bottomingFn :: forall a. t1 -> ... -> tn -> a
550 ^---------------------^ NB!
552 Furthermore, we only count a bottomingApp if the function is
553 applied to more than n args. If so, we transform:
555 bottomingFn ty e1 ... en en+1 ... em
557 bottomingFn ty' e1 ... en
559 That is, we discard en+1 .. em
562 maybeErrorApp :: GenCoreExpr bndr Id -- Expr to look at
563 -> Maybe Type -- Just ty => a result type *already cloned*;
564 -- Nothing => don't know result ty; we
565 -- *pretend* that the result ty won't be
566 -- primitive -- somebody later must
568 -> Maybe (GenCoreExpr bndr Id)
570 maybeErrorApp expr result_ty_maybe
571 = case collectArgs expr of
572 (Var fun, (TypeArg ty : other_args))
574 && maybeToBool result_ty_maybe -- we *know* the result type
575 -- (otherwise: live a fairy-tale existence...)
576 && not (isPrimType result_ty) ->
577 case splitSigmaTy (idType fun) of
578 ([tyvar_tmpl], [], tau_ty) ->
579 case (splitTyArgs tau_ty) of { (arg_tys, res_ty) ->
581 n_args_to_keep = length arg_tys
582 args_to_keep = take n_args_to_keep other_args
584 if res_ty == mkTyVarTemplateTy tyvar_tmpl &&
585 n_args_to_keep <= length other_args
587 -- Phew! We're in business
588 Just (mkGenApp (Var fun)
589 (TypeArg result_ty : args_to_keep))
594 other -> -- Function type wrong shape
598 Just result_ty = result_ty_maybe
602 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b -> Bool
604 squashableDictishCcExpr cc expr
605 = if not (isDictCC cc) then
606 False -- that was easy...
608 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
610 squashable (Var _) = True
611 squashable (CoTyApp f _) = squashable f
612 squashable (Con _ _ _) = True -- I think so... WDP 94/09
613 squashable (Prim _ _ _) = True -- ditto
614 squashable other = False
618 %************************************************************************
620 \subsection{Core-renaming utils}
622 %************************************************************************
625 substCoreExpr :: ValEnv
626 -> TypeEnv -- TyVar=>Type
630 substCoreExpr venv tenv expr
631 -- if the envs are empty, then avoid doing anything
632 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
635 do_CoreExpr venv tenv expr
638 The equiv code for @Types@ is in @TyUtils@.
640 Because binders aren't necessarily unique: we don't do @plusEnvs@
641 (which check for duplicates); rather, we use the shadowing version,
642 @growIdEnv@ (and shorthand @addOneToIdEnv@).
644 @do_CoreBindings@ takes into account the semantics of a list of
645 @CoreBindings@---things defined early in the list are visible later in
646 the list, but not vice versa.
649 type ValEnv = IdEnv CoreExpr
651 do_CoreBindings :: ValEnv
654 -> UniqSM [CoreBinding]
656 do_CoreBinding :: ValEnv
659 -> UniqSM (CoreBinding, ValEnv)
661 do_CoreBindings venv tenv [] = returnUs []
662 do_CoreBindings venv tenv (b:bs)
663 = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
664 do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
665 returnUs (new_b : new_bs)
667 do_CoreBinding venv tenv (NonRec binder rhs)
668 = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
670 dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
671 -- now plug new bindings into envs
672 let new_venv = addOneToIdEnv venv old new in
674 returnUs (NonRec new_binder new_rhs, new_venv)
676 do_CoreBinding venv tenv (Rec binds)
677 = -- for letrec, we plug in new bindings BEFORE cloning rhss
678 mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
679 let new_venv = growIdEnvList venv new_maps in
681 mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
682 returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv)
684 (binders, rhss) = unzip binds
693 do_CoreArg venv tenv (LitArg lit) = returnUs (Lit lit)
694 do_CoreArg venv tenv (TyArg ty) = panic "do_CoreArg: TyArg"
695 do_CoreArg venv tenv (UsageArg usage) = panic "do_CoreArg: UsageArg"
696 do_CoreArg venv tenv (VarArg v)
698 case (lookupIdEnv venv v) of
699 Nothing -> --false:ASSERT(toplevelishId v)
706 do_CoreExpr :: ValEnv
711 do_CoreExpr venv tenv orig_expr@(Var var)
713 case (lookupIdEnv venv var) of
714 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
719 do_CoreExpr venv tenv e@(Lit _) = returnUs e
721 do_CoreExpr venv tenv (Con con as)
722 = panic "CoreUtils.do_CoreExpr:Con"
724 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
728 do_CoreExpr venv tenv (Prim op as)
729 = panic "CoreUtils.do_CoreExpr:Prim"
731 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
732 do_PrimOp op `thenUs` \ new_op ->
733 mkCoPrim new_op new_as
735 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
737 new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
738 new_result_ty = applyTypeEnvToTy tenv result_ty
740 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
742 do_PrimOp other_op = returnUs other_op
745 do_CoreExpr venv tenv (Lam binder expr)
746 = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
747 let new_venv = addOneToIdEnv venv old new in
748 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
749 returnUs (Lam new_binder new_expr)
751 do_CoreExpr venv tenv (App expr arg)
752 = panic "CoreUtils.do_CoreExpr:App"
754 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
755 do_CoreArg venv tenv arg `thenUs` \ new_arg ->
756 mkCoApp new_expr new_arg
759 do_CoreExpr venv tenv (Case expr alts)
760 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
761 do_alts venv tenv alts `thenUs` \ new_alts ->
762 returnUs (Case new_expr new_alts)
764 do_alts venv tenv (AlgAlts alts deflt)
765 = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
766 do_default venv tenv deflt `thenUs` \ new_deflt ->
767 returnUs (AlgAlts new_alts new_deflt)
769 do_boxed_alt venv tenv (con, binders, expr)
770 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
771 let new_venv = growIdEnvList venv new_vmaps in
772 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
773 returnUs (con, new_binders, new_expr)
776 do_alts venv tenv (PrimAlts alts deflt)
777 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
778 do_default venv tenv deflt `thenUs` \ new_deflt ->
779 returnUs (PrimAlts new_alts new_deflt)
781 do_unboxed_alt venv tenv (lit, expr)
782 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
783 returnUs (lit, new_expr)
785 do_default venv tenv NoDefault = returnUs NoDefault
787 do_default venv tenv (BindDefault binder expr)
788 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
789 let new_venv = addOneToIdEnv venv old new in
790 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
791 returnUs (BindDefault new_binder new_expr)
793 do_CoreExpr venv tenv (Let core_bind expr)
794 = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
795 -- and do the body of the let
796 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
797 returnUs (Let new_bind new_expr)
799 do_CoreExpr venv tenv (SCC label expr)
800 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
801 returnUs (SCC label new_expr)