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