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