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_DELOOPER(IdLoop) -- for pananoia-checking purposes
33 import CostCentre ( isDictCC )
34 import Id ( idType, mkSysLocal, getIdArity, isBottomingId,
35 toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
36 addOneToIdEnv, growIdEnvList, lookupIdEnv,
37 isNullIdEnv, SYN_IE(IdEnv),
40 import IdInfo ( arityMaybe )
41 import Literal ( literalType, isNoRepLit, Literal(..) )
42 import Maybes ( catMaybes, maybeToBool )
44 import PprStyle ( PprStyle(..) )
45 import PprType ( GenType{-instances-} )
46 import Pretty ( ppAboves )
47 import PrelVals ( augmentId, buildId )
48 import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) )
49 import SrcLoc ( mkUnknownSrcLoc )
50 import TyVar ( cloneTyVar,
51 isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
53 import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
54 getFunTy_maybe, applyTy, isPrimType,
55 splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
57 import TysWiredIn ( trueDataCon, falseDataCon )
58 import UniqSupply ( initUs, returnUs, thenUs,
59 mapUs, mapAndUnzipUs, getUnique,
60 SYN_IE(UniqSM), UniqSupply
62 import Usage ( SYN_IE(UVar) )
63 import Util ( zipEqual, panic, pprPanic, assertPanic )
65 type TypeEnv = TyVarEnv Type
66 applyUsage = panic "CoreUtils.applyUsage:ToDo"
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 coreExprType (Coerce _ ty _) = ty -- that's the whole point!
87 -- a Con is a fully-saturated application of a data constructor
88 -- a Prim is <ditto> of a PrimOp
90 coreExprType (Con con args) = applyTypeToArgs (idType con) args
91 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
93 coreExprType (Lam (ValBinder binder) expr)
94 = idType binder `mkFunTy` coreExprType expr
96 coreExprType (Lam (TyBinder tyvar) expr)
97 = mkForAllTy tyvar (coreExprType expr)
99 coreExprType (Lam (UsageBinder uvar) expr)
100 = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
102 coreExprType (App expr (TyArg ty))
103 = applyTy (coreExprType expr) ty
105 coreExprType (App expr (UsageArg use))
106 = applyUsage (coreExprType expr) use
108 coreExprType (App expr val_arg)
109 = ASSERT(isValArg val_arg)
111 fun_ty = coreExprType expr
113 case (getFunTy_maybe fun_ty) of
114 Just (_, result_ty) -> result_ty
116 Nothing -> pprPanic "coreExprType:\n"
117 (ppAboves [ppr PprDebug fun_ty,
118 ppr PprShowAll (App expr val_arg)])
123 coreAltsType :: CoreCaseAlts -> Type
125 coreAltsType (AlgAlts [] deflt) = default_ty deflt
126 coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
128 coreAltsType (PrimAlts [] deflt) = default_ty deflt
129 coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
131 default_ty NoDefault = panic "coreExprType:Case:default_ty"
132 default_ty (BindDefault _ rhs) = coreExprType rhs
136 applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args
138 applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
139 applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg"
140 applyTypeToArg op_ty val_or_lit_arg = case (getFunTy_maybe op_ty) of
141 Just (_, res_ty) -> res_ty
144 %************************************************************************
146 \subsection{Routines to manufacture bits of @CoreExpr@}
148 %************************************************************************
151 mkCoreIfThenElse (Var bool) then_expr else_expr
152 | bool == trueDataCon = then_expr
153 | bool == falseDataCon = else_expr
155 mkCoreIfThenElse guard then_expr else_expr
157 (AlgAlts [ (trueDataCon, [], then_expr),
158 (falseDataCon, [], else_expr) ]
162 For making @Apps@ and @Lets@, we must take appropriate evasive
163 action if the thing being bound has unboxed type. @mkCoApp@ requires
164 a name supply to do its work.
166 @mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
167 arguments-must-be-atoms constraint.
174 mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
175 mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
176 mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
178 mkCoApps fun args = co_thing (mkGenApp fun) args
179 mkCoCon con args = co_thing (Con con) args
180 mkCoPrim op args = co_thing (Prim op) args
182 co_thing :: ([CoreArg] -> CoreExpr)
186 co_thing thing arg_exprs
187 = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
188 returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
190 expr_to_arg :: CoreArgOrExpr
191 -> UniqSM (CoreArg, Maybe CoreBinding)
193 expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
194 expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
195 expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
196 expr_to_arg (AnExpr other_expr)
198 e_ty = coreExprType other_expr
200 getUnique `thenUs` \ uniq ->
202 new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
204 returnUs (VarArg new_var, Just (NonRec new_var other_expr))
209 GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
211 argToExpr (VarArg v) = Var v
212 argToExpr (LitArg lit) = Lit lit
216 exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
217 exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
218 exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
219 exprSmallEnoughToDup expr
220 = case (collectArgs expr) of { (fun, _, _, vargs) ->
222 Var v | length vargs == 0 -> True
228 exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
229 = case (collectArgs expr) of { (fun, _, _, vargs) ->
231 Var v -> v /= buildId
233 && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
238 Question (ADR): What is the above used for? Is a _ccall_ really small
241 @manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
242 it is obviously in weak head normal form. It isn't a disaster if it
243 errs on the conservative side (returning \tr{False})---I've probably
244 left something out... [WDP]
247 manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool
249 manifestlyWHNF (Var _) = True
250 manifestlyWHNF (Lit _) = True
251 manifestlyWHNF (Con _ _) = True
252 manifestlyWHNF (SCC _ e) = manifestlyWHNF e
253 manifestlyWHNF (Coerce _ _ e) = manifestlyWHNF e
254 manifestlyWHNF (Let _ e) = False
255 manifestlyWHNF (Case _ _) = False
257 manifestlyWHNF (Lam x e) = if isValBinder x then True else manifestlyWHNF e
259 manifestlyWHNF other_expr -- look for manifest partial application
260 = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
263 num_val_args = length vargs
265 num_val_args == 0 -- Just a type application of
266 -- a variable (f t1 t2 t3);
269 case (arityMaybe (getIdArity f)) of
271 Just arity -> num_val_args < arity
277 @manifestlyBottom@ looks at a Core expression and returns \tr{True} if
278 it is obviously bottom, that is, it will certainly return bottom at
279 some point. It isn't a disaster if it errs on the conservative side
280 (returning \tr{False}).
283 manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
285 manifestlyBottom (Var v) = isBottomingId v
286 manifestlyBottom (Lit _) = False
287 manifestlyBottom (Con _ _) = False
288 manifestlyBottom (Prim _ _) = False
289 manifestlyBottom (SCC _ e) = manifestlyBottom e
290 manifestlyBottom (Coerce _ _ e) = manifestlyBottom e
291 manifestlyBottom (Let _ e) = manifestlyBottom e
293 -- We do not assume \x.bottom == bottom:
294 manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e
296 manifestlyBottom (Case e a)
299 AlgAlts alts def -> all mbalg alts && mbdef def
300 PrimAlts alts def -> all mbprim alts && mbdef def
303 mbalg (_,_,e') = manifestlyBottom e'
305 mbprim (_,e') = manifestlyBottom e'
307 mbdef NoDefault = True
308 mbdef (BindDefault _ e') = manifestlyBottom e'
310 manifestlyBottom other_expr -- look for manifest partial application
311 = case (collectArgs other_expr) of { (fun, _, _, _) ->
313 Var f | isBottomingId f -> True
314 -- Application of a function which always gives
315 -- bottom; we treat this as a WHNF, because it
316 -- certainly doesn't need to be shared!
324 :: (Id -> Maybe (GenCoreExpr bndr Id))
325 -> GenCoreExpr bndr Id
327 coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
328 coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
329 coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
330 coreExprArity f (CoTyApp expr _) = coreExprArity f expr
331 coreExprArity f (Var v) = max further info
336 Just expr -> coreExprArity f expr
337 info = case (arityMaybe (getIdArity v)) of
340 coreExprArity f _ = 0
343 @isWrapperFor@: we want to see exactly:
345 /\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
348 Probably a little too HACKY [WDP].
351 isWrapperFor :: CoreExpr -> Id -> Bool
353 expr `isWrapperFor` var
354 = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front
355 unravel_casing args body
356 --NO, THANKS: && not (null args)
359 var's_worker = getWorkerId (getIdStrictness var)
361 is_elem = isIn "isWrapperFor"
364 unravel_casing case_ables (Case scrut alts)
365 = case (collectArgs scrut) of { (fun, _, _, vargs) ->
369 scrut_var /= var && all (doesn't_mention var) vargs
370 && scrut_var `is_elem` case_ables
371 && unravel_alts case_ables alts
378 unravel_casing case_ables other_expr
379 = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
383 -- DOESN'T WORK: wrkr == var's_worker
386 && all (doesn't_mention var) vargs
387 && all (only_from case_ables) vargs
395 unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
396 = unravel_casing (params ++ case_ables) rhs
397 unravel_alts case_ables other = False
399 -------------------------
400 doesn't_mention var (ValArg (VarArg v)) = v /= var
401 doesn't_mention var other = True
403 -------------------------
404 only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
405 only_from case_ables other = True
409 All the following functions operate on binders, perform a uniform
410 transformation on them; ie. the function @(\ x -> (x,False))@
411 annotates all binders with False.
414 unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
415 unTagBinders expr = bop_expr fst expr
417 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
418 unTagBindersAlts alts = bop_alts fst alts
422 bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
424 bop_expr f (Var b) = Var b
425 bop_expr f (Lit lit) = Lit lit
426 bop_expr f (Con con args) = Con con args
427 bop_expr f (Prim op args) = Prim op args
428 bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
429 bop_expr f (App expr arg) = App (bop_expr f expr) arg
430 bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
431 bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
432 bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
433 bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
435 bop_binder f (ValBinder v) = ValBinder (f v)
436 bop_binder f (TyBinder t) = TyBinder t
437 bop_binder f (UsageBinder u) = UsageBinder u
439 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
440 bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
442 bop_alts f (AlgAlts alts deflt)
443 = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
444 | (con, binders, e) <- alts ]
447 bop_alts f (PrimAlts alts deflt)
448 = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
451 bop_deflt f (NoDefault) = NoDefault
452 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
455 OLD (but left here because of the nice example): @singleAlt@ checks
456 whether a bunch of case alternatives is actually just one alternative.
457 It specifically {\em ignores} alternatives which consist of just a
458 call to @error@, because they won't result in any code duplication.
462 case (case <something> of
464 False -> error "Foo") of
470 True -> case <rhs> of
472 False -> case error "Foo" of
478 True -> case <rhs> of
482 Notice that the \tr{<alts>} don't get duplicated.
485 nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
488 = filter not_error_app (find_rhss alts)
490 find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
491 find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
493 deflt_rhs NoDefault = []
494 deflt_rhs (BindDefault _ rhs) = [rhs]
497 = case (maybeErrorApp rhs Nothing) of
502 maybeErrorApp checks whether an expression is of the form
508 Just (error ty' args)
510 where ty' is supplied as an argument to maybeErrorApp.
512 Here's where it is useful:
514 case (error ty "Foo" e1 e2) of <alts>
518 where ty' is the type of any of the alternatives. You might think
519 this never occurs, but see the comments on the definition of
522 Note: we *avoid* the case where ty' might end up as a primitive type:
523 this is very uncool (totally wrong).
525 NOTICE: in the example above we threw away e1 and e2, but not the
526 string "Foo". How did we know to do that?
528 Answer: for now anyway, we only handle the case of a function whose
531 bottomingFn :: forall a. t1 -> ... -> tn -> a
532 ^---------------------^ NB!
534 Furthermore, we only count a bottomingApp if the function is applied
535 to more than n args. If so, we transform:
537 bottomingFn ty e1 ... en en+1 ... em
539 bottomingFn ty' e1 ... en
541 That is, we discard en+1 .. em
545 :: GenCoreExpr a Id TyVar UVar -- Expr to look at
546 -> Maybe Type -- Just ty => a result type *already cloned*;
547 -- Nothing => don't know result ty; we
548 -- *pretend* that the result ty won't be
549 -- primitive -- somebody later must
551 -> Maybe (GenCoreExpr a Id TyVar UVar)
553 maybeErrorApp expr result_ty_maybe
554 = case (collectArgs expr) of
555 (Var fun, [{-no usage???-}], [ty], other_args)
557 && maybeToBool result_ty_maybe -- we *know* the result type
558 -- (otherwise: live a fairy-tale existence...)
559 && not (isPrimType result_ty) ->
561 case (splitSigmaTy (idType fun)) of
562 ([tyvar], [], tau_ty) ->
563 case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
565 n_args_to_keep = length arg_tys
566 args_to_keep = take n_args_to_keep other_args
568 if (res_ty `eqTy` mkTyVarTy tyvar)
569 && n_args_to_keep <= length other_args
571 -- Phew! We're in business
572 Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
577 other -> Nothing -- Function type wrong shape
580 Just result_ty = result_ty_maybe
584 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
586 squashableDictishCcExpr cc expr
587 = if not (isDictCC cc) then
588 False -- that was easy...
590 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
592 squashable (Var _) = True
593 squashable (Con _ _) = True -- I think so... WDP 94/09
594 squashable (Prim _ _) = True -- ditto
596 | notValArg a = squashable f
597 squashable other = False
600 %************************************************************************
602 \subsection{Core-renaming utils}
604 %************************************************************************
607 substCoreBindings :: ValEnv
608 -> TypeEnv -- TyVar=>Type
610 -> UniqSM [CoreBinding]
612 substCoreExpr :: ValEnv
613 -> TypeEnv -- TyVar=>Type
617 substCoreBindings venv tenv binds
618 -- if the envs are empty, then avoid doing anything
619 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
622 do_CoreBindings venv tenv binds
624 substCoreExpr venv tenv expr
625 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
628 do_CoreExpr venv tenv expr
631 The equiv code for @Types@ is in @TyUtils@.
633 Because binders aren't necessarily unique: we don't do @plusEnvs@
634 (which check for duplicates); rather, we use the shadowing version,
635 @growIdEnv@ (and shorthand @addOneToIdEnv@).
637 @do_CoreBindings@ takes into account the semantics of a list of
638 @CoreBindings@---things defined early in the list are visible later in
639 the list, but not vice versa.
642 type ValEnv = IdEnv CoreExpr
644 do_CoreBindings :: ValEnv
647 -> UniqSM [CoreBinding]
649 do_CoreBinding :: ValEnv
652 -> UniqSM (CoreBinding, ValEnv)
654 do_CoreBindings venv tenv [] = returnUs []
655 do_CoreBindings venv tenv (b:bs)
656 = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
657 do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
658 returnUs (new_b : new_bs)
660 do_CoreBinding venv tenv (NonRec binder rhs)
661 = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
663 dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
664 -- now plug new bindings into envs
665 let new_venv = addOneToIdEnv venv old new in
667 returnUs (NonRec new_binder new_rhs, new_venv)
669 do_CoreBinding venv tenv (Rec binds)
670 = -- for letrec, we plug in new bindings BEFORE cloning rhss
671 mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
672 let new_venv = growIdEnvList venv new_maps in
674 mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
675 returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
677 (binders, rhss) = unzip binds
684 -> UniqSM CoreArgOrExpr
686 do_CoreArg venv tenv a@(VarArg v)
688 case (lookupIdEnv venv v) of
690 Just expr -> AnExpr expr
693 do_CoreArg venv tenv (TyArg ty)
694 = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
696 do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
700 do_CoreExpr :: ValEnv
705 do_CoreExpr venv tenv orig_expr@(Var var)
707 case (lookupIdEnv venv var) of
708 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
713 do_CoreExpr venv tenv e@(Lit _) = returnUs e
715 do_CoreExpr venv tenv (Con con as)
716 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
719 do_CoreExpr venv tenv (Prim op as)
720 = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
721 do_PrimOp op `thenUs` \ new_op ->
722 mkCoPrim new_op new_as
724 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
726 new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
727 new_result_ty = applyTypeEnvToTy tenv result_ty
729 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
731 do_PrimOp other_op = returnUs other_op
733 do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
734 = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
735 let new_venv = addOneToIdEnv venv old new in
736 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
737 returnUs (Lam (ValBinder new_binder) new_expr)
739 do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
740 = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) ->
742 new_tenv = addOneToTyVarEnv tenv old new
744 do_CoreExpr venv new_tenv expr `thenUs` \ new_expr ->
745 returnUs (Lam (TyBinder new_tyvar) new_expr)
747 do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder"
749 do_CoreExpr venv tenv (App expr arg)
750 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
751 do_CoreArg venv tenv arg `thenUs` \ new_arg ->
752 mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
754 do_CoreExpr venv tenv (Case expr alts)
755 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
756 do_alts venv tenv alts `thenUs` \ new_alts ->
757 returnUs (Case new_expr new_alts)
759 do_alts venv tenv (AlgAlts alts deflt)
760 = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
761 do_default venv tenv deflt `thenUs` \ new_deflt ->
762 returnUs (AlgAlts new_alts new_deflt)
764 do_boxed_alt venv tenv (con, binders, expr)
765 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
766 let new_venv = growIdEnvList venv new_vmaps in
767 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
768 returnUs (con, new_binders, new_expr)
771 do_alts venv tenv (PrimAlts alts deflt)
772 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
773 do_default venv tenv deflt `thenUs` \ new_deflt ->
774 returnUs (PrimAlts new_alts new_deflt)
776 do_unboxed_alt venv tenv (lit, expr)
777 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
778 returnUs (lit, new_expr)
780 do_default venv tenv NoDefault = returnUs NoDefault
782 do_default venv tenv (BindDefault binder expr)
783 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
784 let new_venv = addOneToIdEnv venv old new in
785 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
786 returnUs (BindDefault new_binder new_expr)
788 do_CoreExpr venv tenv (Let core_bind expr)
789 = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
790 -- and do the body of the let
791 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
792 returnUs (Let new_bind new_expr)
794 do_CoreExpr venv tenv (SCC label expr)
795 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
796 returnUs (SCC label new_expr)
798 do_CoreExpr venv tenv (Coerce c ty expr)
799 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
800 returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
804 dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
806 = getUnique `thenUs` \ uniq ->
807 let new_tyvar = cloneTyVar tyvar uniq in
808 returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
810 -- same thing all over again --------------------
812 dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
814 = if (toplevelishId b) then
815 -- binder is "top-level-ish"; -- it should *NOT* be renamed
816 -- ToDo: it's unsavoury that we return something to heave in env
817 returnUs (b, (b, Var b))
819 else -- otherwise, the full business
820 getUnique `thenUs` \ uniq ->
822 new_b1 = mkIdWithNewUniq b uniq
823 new_b2 = applyTypeEnvToId tenv new_b1
825 returnUs (new_b2, (b, Var new_b2))