ghc/compiler/coreSyn/CoreUtils.lhs

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