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
15 , mkErrorApp, escErrorMsg
17 , unTagBinders, unTagBindersAlts
18 , manifestlyWHNF, manifestlyBottom
21 , squashableDictishCcExpr
22 {- 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,
50 import PrimOp ( primOpType, PrimOp(..) )
51 import SrcLoc ( mkUnknownSrcLoc )
52 import TyVar ( isNullTyVarEnv, TyVarEnv(..) )
53 import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
54 getFunTy_maybe, applyTy, isPrimType,
55 splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
57 import UniqSupply ( initUs, returnUs, thenUs,
59 UniqSM(..), UniqSupply
61 import Usage ( UVar(..) )
62 import Util ( zipEqual, panic, pprPanic, assertPanic )
64 type TypeEnv = TyVarEnv Type
65 applyUsage = panic "CoreUtils.applyUsage:ToDo"
66 dup_binder = panic "CoreUtils.dup_binder"
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, _, _, vargs) ->
258 Var v -> v /= buildId
260 && length vargs <= 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 x e) = if isValBinder x then True else manifestlyWHNF e
285 manifestlyWHNF other_expr -- look for manifest partial application
286 = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
289 num_val_args = length vargs
291 num_val_args == 0 -- Just a type application of
292 -- a variable (f t1 t2 t3);
295 case (arityMaybe (getIdArity f)) of
297 Just arity -> num_val_args < arity
303 @manifestlyBottom@ looks at a Core expression and returns \tr{True} if
304 it is obviously bottom, that is, it will certainly return bottom at
305 some point. It isn't a disaster if it errs on the conservative side
306 (returning \tr{False}).
309 manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
311 manifestlyBottom (Var v) = isBottomingId v
312 manifestlyBottom (Lit _) = False
313 manifestlyBottom (Con _ _) = False
314 manifestlyBottom (Prim _ _) = False
315 manifestlyBottom (SCC _ e) = manifestlyBottom e
316 manifestlyBottom (Let _ e) = manifestlyBottom e
318 -- We do not assume \x.bottom == bottom:
319 manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e
321 manifestlyBottom (Case e a)
324 AlgAlts alts def -> all mbalg alts && mbdef def
325 PrimAlts alts def -> all mbprim alts && mbdef def
328 mbalg (_,_,e') = manifestlyBottom e'
330 mbprim (_,e') = manifestlyBottom e'
332 mbdef NoDefault = True
333 mbdef (BindDefault _ e') = manifestlyBottom e'
335 manifestlyBottom other_expr -- look for manifest partial application
336 = case (collectArgs other_expr) of { (fun, _, _, _) ->
338 Var f | isBottomingId f -> True
339 -- Application of a function which always gives
340 -- bottom; we treat this as a WHNF, because it
341 -- certainly doesn't need to be shared!
349 :: (Id -> Maybe (GenCoreExpr bndr Id))
350 -> GenCoreExpr bndr Id
352 coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
353 coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
354 coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
355 coreExprArity f (CoTyApp expr _) = coreExprArity f expr
356 coreExprArity f (Var v) = max further info
361 Just expr -> coreExprArity f expr
362 info = case (arityMaybe (getIdArity v)) of
365 coreExprArity f _ = 0
368 @isWrapperFor@: we want to see exactly:
370 /\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
373 Probably a little too HACKY [WDP].
376 isWrapperFor :: CoreExpr -> Id -> Bool
378 expr `isWrapperFor` var
379 = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front
380 unravel_casing args body
381 --NO, THANKS: && not (null args)
384 var's_worker = getWorkerId (getIdStrictness var)
386 is_elem = isIn "isWrapperFor"
389 unravel_casing case_ables (Case scrut alts)
390 = case (collectArgs scrut) of { (fun, _, _, vargs) ->
394 scrut_var /= var && all (doesn't_mention var) vargs
395 && scrut_var `is_elem` case_ables
396 && unravel_alts case_ables alts
403 unravel_casing case_ables other_expr
404 = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
408 -- DOESN'T WORK: wrkr == var's_worker
411 && all (doesn't_mention var) vargs
412 && all (only_from case_ables) vargs
420 unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
421 = unravel_casing (params ++ case_ables) rhs
422 unravel_alts case_ables other = False
424 -------------------------
425 doesn't_mention var (ValArg (VarArg v)) = v /= var
426 doesn't_mention var other = True
428 -------------------------
429 only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
430 only_from case_ables other = True
434 All the following functions operate on binders, perform a uniform
435 transformation on them; ie. the function @(\ x -> (x,False))@
436 annotates all binders with False.
439 unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
440 unTagBinders expr = bop_expr fst expr
442 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
443 unTagBindersAlts alts = bop_alts fst alts
447 bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
449 bop_expr f (Var b) = Var b
450 bop_expr f (Lit lit) = Lit lit
451 bop_expr f (Con con args) = Con con args
452 bop_expr f (Prim op args) = Prim op args
453 bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
454 bop_expr f (App expr arg) = App (bop_expr f expr) arg
455 bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
456 bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
457 bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
459 bop_binder f (ValBinder v) = ValBinder (f v)
460 bop_binder f (TyBinder t) = TyBinder t
461 bop_binder f (UsageBinder u) = UsageBinder u
463 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
464 bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
466 bop_alts f (AlgAlts alts deflt)
467 = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
468 | (con, binders, e) <- alts ]
471 bop_alts f (PrimAlts alts deflt)
472 = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
475 bop_deflt f (NoDefault) = NoDefault
476 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
479 OLD (but left here because of the nice example): @singleAlt@ checks
480 whether a bunch of case alternatives is actually just one alternative.
481 It specifically {\em ignores} alternatives which consist of just a
482 call to @error@, because they won't result in any code duplication.
486 case (case <something> of
488 False -> error "Foo") of
494 True -> case <rhs> of
496 False -> case error "Foo" of
502 True -> case <rhs> of
506 Notice that the \tr{<alts>} don't get duplicated.
509 nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
512 = filter not_error_app (find_rhss alts)
514 find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
515 find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
517 deflt_rhs NoDefault = []
518 deflt_rhs (BindDefault _ rhs) = [rhs]
521 = case (maybeErrorApp rhs Nothing) of
526 maybeErrorApp checks whether an expression is of the form
532 Just (error ty' args)
534 where ty' is supplied as an argument to maybeErrorApp.
536 Here's where it is useful:
538 case (error ty "Foo" e1 e2) of <alts>
542 where ty' is the type of any of the alternatives. You might think
543 this never occurs, but see the comments on the definition of
546 Note: we *avoid* the case where ty' might end up as a primitive type:
547 this is very uncool (totally wrong).
549 NOTICE: in the example above we threw away e1 and e2, but not the
550 string "Foo". How did we know to do that?
552 Answer: for now anyway, we only handle the case of a function whose
555 bottomingFn :: forall a. t1 -> ... -> tn -> a
556 ^---------------------^ NB!
558 Furthermore, we only count a bottomingApp if the function is applied
559 to more than n args. If so, we transform:
561 bottomingFn ty e1 ... en en+1 ... em
563 bottomingFn ty' e1 ... en
565 That is, we discard en+1 .. em
569 :: GenCoreExpr a Id TyVar UVar -- 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 a Id TyVar UVar)
577 maybeErrorApp expr result_ty_maybe
578 = case (collectArgs expr) of
579 (Var fun, [{-no usage???-}], [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) ->
585 case (splitSigmaTy (idType fun)) of
586 ([tyvar], [], tau_ty) ->
587 case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
589 n_args_to_keep = length arg_tys
590 args_to_keep = take n_args_to_keep other_args
592 if (res_ty `eqTy` mkTyVarTy tyvar)
593 && n_args_to_keep <= length other_args
595 -- Phew! We're in business
596 Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
601 other -> Nothing -- Function type wrong shape
604 Just result_ty = result_ty_maybe
608 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
610 squashableDictishCcExpr cc expr
611 = if not (isDictCC cc) then
612 False -- that was easy...
614 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
616 squashable (Var _) = True
617 squashable (Con _ _) = True -- I think so... WDP 94/09
618 squashable (Prim _ _) = True -- ditto
620 | notValArg a = squashable f
621 squashable other = False
624 %************************************************************************
626 \subsection{Core-renaming utils}
628 %************************************************************************
631 substCoreBindings :: ValEnv
632 -> TypeEnv -- TyVar=>Type
634 -> UniqSM [CoreBinding]
636 substCoreExpr :: ValEnv
637 -> TypeEnv -- TyVar=>Type
641 substCoreBindings venv tenv binds
642 -- if the envs are empty, then avoid doing anything
643 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
646 do_CoreBindings venv tenv binds
648 substCoreExpr venv tenv expr
649 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
652 do_CoreExpr venv tenv expr
655 The equiv code for @Types@ is in @TyUtils@.
657 Because binders aren't necessarily unique: we don't do @plusEnvs@
658 (which check for duplicates); rather, we use the shadowing version,
659 @growIdEnv@ (and shorthand @addOneToIdEnv@).
661 @do_CoreBindings@ takes into account the semantics of a list of
662 @CoreBindings@---things defined early in the list are visible later in
663 the list, but not vice versa.
666 type ValEnv = IdEnv CoreExpr
668 do_CoreBindings :: ValEnv
671 -> UniqSM [CoreBinding]
673 do_CoreBinding :: ValEnv
676 -> UniqSM (CoreBinding, ValEnv)
678 do_CoreBindings venv tenv [] = returnUs []
679 do_CoreBindings venv tenv (b:bs)
680 = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
681 do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
682 returnUs (new_b : new_bs)
684 do_CoreBinding venv tenv (NonRec binder rhs)
685 = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
687 dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
688 -- now plug new bindings into envs
689 let new_venv = addOneToIdEnv venv old new in
691 returnUs (NonRec new_binder new_rhs, new_venv)
693 do_CoreBinding venv tenv (Rec binds)
694 = -- for letrec, we plug in new bindings BEFORE cloning rhss
695 mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
696 let new_venv = growIdEnvList venv new_maps in
698 mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
699 returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv)
701 (binders, rhss) = unzip binds
710 do_CoreArg venv tenv (LitArg lit) = returnUs (Lit lit)
711 do_CoreArg venv tenv (TyArg ty) = panic "do_CoreArg: TyArg"
712 do_CoreArg venv tenv (UsageArg usage) = panic "do_CoreArg: UsageArg"
713 do_CoreArg venv tenv (VarArg v)
715 case (lookupIdEnv venv v) of
716 Nothing -> --false:ASSERT(toplevelishId v)
723 do_CoreExpr :: ValEnv
728 do_CoreExpr venv tenv orig_expr@(Var var)
730 case (lookupIdEnv venv var) of
731 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
736 do_CoreExpr venv tenv e@(Lit _) = returnUs e
738 do_CoreExpr venv tenv (Con con as)
739 = panic "CoreUtils.do_CoreExpr:Con"
741 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
745 do_CoreExpr venv tenv (Prim op as)
746 = panic "CoreUtils.do_CoreExpr:Prim"
748 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
749 do_PrimOp op `thenUs` \ new_op ->
750 mkCoPrim new_op new_as
752 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
754 new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
755 new_result_ty = applyTypeEnvToTy tenv result_ty
757 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
759 do_PrimOp other_op = returnUs other_op
762 do_CoreExpr venv tenv (Lam binder expr)
763 = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
764 let new_venv = addOneToIdEnv venv old new in
765 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
766 returnUs (Lam new_binder new_expr)
768 do_CoreExpr venv tenv (App expr arg)
769 = panic "CoreUtils.do_CoreExpr:App"
771 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
772 do_CoreArg venv tenv arg `thenUs` \ new_arg ->
773 mkCoApp new_expr new_arg
776 do_CoreExpr venv tenv (Case expr alts)
777 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
778 do_alts venv tenv alts `thenUs` \ new_alts ->
779 returnUs (Case new_expr new_alts)
781 do_alts venv tenv (AlgAlts alts deflt)
782 = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
783 do_default venv tenv deflt `thenUs` \ new_deflt ->
784 returnUs (AlgAlts new_alts new_deflt)
786 do_boxed_alt venv tenv (con, binders, expr)
787 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
788 let new_venv = growIdEnvList venv new_vmaps in
789 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
790 returnUs (con, new_binders, new_expr)
793 do_alts venv tenv (PrimAlts alts deflt)
794 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
795 do_default venv tenv deflt `thenUs` \ new_deflt ->
796 returnUs (PrimAlts new_alts new_deflt)
798 do_unboxed_alt venv tenv (lit, expr)
799 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
800 returnUs (lit, new_expr)
802 do_default venv tenv NoDefault = returnUs NoDefault
804 do_default venv tenv (BindDefault binder expr)
805 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
806 let new_venv = addOneToIdEnv venv old new in
807 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
808 returnUs (BindDefault new_binder new_expr)
810 do_CoreExpr venv tenv (Let core_bind expr)
811 = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
812 -- and do the body of the let
813 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
814 returnUs (Let new_bind new_expr)
816 do_CoreExpr venv tenv (SCC label expr)
817 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
818 returnUs (SCC label new_expr)