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