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