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