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