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