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