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