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
  13
  14         , mkCoreIfThenElse
  15         , mkErrorApp, escErrorMsg
  16         , argToExpr
  17         , unTagBinders, unTagBindersAlts
  18         , manifestlyWHNF, manifestlyBottom
  19 {-      exprSmallEnoughToDup,
  20         coreExprArity,
  21         isWrapperFor,
  22         maybeErrorApp,
  23         nonErrorRHSs,
  24         squashableDictishCcExpr,
  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 )
  42 import PprCore          ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} )
  43 import PprStyle         ( PprStyle(..) )
  44 import PprType          ( GenType{-instances-}, GenTyVar{-instance-} )
  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(..), GenTyVar{-instances-} )
  53 import Type             ( mkFunTys, mkForAllTy, mkForAllUsageTy,
  54                           getFunTy_maybe, applyTy, splitSigmaTy
  55                         )
  56 import Unique           ( Unique{-instances-} )
  57 import UniqSupply       ( initUs, returnUs, thenUs,
  58                           mapUs, mapAndUnzipUs,
  59                           UniqSM(..), UniqSupply
  60                         )
  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 applyTypeEnvToTy = panic "CoreUtils.applyTypeEnvToTy"
  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, args) ->
 257     case fun of
 258       Var v -> v /= buildId
 259                  && v /= augmentId
 260                  && length args <= 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 (ValBinder _) _) = True
 284 manifestlyWHNF (Lam other_binder  e) = manifestlyWHNF e
 285
 286 manifestlyWHNF other_expr   -- look for manifest partial application
 287   = case (collectArgs other_expr) of { (fun, args) ->
 288     case fun of
 289       Var f ->  let
 290                     num_val_args = numValArgs args
 291                 in
 292                 num_val_args == 0 -- Just a type application of
 293                                   -- a variable (f t1 t2 t3);
 294                                   -- counts as WHNF.
 295                 ||
 296                 case (arityMaybe (getIdArity f)) of
 297                   Nothing     -> False
 298                   Just arity  -> num_val_args < arity
 299
 300       _ -> False
 301     }
 302 \end{code}
 303
 304 @manifestlyBottom@ looks at a Core expression and returns \tr{True} if
 305 it is obviously bottom, that is, it will certainly return bottom at
 306 some point.  It isn't a disaster if it errs on the conservative side
 307 (returning \tr{False}).
 308
 309 \begin{code}
 310 manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
 311
 312 manifestlyBottom (Var v)     = isBottomingId v
 313 manifestlyBottom (Lit _)     = False
 314 manifestlyBottom (Con  _ _)  = False
 315 manifestlyBottom (Prim _ _)  = False
 316 manifestlyBottom (SCC _ e)   = manifestlyBottom e
 317 manifestlyBottom (Let _ e)   = manifestlyBottom e
 318
 319   -- We do not assume \x.bottom == bottom:
 320 manifestlyBottom (Lam (ValBinder _) _) = False
 321 manifestlyBottom (Lam other_binder  e) = manifestlyBottom e
 322
 323 manifestlyBottom (Case e a)
 324   = manifestlyBottom e
 325   || (case a of
 326         AlgAlts  alts def -> all mbalg  alts && mbdef def
 327         PrimAlts alts def -> all mbprim alts && mbdef def
 328      )
 329   where
 330     mbalg  (_,_,e') = manifestlyBottom e'
 331
 332     mbprim (_,e')   = manifestlyBottom e'
 333
 334     mbdef NoDefault          = True
 335     mbdef (BindDefault _ e') = manifestlyBottom e'
 336
 337 manifestlyBottom other_expr   -- look for manifest partial application
 338   = case (collectArgs other_expr) of { (fun, args) ->
 339     case fun of
 340       Var f | isBottomingId f -> True
 341                 -- Application of a function which always gives
 342                 -- bottom; we treat this as a WHNF, because it
 343                 -- certainly doesn't need to be shared!
 344       _ -> False
 345     }
 346 \end{code}
 347
 348 \begin{code}
 349 {-LATER:
 350 coreExprArity
 351         :: (Id -> Maybe (GenCoreExpr bndr Id))
 352         -> GenCoreExpr bndr Id
 353         -> Int
 354 coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
 355 coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
 356 coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
 357 coreExprArity f (CoTyApp expr _) = coreExprArity f expr
 358 coreExprArity f (Var v) = max further info
 359    where
 360         further
 361              = case f v of
 362                 Nothing -> 0
 363                 Just expr -> coreExprArity f expr
 364         info = case (arityMaybe (getIdArity v)) of
 365                 Nothing    -> 0
 366                 Just arity -> arity
 367 coreExprArity f _ = 0
 368 \end{code}
 369
 370 @isWrapperFor@: we want to see exactly:
 371 \begin{verbatim}
 372 /\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
 373 \end{verbatim}
 374
 375 Probably a little too HACKY [WDP].
 376
 377 \begin{code}
 378 isWrapperFor :: CoreExpr -> Id -> Bool
 379
 380 expr `isWrapperFor` var
 381   = case (collectBinders  expr) of { (_, _, args, body) -> -- lambdas off the front
 382     unravel_casing args body
 383     --NO, THANKS: && not (null args)
 384     }
 385   where
 386     var's_worker = getWorkerId (getIdStrictness var)
 387
 388     is_elem = isIn "isWrapperFor"
 389
 390     --------------
 391     unravel_casing case_ables (Case scrut alts)
 392       = case (collectArgs scrut) of { (fun, args) ->
 393         case fun of
 394           Var scrut_var -> let
 395                                 answer =
 396                                      scrut_var /= var && all (doesn't_mention var) args
 397                                   && scrut_var `is_elem` case_ables
 398                                   && unravel_alts case_ables alts
 399                              in
 400                              answer
 401
 402           _ -> False
 403         }
 404
 405     unravel_casing case_ables other_expr
 406       = case (collectArgs other_expr) of { (fun, args) ->
 407         case fun of
 408           Var wrkr -> let
 409                             answer =
 410                                 -- DOESN'T WORK: wrkr == var's_worker
 411                                 wrkr /= var
 412                              && isWorkerId wrkr
 413                              && all (doesn't_mention var)  args
 414                              && all (only_from case_ables) args
 415                         in
 416                         answer
 417
 418           _ -> False
 419         }
 420
 421     --------------
 422     unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
 423       = unravel_casing (params ++ case_ables) rhs
 424     unravel_alts case_ables other = False
 425
 426     -------------------------
 427     doesn't_mention var (ValArg (VarArg v)) = v /= var
 428     doesn't_mention var other = True
 429
 430     -------------------------
 431     only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
 432     only_from case_ables other = True
 433 -}
 434 \end{code}
 435
 436 All the following functions operate on binders, perform a uniform
 437 transformation on them; ie. the function @(\ x -> (x,False))@
 438 annotates all binders with False.
 439
 440 \begin{code}
 441 unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
 442 unTagBinders expr = bop_expr fst expr
 443
 444 unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
 445 unTagBindersAlts alts = bop_alts fst alts
 446 \end{code}
 447
 448 \begin{code}
 449 bop_expr  :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
 450
 451 bop_expr f (Var b)           = Var b
 452 bop_expr f (Lit lit)         = Lit lit
 453 bop_expr f (Con con args)    = Con con args
 454 bop_expr f (Prim op args)    = Prim op args
 455 bop_expr f (Lam binder expr) = Lam  (bop_binder f binder) (bop_expr f expr)
 456 bop_expr f (App expr arg)    = App  (bop_expr f expr) arg
 457 bop_expr f (SCC label expr)  = SCC  label (bop_expr f expr)
 458 bop_expr f (Let bind expr)   = Let  (bop_bind f bind) (bop_expr f expr)
 459 bop_expr f (Case expr alts)  = Case (bop_expr f expr) (bop_alts f alts)
 460
 461 bop_binder f (ValBinder   v) = ValBinder (f v)
 462 bop_binder f (TyBinder    t) = TyBinder    t
 463 bop_binder f (UsageBinder u) = UsageBinder u
 464
 465 bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
 466 bop_bind f (Rec pairs)  = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
 467
 468 bop_alts f (AlgAlts alts deflt)
 469   = AlgAlts  [ (con, [f b | b <- binders], bop_expr f e)
 470              | (con, binders, e) <- alts ]
 471              (bop_deflt f deflt)
 472
 473 bop_alts f (PrimAlts alts deflt)
 474   = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
 475              (bop_deflt f deflt)
 476
 477 bop_deflt f (NoDefault)          = NoDefault
 478 bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
 479 \end{code}
 480
 481 OLD (but left here because of the nice example): @singleAlt@ checks
 482 whether a bunch of case alternatives is actually just one alternative.
 483 It specifically {\em ignores} alternatives which consist of just a
 484 call to @error@, because they won't result in any code duplication.
 485
 486 Example:
 487 \begin{verbatim}
 488         case (case <something> of
 489                 True  -> <rhs>
 490                 False -> error "Foo") of
 491         <alts>
 492
 493 ===>
 494
 495         case <something> of
 496            True ->  case <rhs> of
 497                     <alts>
 498            False -> case error "Foo" of
 499                     <alts>
 500
 501 ===>
 502
 503         case <something> of
 504            True ->  case <rhs> of
 505                     <alts>
 506            False -> error "Foo"
 507 \end{verbatim}
 508 Notice that the \tr{<alts>} don't get duplicated.
 509
 510 \begin{code}
 511 {- LATER:
 512 nonErrorRHSs :: GenCoreCaseAlts binder Id -> [GenCoreExpr binder Id]
 513
 514 nonErrorRHSs alts = filter not_error_app (find_rhss alts)
 515   where
 516     find_rhss (AlgAlts  alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt
 517     find_rhss (PrimAlts alts deflt) = [rhs | (_,rhs)   <- alts] ++ deflt_rhs deflt
 518
 519     deflt_rhs NoDefault           = []
 520     deflt_rhs (BindDefault _ rhs) = [rhs]
 521
 522     not_error_app rhs = case maybeErrorApp rhs Nothing of
 523                          Just _  -> False
 524                          Nothing -> True
 525 \end{code}
 526
 527 maybeErrorApp checkes whether an expression is of the form
 528
 529         error ty args
 530
 531 If so, it returns
 532
 533         Just (error ty' args)
 534
 535 where ty' is supplied as an argument to maybeErrorApp.
 536
 537 Here's where it is useful:
 538
 539                 case (error ty "Foo" e1 e2) of <alts>
 540  ===>
 541                 error ty' "Foo"
 542
 543 where ty' is the type of any of the alternatives.
 544 You might think this never occurs, but see the comments on
 545 the definition of @singleAlt@.
 546
 547 Note: we *avoid* the case where ty' might end up as a
 548 primitive type: this is very uncool (totally wrong).
 549
 550 NOTICE: in the example above we threw away e1 and e2, but
 551 not the string "Foo".  How did we know to do that?
 552
 553 Answer: for now anyway, we only handle the case of a function
 554 whose type is of form
 555
 556         bottomingFn :: forall a. t1 -> ... -> tn -> a
 557                               ^---------------------^ NB!
 558
 559 Furthermore, we only count a bottomingApp if the function is
 560 applied to more than n args.  If so, we transform:
 561
 562         bottomingFn ty e1 ... en en+1 ... em
 563 to
 564         bottomingFn ty' e1 ... en
 565
 566 That is, we discard en+1 .. em
 567
 568 \begin{code}
 569 maybeErrorApp :: GenCoreExpr bndr Id   -- 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 bndr Id)
 576
 577 maybeErrorApp expr result_ty_maybe
 578   = case collectArgs expr of
 579       (Var fun, (TypeArg 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         case splitSigmaTy (idType fun) of
 585           ([tyvar_tmpl], [], tau_ty) ->
 586               case (splitTyArgs tau_ty) of { (arg_tys, res_ty) ->
 587               let
 588                   n_args_to_keep = length arg_tys
 589                   args_to_keep   = take n_args_to_keep other_args
 590               in
 591               if  res_ty == mkTyVarTemplateTy tyvar_tmpl &&
 592                   n_args_to_keep <= length other_args
 593               then
 594                     -- Phew!  We're in business
 595                   Just (mkGenApp (Var fun)
 596                               (TypeArg result_ty : args_to_keep))
 597               else
 598                   Nothing
 599               }
 600
 601           other ->      -- Function type wrong shape
 602                     Nothing
 603       other -> Nothing
 604   where
 605     Just result_ty = result_ty_maybe
 606 \end{code}
 607
 608 \begin{code}
 609 squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b -> Bool
 610
 611 squashableDictishCcExpr cc expr
 612   = if not (isDictCC cc) then
 613         False -- that was easy...
 614     else
 615         squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
 616   where
 617     squashable (Var _)      = True
 618     squashable (CoTyApp f _)  = squashable f
 619     squashable (Con _ _ _)  = True -- I think so... WDP 94/09
 620     squashable (Prim _ _ _) = True -- ditto
 621     squashable other          = False
 622 -}
 623 \end{code}
 624
 625 %************************************************************************
 626 %*                                                                      *
 627 \subsection{Core-renaming utils}
 628 %*                                                                      *
 629 %************************************************************************
 630
 631 \begin{code}
 632 substCoreExpr   :: ValEnv
 633                 -> TypeEnv -- TyVar=>Type
 634                 -> CoreExpr
 635                 -> UniqSM CoreExpr
 636
 637 substCoreExpr venv tenv expr
 638   -- if the envs are empty, then avoid doing anything
 639   = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
 640        returnUs expr
 641     else
 642        do_CoreExpr venv tenv expr
 643 \end{code}
 644
 645 The equiv code for @Types@ is in @TyUtils@.
 646
 647 Because binders aren't necessarily unique: we don't do @plusEnvs@
 648 (which check for duplicates); rather, we use the shadowing version,
 649 @growIdEnv@ (and shorthand @addOneToIdEnv@).
 650
 651 @do_CoreBindings@ takes into account the semantics of a list of
 652 @CoreBindings@---things defined early in the list are visible later in
 653 the list, but not vice versa.
 654
 655 \begin{code}
 656 type ValEnv  = IdEnv CoreExpr
 657
 658 do_CoreBindings :: ValEnv
 659                 -> TypeEnv
 660                 -> [CoreBinding]
 661                 -> UniqSM [CoreBinding]
 662
 663 do_CoreBinding :: ValEnv
 664                -> TypeEnv
 665                -> CoreBinding
 666                -> UniqSM (CoreBinding, ValEnv)
 667
 668 do_CoreBindings venv tenv [] = returnUs []
 669 do_CoreBindings venv tenv (b:bs)
 670   = do_CoreBinding  venv     tenv b     `thenUs` \ (new_b,  new_venv) ->
 671     do_CoreBindings new_venv tenv bs    `thenUs` \  new_bs ->
 672     returnUs (new_b : new_bs)
 673
 674 do_CoreBinding venv tenv (NonRec binder rhs)
 675   = do_CoreExpr venv tenv rhs   `thenUs` \ new_rhs ->
 676
 677     dup_binder tenv binder      `thenUs` \ (new_binder, (old, new)) ->
 678     -- now plug new bindings into envs
 679     let  new_venv = addOneToIdEnv venv old new  in
 680
 681     returnUs (NonRec new_binder new_rhs, new_venv)
 682
 683 do_CoreBinding venv tenv (Rec binds)
 684   = -- for letrec, we plug in new bindings BEFORE cloning rhss
 685     mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
 686     let  new_venv = growIdEnvList venv new_maps in
 687
 688     mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
 689     returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv)
 690   where
 691     (binders, rhss) = unzip binds
 692 \end{code}
 693
 694 \begin{code}
 695 do_CoreArg :: ValEnv
 696             -> TypeEnv
 697             -> CoreArg
 698             -> UniqSM CoreExpr
 699
 700 do_CoreArg venv tenv (LitArg lit)     = returnUs (Lit lit)
 701 do_CoreArg venv tenv (TyArg ty)       = panic "do_CoreArg: TyArg"
 702 do_CoreArg venv tenv (UsageArg usage) = panic "do_CoreArg: UsageArg"
 703 do_CoreArg venv tenv (VarArg v)
 704   = returnUs (
 705       case (lookupIdEnv venv v) of
 706         Nothing   -> --false:ASSERT(toplevelishId v)
 707                      Var v
 708         Just expr -> expr
 709     )
 710 \end{code}
 711
 712 \begin{code}
 713 do_CoreExpr :: ValEnv
 714             -> TypeEnv
 715             -> CoreExpr
 716             -> UniqSM CoreExpr
 717
 718 do_CoreExpr venv tenv orig_expr@(Var var)
 719   = returnUs (
 720       case (lookupIdEnv venv var) of
 721         Nothing     -> --false:ASSERT(toplevelishId var) (SIGH)
 722                        orig_expr
 723         Just expr   -> expr
 724     )
 725
 726 do_CoreExpr venv tenv e@(Lit _) = returnUs e
 727
 728 do_CoreExpr venv tenv (Con con as)
 729   = panic "CoreUtils.do_CoreExpr:Con"
 730 {- LATER:
 731   = mapUs  (do_CoreArg venv tenv) as `thenUs`  \ new_as ->
 732     mkCoCon con new_as
 733 -}
 734
 735 do_CoreExpr venv tenv (Prim op as)
 736   = panic "CoreUtils.do_CoreExpr:Prim"
 737 {- LATER:
 738   = mapUs  (do_CoreArg venv tenv) as    `thenUs`  \ new_as ->
 739     do_PrimOp op                        `thenUs`  \ new_op ->
 740     mkCoPrim new_op new_as
 741   where
 742     do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
 743       = let
 744             new_arg_tys   = map (applyTypeEnvToTy tenv) arg_tys
 745             new_result_ty = applyTypeEnvToTy tenv result_ty
 746         in
 747         returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
 748
 749     do_PrimOp other_op = returnUs other_op
 750 -}
 751
 752 do_CoreExpr venv tenv (Lam binder expr)
 753   = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
 754     let  new_venv = addOneToIdEnv venv old new  in
 755     do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
 756     returnUs (Lam new_binder new_expr)
 757
 758 do_CoreExpr venv tenv (App expr arg)
 759   = panic "CoreUtils.do_CoreExpr:App"
 760 {-
 761   = do_CoreExpr venv tenv expr  `thenUs` \ new_expr ->
 762     do_CoreArg  venv tenv arg   `thenUs` \ new_arg  ->
 763     mkCoApp new_expr new_arg
 764 -}
 765
 766 do_CoreExpr venv tenv (Case expr alts)
 767   = do_CoreExpr venv tenv expr      `thenUs` \ new_expr ->
 768     do_alts venv tenv alts          `thenUs` \ new_alts ->
 769     returnUs (Case new_expr new_alts)
 770   where
 771     do_alts venv tenv (AlgAlts alts deflt)
 772       = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
 773         do_default venv tenv deflt          `thenUs` \ new_deflt ->
 774         returnUs (AlgAlts new_alts new_deflt)
 775       where
 776         do_boxed_alt venv tenv (con, binders, expr)
 777           = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
 778             let  new_venv = growIdEnvList venv new_vmaps  in
 779             do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
 780             returnUs (con, new_binders, new_expr)
 781
 782
 783     do_alts venv tenv (PrimAlts alts deflt)
 784       = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
 785         do_default venv tenv deflt            `thenUs` \ new_deflt ->
 786         returnUs (PrimAlts new_alts new_deflt)
 787       where
 788         do_unboxed_alt venv tenv (lit, expr)
 789           = do_CoreExpr venv tenv expr  `thenUs` \ new_expr ->
 790             returnUs (lit, new_expr)
 791
 792     do_default venv tenv NoDefault = returnUs NoDefault
 793
 794     do_default venv tenv (BindDefault binder expr)
 795       = dup_binder tenv binder          `thenUs` \ (new_binder, (old, new)) ->
 796         let  new_venv = addOneToIdEnv venv old new  in
 797         do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
 798         returnUs (BindDefault new_binder new_expr)
 799
 800 do_CoreExpr venv tenv (Let core_bind expr)
 801   = do_CoreBinding venv tenv core_bind  `thenUs` \ (new_bind, new_venv) ->
 802     -- and do the body of the let
 803     do_CoreExpr new_venv tenv expr      `thenUs` \ new_expr ->
 804     returnUs (Let new_bind new_expr)
 805
 806 do_CoreExpr venv tenv (SCC label expr)
 807   = do_CoreExpr venv tenv expr          `thenUs` \ new_expr ->
 808     returnUs (SCC label new_expr)
 809 \end{code}