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