[project @ 1996-12-19 09:10:02 by simonpj]
[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreUtils.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 %
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
5
6 \begin{code}
7 #include "HsVersions.h"
8
9 module CoreUtils (
10         coreExprType, coreAltsType, coreExprCc,
11
12         substCoreExpr, substCoreBindings
13
14         , mkCoreIfThenElse
15         , argToExpr
16         , unTagBinders, unTagBindersAlts
17
18         , maybeErrorApp
19         , nonErrorRHSs
20         , squashableDictishCcExpr
21     ) where
22
23 IMP_Ubiq()
24 IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes
25
26 import CoreSyn
27
28 import CostCentre       ( isDictCC, CostCentre, noCostCentre )
29 import Id               ( idType, mkSysLocal, isBottomingId,
30                           toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
31                           dataConRepType,
32                           addOneToIdEnv, growIdEnvList, lookupIdEnv,
33                           isNullIdEnv, SYN_IE(IdEnv),
34                           GenId{-instances-}
35                         )
36 import Literal          ( literalType, isNoRepLit, Literal(..) )
37 import Maybes           ( catMaybes, maybeToBool )
38 import PprCore
39 import PprStyle         ( PprStyle(..) )
40 import PprType          ( GenType{-instances-} )
41 import Pretty           ( ppAboves, ppStr )
42 import PrelVals         ( augmentId, buildId )
43 import PrimOp           ( primOpType, PrimOp(..) )
44 import SrcLoc           ( noSrcLoc )
45 import TyVar            ( cloneTyVar,
46                           isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
47                         )
48 import Type             ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
49                           getFunTyExpandingDicts_maybe, applyTy, isPrimType,
50                           splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
51                         )
52 import TysWiredIn       ( trueDataCon, falseDataCon )
53 import UniqSupply       ( initUs, returnUs, thenUs,
54                           mapUs, mapAndUnzipUs, getUnique,
55                           SYN_IE(UniqSM), UniqSupply
56                         )
57 import Usage            ( SYN_IE(UVar) )
58 import Util             ( zipEqual, panic, pprPanic, assertPanic )
59
60 type TypeEnv = TyVarEnv Type
61 applyUsage = panic "CoreUtils.applyUsage:ToDo"
62 \end{code}
63
64 %************************************************************************
65 %*                                                                      *
66 \subsection{Find the type of a Core atom/expression}
67 %*                                                                      *
68 %************************************************************************
69
70 \begin{code}
71 coreExprType :: CoreExpr -> Type
72
73 coreExprType (Var var) = idType   var
74 coreExprType (Lit lit) = literalType lit
75
76 coreExprType (Let _ body)       = coreExprType body
77 coreExprType (SCC _ expr)       = coreExprType expr
78 coreExprType (Case _ alts)      = coreAltsType alts
79
80 coreExprType (Coerce _ ty _)    = ty -- that's the whole point!
81
82 -- a Con is a fully-saturated application of a data constructor
83 -- a Prim is <ditto> of a PrimOp
84
85 coreExprType (Con con args) = applyTypeToArgs (dataConRepType    con) args
86 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
87
88 coreExprType (Lam (ValBinder binder) expr)
89   = idType binder `mkFunTy` coreExprType expr
90
91 coreExprType (Lam (TyBinder tyvar) expr)
92   = mkForAllTy tyvar (coreExprType expr)
93
94 coreExprType (Lam (UsageBinder uvar) expr)
95   = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
96
97 coreExprType (App expr (TyArg ty))
98   = applyTy (coreExprType expr) ty
99
100 coreExprType (App expr (UsageArg use))
101   = applyUsage (coreExprType expr) use
102
103 coreExprType (App expr val_arg)
104   = ASSERT(isValArg val_arg)
105     let
106         fun_ty = coreExprType expr
107     in
108     case (getFunTyExpandingDicts_maybe False{-no peeking-} fun_ty) of
109           Just (_, result_ty) -> result_ty
110 #ifdef DEBUG
111           Nothing -> pprPanic "coreExprType:\n"
112                 (ppAboves [ppr PprDebug fun_ty,
113                            ppr PprShowAll (App expr val_arg)])
114 #endif
115 \end{code}
116
117 \begin{code}
118 coreAltsType :: CoreCaseAlts -> Type
119
120 coreAltsType (AlgAlts [] deflt)         = default_ty deflt
121 coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
122
123 coreAltsType (PrimAlts [] deflt)       = default_ty deflt
124 coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
125
126 default_ty NoDefault           = panic "coreExprType:Case:default_ty"
127 default_ty (BindDefault _ rhs) = coreExprType rhs
128 \end{code}
129
130 \begin{code}
131 applyTypeToArgs op_ty args          = foldl applyTypeToArg op_ty args
132
133 applyTypeToArg op_ty (TyArg ty)     = applyTy op_ty ty
134 applyTypeToArg op_ty (UsageArg _)   = panic "applyTypeToArg: UsageArg"
135 applyTypeToArg op_ty val_or_lit_arg = case (getFunTyExpandingDicts_maybe False{-no peeking-} op_ty) of
136                                         Just (_, res_ty) -> res_ty
137 \end{code}
138
139 coreExprCc gets the cost centre enclosing an expression, if any.
140 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
141
142 \begin{code}
143 coreExprCc :: GenCoreExpr val_bdr val_occ tyvar uvar -> CostCentre
144 coreExprCc (SCC cc e) = cc
145 coreExprCc (Lam _ e)  = coreExprCc e
146 coreExprCc other      = noCostCentre
147 \end{code}
148
149 %************************************************************************
150 %*                                                                      *
151 \subsection{Routines to manufacture bits of @CoreExpr@}
152 %*                                                                      *
153 %************************************************************************
154
155 \begin{code}
156 mkCoreIfThenElse (Var bool) then_expr else_expr
157     | bool == trueDataCon   = then_expr
158     | bool == falseDataCon  = else_expr
159
160 mkCoreIfThenElse guard then_expr else_expr
161   = Case guard
162       (AlgAlts [ (trueDataCon,  [], then_expr),
163                  (falseDataCon, [], else_expr) ]
164        NoDefault )
165 \end{code}
166
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.
170
171 @mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
172 arguments-must-be-atoms constraint.
173
174 \begin{code}
175 data CoreArgOrExpr
176   = AnArg   CoreArg
177   | AnExpr  CoreExpr
178
179 mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
180 mkCoCon  :: Id       -> [CoreArgOrExpr] -> UniqSM CoreExpr
181 mkCoPrim :: PrimOp   -> [CoreArgOrExpr] -> UniqSM CoreExpr
182
183 mkCoApps fun args = co_thing (mkGenApp fun) args
184 mkCoCon  con args = co_thing (Con  con)     args
185 mkCoPrim  op args = co_thing (Prim op)      args 
186
187 co_thing :: ([CoreArg] -> CoreExpr)
188          -> [CoreArgOrExpr]
189          -> UniqSM CoreExpr
190
191 co_thing thing arg_exprs
192   = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
193     returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
194   where
195     expr_to_arg :: CoreArgOrExpr
196                 -> UniqSM (CoreArg, Maybe CoreBinding)
197
198     expr_to_arg (AnArg  arg)     = returnUs (arg,      Nothing)
199     expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
200     expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
201     expr_to_arg (AnExpr other_expr)
202       = let
203             e_ty = coreExprType other_expr
204         in
205         getUnique `thenUs` \ uniq ->
206         let
207             new_var  = mkSysLocal SLIT("a") uniq e_ty noSrcLoc
208         in
209         returnUs (VarArg new_var, Just (NonRec new_var other_expr))
210 \end{code}
211
212 \begin{code}
213 argToExpr ::
214   GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
215
216 argToExpr (VarArg v)   = Var v
217 argToExpr (LitArg lit) = Lit lit
218 \end{code}
219
220 All the following functions operate on binders, perform a uniform
221 transformation on them; ie. the function @(\ x -> (x,False))@
222 annotates all binders with False.
223
224 \begin{code}
225 unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
226 unTagBinders expr = bop_expr fst expr
227
228 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
229 unTagBindersAlts alts = bop_alts fst alts
230 \end{code}
231
232 \begin{code}
233 bop_expr  :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
234
235 bop_expr f (Var b)           = Var b
236 bop_expr f (Lit lit)         = Lit lit
237 bop_expr f (Con con args)    = Con con args
238 bop_expr f (Prim op args)    = Prim op args
239 bop_expr f (Lam binder expr) = Lam  (bop_binder f binder) (bop_expr f expr)
240 bop_expr f (App expr arg)    = App  (bop_expr f expr) arg
241 bop_expr f (SCC label expr)  = SCC  label (bop_expr f expr)
242 bop_expr f (Coerce c ty e)   = Coerce c ty (bop_expr f e)
243 bop_expr f (Let bind expr)   = Let  (bop_bind f bind) (bop_expr f expr)
244 bop_expr f (Case expr alts)  = Case (bop_expr f expr) (bop_alts f alts)
245
246 bop_binder f (ValBinder   v) = ValBinder (f v)
247 bop_binder f (TyBinder    t) = TyBinder    t
248 bop_binder f (UsageBinder u) = UsageBinder u
249
250 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
251 bop_bind f (Rec pairs)  = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
252
253 bop_alts f (AlgAlts alts deflt)
254   = AlgAlts  [ (con, [f b | b <- binders], bop_expr f e)
255              | (con, binders, e) <- alts ]
256              (bop_deflt f deflt)
257
258 bop_alts f (PrimAlts alts deflt)
259   = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
260              (bop_deflt f deflt)
261
262 bop_deflt f (NoDefault)          = NoDefault
263 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
264 \end{code}
265
266 OLD (but left here because of the nice example): @singleAlt@ checks
267 whether a bunch of case alternatives is actually just one alternative.
268 It specifically {\em ignores} alternatives which consist of just a
269 call to @error@, because they won't result in any code duplication.
270
271 Example:
272 \begin{verbatim}
273         case (case <something> of
274                 True  -> <rhs>
275                 False -> error "Foo") of
276         <alts>
277
278 ===>
279
280         case <something> of
281            True ->  case <rhs> of
282                     <alts>
283            False -> case error "Foo" of
284                     <alts>
285
286 ===>
287
288         case <something> of
289            True ->  case <rhs> of
290                     <alts>
291            False -> error "Foo"
292 \end{verbatim}
293 Notice that the \tr{<alts>} don't get duplicated.
294
295 \begin{code}
296 nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
297
298 nonErrorRHSs alts
299   = filter not_error_app (find_rhss alts)
300   where
301     find_rhss (AlgAlts  as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
302     find_rhss (PrimAlts as deflt) = [rhs | (_,rhs)   <- as] ++ deflt_rhs deflt
303
304     deflt_rhs NoDefault           = []
305     deflt_rhs (BindDefault _ rhs) = [rhs]
306
307     not_error_app rhs
308       = case (maybeErrorApp rhs Nothing) of
309           Just _  -> False
310           Nothing -> True
311 \end{code}
312
313 maybeErrorApp checks whether an expression is of the form
314
315         error ty args
316
317 If so, it returns
318
319         Just (error ty' args)
320
321 where ty' is supplied as an argument to maybeErrorApp.
322
323 Here's where it is useful:
324
325                 case (error ty "Foo" e1 e2) of <alts>
326  ===>
327                 error ty' "Foo"
328
329 where ty' is the type of any of the alternatives.  You might think
330 this never occurs, but see the comments on the definition of
331 @singleAlt@.
332
333 Note: we *avoid* the case where ty' might end up as a primitive type:
334 this is very uncool (totally wrong).
335
336 NOTICE: in the example above we threw away e1 and e2, but not the
337 string "Foo".  How did we know to do that?
338
339 Answer: for now anyway, we only handle the case of a function whose
340 type is of form
341
342         bottomingFn :: forall a. t1 -> ... -> tn -> a
343                               ^---------------------^ NB!
344
345 Furthermore, we only count a bottomingApp if the function is applied
346 to more than n args.  If so, we transform:
347
348         bottomingFn ty e1 ... en en+1 ... em
349 to
350         bottomingFn ty' e1 ... en
351
352 That is, we discard en+1 .. em
353
354 \begin{code}
355 maybeErrorApp
356         :: GenCoreExpr a Id TyVar UVar  -- Expr to look at
357         -> Maybe Type                   -- Just ty => a result type *already cloned*;
358                                         -- Nothing => don't know result ty; we
359                                         -- *pretend* that the result ty won't be
360                                         -- primitive -- somebody later must
361                                         -- ensure this.
362         -> Maybe (GenCoreExpr a Id TyVar UVar)
363
364 maybeErrorApp expr result_ty_maybe
365   = case (collectArgs expr) of
366       (Var fun, [{-no usage???-}], [ty], other_args)
367         | isBottomingId fun
368         && maybeToBool result_ty_maybe -- we *know* the result type
369                                        -- (otherwise: live a fairy-tale existence...)
370         && not (isPrimType result_ty) ->
371
372         case (splitSigmaTy (idType fun)) of
373           ([tyvar], [], tau_ty) ->
374               case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
375               let
376                   n_args_to_keep = length arg_tys
377                   args_to_keep   = take n_args_to_keep other_args
378               in
379               if  (res_ty `eqTy` mkTyVarTy tyvar)
380                && n_args_to_keep <= length other_args
381               then
382                     -- Phew!  We're in business
383                   Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
384               else
385                   Nothing
386               }
387
388           other -> Nothing  -- Function type wrong shape
389       other -> Nothing
390   where
391     Just result_ty = result_ty_maybe
392 \end{code}
393
394 \begin{code}
395 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
396
397 squashableDictishCcExpr cc expr
398   = if not (isDictCC cc) then
399         False -- that was easy...
400     else
401         squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
402   where
403     squashable (Var _)      = True
404     squashable (Con  _ _)   = True -- I think so... WDP 94/09
405     squashable (Prim _ _)   = True -- ditto
406     squashable (App f a)
407       | notValArg a         = squashable f
408     squashable other        = False
409 \end{code}
410
411 %************************************************************************
412 %*                                                                      *
413 \subsection{Core-renaming utils}
414 %*                                                                      *
415 %************************************************************************
416
417 \begin{code}
418 substCoreBindings :: ValEnv
419                 -> TypeEnv -- TyVar=>Type
420                 -> [CoreBinding]
421                 -> UniqSM [CoreBinding]
422
423 substCoreExpr   :: ValEnv
424                 -> TypeEnv -- TyVar=>Type
425                 -> CoreExpr
426                 -> UniqSM CoreExpr
427
428 substCoreBindings venv tenv binds
429   -- if the envs are empty, then avoid doing anything
430   = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
431        returnUs binds
432     else
433        do_CoreBindings venv tenv binds
434
435 substCoreExpr venv tenv expr
436   = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
437        returnUs expr
438     else
439        do_CoreExpr venv tenv expr
440 \end{code}
441
442 The equiv code for @Types@ is in @TyUtils@.
443
444 Because binders aren't necessarily unique: we don't do @plusEnvs@
445 (which check for duplicates); rather, we use the shadowing version,
446 @growIdEnv@ (and shorthand @addOneToIdEnv@).
447
448 @do_CoreBindings@ takes into account the semantics of a list of
449 @CoreBindings@---things defined early in the list are visible later in
450 the list, but not vice versa.
451
452 \begin{code}
453 type ValEnv  = IdEnv CoreExpr
454
455 do_CoreBindings :: ValEnv
456                 -> TypeEnv
457                 -> [CoreBinding]
458                 -> UniqSM [CoreBinding]
459
460 do_CoreBinding :: ValEnv
461                -> TypeEnv
462                -> CoreBinding
463                -> UniqSM (CoreBinding, ValEnv)
464
465 do_CoreBindings venv tenv [] = returnUs []
466 do_CoreBindings venv tenv (b:bs)
467   = do_CoreBinding  venv     tenv b     `thenUs` \ (new_b,  new_venv) ->
468     do_CoreBindings new_venv tenv bs    `thenUs` \  new_bs ->
469     returnUs (new_b : new_bs)
470
471 do_CoreBinding venv tenv (NonRec binder rhs)
472   = do_CoreExpr venv tenv rhs   `thenUs` \ new_rhs ->
473
474     dup_binder tenv binder      `thenUs` \ (new_binder, (old, new)) ->
475     -- now plug new bindings into envs
476     let  new_venv = addOneToIdEnv venv old new  in
477
478     returnUs (NonRec new_binder new_rhs, new_venv)
479
480 do_CoreBinding venv tenv (Rec binds)
481   = -- for letrec, we plug in new bindings BEFORE cloning rhss
482     mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
483     let  new_venv = growIdEnvList venv new_maps in
484
485     mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
486     returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
487   where
488     (binders, rhss) = unzip binds
489 \end{code}
490
491 \begin{code}
492 do_CoreArg :: ValEnv
493             -> TypeEnv
494             -> CoreArg
495             -> UniqSM CoreArgOrExpr
496
497 do_CoreArg venv tenv a@(VarArg v)
498   = returnUs (
499       case (lookupIdEnv venv v) of
500         Nothing   -> AnArg  a
501         Just expr -> AnExpr expr
502     )
503
504 do_CoreArg venv tenv (TyArg ty)
505   = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
506
507 do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
508 \end{code}
509
510 \begin{code}
511 do_CoreExpr :: ValEnv
512             -> TypeEnv
513             -> CoreExpr
514             -> UniqSM CoreExpr
515
516 do_CoreExpr venv tenv orig_expr@(Var var)
517   = returnUs (
518       case (lookupIdEnv venv var) of
519         Nothing     -> --false:ASSERT(toplevelishId var) (SIGH)
520                        orig_expr
521         Just expr   -> expr
522     )
523
524 do_CoreExpr venv tenv e@(Lit _) = returnUs e
525
526 do_CoreExpr venv tenv (Con con as)
527   = mapUs  (do_CoreArg venv tenv) as `thenUs`  \ new_as ->
528     mkCoCon con new_as
529
530 do_CoreExpr venv tenv (Prim op as)
531   = mapUs  (do_CoreArg venv tenv) as    `thenUs`  \ new_as ->
532     do_PrimOp op                        `thenUs`  \ new_op ->
533     mkCoPrim new_op new_as
534   where
535     do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
536       = let
537             new_arg_tys   = map (applyTypeEnvToTy tenv) arg_tys
538             new_result_ty = applyTypeEnvToTy tenv result_ty
539         in
540         returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
541
542     do_PrimOp other_op = returnUs other_op
543
544 do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
545   = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
546     let  new_venv = addOneToIdEnv venv old new  in
547     do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
548     returnUs (Lam (ValBinder new_binder) new_expr)
549
550 do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
551   = dup_tyvar tyvar        `thenUs` \ (new_tyvar, (old, new)) ->
552     let
553         new_tenv = addOneToTyVarEnv tenv old new
554     in
555     do_CoreExpr venv new_tenv expr  `thenUs` \ new_expr ->
556     returnUs (Lam (TyBinder new_tyvar) new_expr)
557
558 do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder"
559
560 do_CoreExpr venv tenv (App expr arg)
561   = do_CoreExpr venv tenv expr  `thenUs` \ new_expr ->
562     do_CoreArg  venv tenv arg   `thenUs` \ new_arg  ->
563     mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
564
565 do_CoreExpr venv tenv (Case expr alts)
566   = do_CoreExpr venv tenv expr      `thenUs` \ new_expr ->
567     do_alts venv tenv alts          `thenUs` \ new_alts ->
568     returnUs (Case new_expr new_alts)
569   where
570     do_alts venv tenv (AlgAlts alts deflt)
571       = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
572         do_default venv tenv deflt          `thenUs` \ new_deflt ->
573         returnUs (AlgAlts new_alts new_deflt)
574       where
575         do_boxed_alt venv tenv (con, binders, expr)
576           = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
577             let  new_venv = growIdEnvList venv new_vmaps  in
578             do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
579             returnUs (con, new_binders, new_expr)
580
581
582     do_alts venv tenv (PrimAlts alts deflt)
583       = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
584         do_default venv tenv deflt            `thenUs` \ new_deflt ->
585         returnUs (PrimAlts new_alts new_deflt)
586       where
587         do_unboxed_alt venv tenv (lit, expr)
588           = do_CoreExpr venv tenv expr  `thenUs` \ new_expr ->
589             returnUs (lit, new_expr)
590
591     do_default venv tenv NoDefault = returnUs NoDefault
592
593     do_default venv tenv (BindDefault binder expr)
594       = dup_binder tenv binder          `thenUs` \ (new_binder, (old, new)) ->
595         let  new_venv = addOneToIdEnv venv old new  in
596         do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
597         returnUs (BindDefault new_binder new_expr)
598
599 do_CoreExpr venv tenv (Let core_bind expr)
600   = do_CoreBinding venv tenv core_bind  `thenUs` \ (new_bind, new_venv) ->
601     -- and do the body of the let
602     do_CoreExpr new_venv tenv expr      `thenUs` \ new_expr ->
603     returnUs (Let new_bind new_expr)
604
605 do_CoreExpr venv tenv (SCC label expr)
606   = do_CoreExpr venv tenv expr          `thenUs` \ new_expr ->
607     returnUs (SCC label new_expr)
608
609 do_CoreExpr venv tenv (Coerce c ty expr)
610   = do_CoreExpr venv tenv expr          `thenUs` \ new_expr ->
611     returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
612 \end{code}
613
614 \begin{code}
615 dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
616 dup_tyvar tyvar
617   = getUnique                   `thenUs` \ uniq ->
618     let  new_tyvar = cloneTyVar tyvar uniq  in
619     returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
620
621 -- same thing all over again --------------------
622
623 dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
624 dup_binder tenv b
625   = if (toplevelishId b) then
626         -- binder is "top-level-ish"; -- it should *NOT* be renamed
627         -- ToDo: it's unsavoury that we return something to heave in env
628         returnUs (b, (b, Var b))
629
630     else -- otherwise, the full business
631         getUnique                           `thenUs`  \ uniq ->
632         let
633             new_b1 = mkIdWithNewUniq b uniq
634             new_b2 = applyTypeEnvToId tenv new_b1
635         in
636         returnUs (new_b2, (b, Var new_b2))
637 \end{code}