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