ghc/compiler/coreSyn/CoreUtils.lhs

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