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