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