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