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