ghc/compiler/coreSyn/CoreFuns.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[CoreUtils]{Utility functions}
   5
   6 These functions are re-exported by the various parameterisations of
   7 @CoreSyn@.
   8
   9 \begin{code}
  10 #include "HsVersions.h"
  11
  12 module CoreFuns (
  13         typeOfCoreExpr, typeOfCoreAlts,
  14
  15         instCoreExpr,   substCoreExpr,   -- UNUSED: cloneCoreExpr,
  16         substCoreExprUS, -- UNUSED: instCoreExprUS, cloneCoreExprUS,
  17
  18         instCoreBindings,
  19
  20         bindersOf,
  21
  22         mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
  23         mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
  24         mkCoLetrecAny, mkCoLetrecNoUnboxed,
  25         mkCoLam, mkCoreIfThenElse,
  26 --      mkCoApp, mkCoCon, mkCoPrim, -- no need to export
  27         mkCoApps,
  28         mkCoTyLam, mkCoTyApps,
  29         mkErrorCoApp, escErrorMsg,
  30         pairsFromCoreBinds,
  31         mkFunction, atomToExpr,
  32         digForLambdas,
  33         exprSmallEnoughToDup,
  34         manifestlyWHNF, manifestlyBottom, --UNUSED: manifestWHNFArgs,
  35         coreExprArity,
  36         isWrapperFor,
  37         maybeErrorApp,
  38 --UNUSED: boilsDownToConApp,
  39         nonErrorRHSs,
  40         squashableDictishCcExpr,
  41
  42         unTagBinders, unTagBindersAlts,
  43
  44 #ifdef DPH
  45         mkNonRecBinds,
  46         isParCoreCaseAlternative,
  47 #endif {- Data Parallel Haskell -}
  48
  49         -- to make the interface self-sufficient...
  50         CoreAtom, CoreExpr, Id, UniType, UniqueSupply, UniqSM(..),
  51         IdEnv(..), UniqFM, Unique, TyVarEnv(..), Maybe
  52     ) where
  53
  54 --IMPORT_Trace          -- ToDo: debugging only
  55 import Pretty
  56
  57 import AbsPrel          ( mkFunTy, trueDataCon, falseDataCon,
  58                           eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
  59                           buildId,
  60                           boolTyCon, fragilePrimOp,
  61                           PrimOp(..), typeOfPrimOp,
  62                           PrimKind
  63                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  64                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  65 #ifdef DPH
  66                           , mkPodTy, mkPodizedPodNTy
  67 #endif {- Data Parallel Haskell -}
  68                         )
  69 import AbsUniType
  70 import BasicLit         ( isNoRepLit, typeOfBasicLit, BasicLit(..)
  71                           IF_ATTACK_PRAGMAS(COMMA isLitLitLit)
  72                         )
  73 import CostCentre       ( isDictCC, CostCentre )
  74 import Id
  75 import IdEnv
  76 import IdInfo
  77 import Maybes           ( catMaybes, maybeToBool, Maybe(..) )
  78 import Outputable
  79 import CoreSyn
  80 import PlainCore        -- the main stuff we're defining functions for
  81 import SrcLoc           ( SrcLoc, mkUnknownSrcLoc )
  82 #ifdef DPH
  83 import TyCon            ( getPodizedPodDimension )
  84 #endif {- Data Parallel Haskell -}
  85 import TyVarEnv
  86 import SplitUniq
  87 import Unique           -- UniqueSupply monadery used here
  88 import Util
  89 \end{code}
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection[bindersOf]{Small but useful}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97
  98 \begin{code}
  99 bindersOf :: CoreBinding bder bdee -> [bder]
 100 bindersOf (CoNonRec binder _) = [binder]
 101 bindersOf (CoRec pairs)       = [binder | (binder,_) <- pairs]
 102 \end{code}
 103
 104
 105 %************************************************************************
 106 %*                                                                      *
 107 \subsection[typeOfCore]{Find the type of a Core atom/expression}
 108 %*                                                                      *
 109 %************************************************************************
 110
 111 \begin{code}
 112 typeOfCoreExpr :: PlainCoreExpr -> UniType
 113 typeOfCoreExpr (CoVar var)              = getIdUniType var
 114 typeOfCoreExpr (CoLit lit)              = typeOfBasicLit lit
 115 typeOfCoreExpr (CoLet binds body)       = typeOfCoreExpr body
 116 typeOfCoreExpr (CoSCC label expr)       = typeOfCoreExpr expr
 117
 118 -- a CoCon is a fully-saturated application of a data constructor
 119 typeOfCoreExpr (CoCon con tys _)
 120   = applyTyCon (getDataConTyCon con) tys
 121
 122 -- and, analogously, ...
 123 typeOfCoreExpr expr@(CoPrim op tys args)
 124   -- Note: CoPrims may be polymorphic, so we do de-forall'ing.
 125   = let
 126         op_ty     = typeOfPrimOp op
 127         op_tau_ty = foldl applyTy op_ty tys
 128     in
 129     funResultTy op_tau_ty (length args)
 130
 131 typeOfCoreExpr (CoCase _ alts)  = typeOfCoreAlts alts
 132   -- Q: What if the one you happen to grab is an "error"?
 133   -- A: NO problem.  The type application of error to its type will give you
 134   --    the answer.
 135
 136 typeOfCoreExpr (CoLam binders expr)
 137   = foldr (mkFunTy . getIdUniType) (typeOfCoreExpr expr) binders
 138
 139 typeOfCoreExpr (CoTyLam tyvar expr)
 140   = case (quantifyTy [tyvar] (typeOfCoreExpr expr)) of
 141       (_, ty) -> ty     -- not worried about the TyVarTemplates that come back
 142
 143 typeOfCoreExpr expr@(CoApp _ _)   = typeOfCoreApp expr
 144 typeOfCoreExpr expr@(CoTyApp _ _) = typeOfCoreApp expr
 145
 146 #ifdef DPH
 147 typeOfCoreExpr (CoParCon con ctxt tys args)
 148   = mkPodizedPodNTy ctxt (applyTyCon (getDataConTyCon con) tys)
 149
 150 typeOfCoreExpr (CoZfExpr expr quals)
 151   = mkPodTy (typeOfCoreExpr expr)
 152
 153 typeOfCoreExpr (CoParComm _ expr _)
 154   = typeOfCoreExpr expr
 155 #endif {- Data Parallel Haskell -}
 156 \end{code}
 157
 158 \begin{code}
 159 typeOfCoreApp application
 160   = case (collectArgs application) of { (fun, args) ->
 161     apply_args (typeOfCoreExpr fun) args
 162     }
 163   where
 164     apply_args expr_ty [] = expr_ty
 165
 166     apply_args fun_ty (TypeArg ty_arg : args)
 167       = apply_args (applyTy fun_ty ty_arg) args
 168
 169     apply_args fun_ty (ValArg val_arg : args)
 170       = case (maybeUnpackFunTy fun_ty) of
 171           Just (_, result_ty) -> apply_args result_ty args
 172
 173           Nothing -> pprPanic "typeOfCoreApp:\n"
 174                 (ppAboves
 175                         [ppr PprDebug val_arg,
 176                          ppr PprDebug fun_ty,
 177                          ppr PprShowAll application])
 178 \end{code}
 179
 180 \begin{code}
 181 typeOfCoreAlts :: PlainCoreCaseAlternatives -> UniType
 182 typeOfCoreAlts (CoAlgAlts [] deflt)         = typeOfDefault deflt
 183 typeOfCoreAlts (CoAlgAlts ((_,_,rhs1):_) _) = typeOfCoreExpr rhs1
 184
 185 typeOfCoreAlts (CoPrimAlts [] deflt)       = typeOfDefault deflt
 186 typeOfCoreAlts (CoPrimAlts ((_,rhs1):_) _) = typeOfCoreExpr rhs1
 187 #ifdef DPH
 188 typeOfCoreAlts (CoParAlgAlts _ _ _ [] deflt)       = typeOfDefault deflt
 189 typeOfCoreAlts (CoParAlgAlts _ _ _ ((_,rhs1):_) _) = typeOfCoreExpr rhs1
 190
 191 typeOfCoreAlts (CoParPrimAlts _ _ [] deflt)       = typeOfDefault deflt
 192 typeOfCoreAlts (CoParPrimAlts _ _ ((_,rhs1):_) _) = typeOfCoreExpr rhs1
 193 #endif {- Data Parallel Haskell -}
 194
 195 typeOfDefault CoNoDefault           = panic "typeOfCoreExpr:CoCase:typeOfDefault"
 196 typeOfDefault (CoBindDefault _ rhs) = typeOfCoreExpr rhs
 197 \end{code}
 198
 199 %************************************************************************
 200 %*                                                                      *
 201 \subsection[CoreFuns-instantiate]{Instantiating core expressions: interfaces}
 202 %*                                                                      *
 203 %************************************************************************
 204
 205 These subst/inst functions {\em must not} use splittable
 206 UniqueSupplies! (yet)
 207
 208 All of the desired functions are done by one piece of code, which
 209 carries around a little (monadised) state (a @UniqueSupply@).
 210 Meanwhile, here is what the outside world sees (NB: @UniqueSupply@
 211 passed in and out):
 212 \begin{code}
 213 {- UNUSED:
 214 cloneCoreExpr   :: UniqueSupply
 215                 -> PlainCoreExpr -- template
 216                 -> (UniqueSupply, PlainCoreExpr)
 217
 218 cloneCoreExpr us expr = instCoreExpr us expr
 219 -}
 220
 221 --------------------
 222
 223 instCoreExpr    :: UniqueSupply
 224                 -> PlainCoreExpr
 225                 -> (UniqueSupply, PlainCoreExpr)
 226
 227 instCoreExpr us expr
 228   = initUs us (do_CoreExpr nullIdEnv nullTyVarEnv expr)
 229
 230 instCoreBindings :: UniqueSupply
 231                  -> [PlainCoreBinding]
 232                  -> (UniqueSupply, [PlainCoreBinding])
 233
 234 instCoreBindings us binds
 235   = initUs us (do_CoreBindings nullIdEnv nullTyVarEnv binds)
 236
 237 --------------------
 238
 239 substCoreExpr   :: UniqueSupply
 240                 -> ValEnv
 241                 -> TypeEnv  -- TyVar=>UniType
 242                 -> PlainCoreExpr
 243                 -> (UniqueSupply, PlainCoreExpr)
 244
 245 substCoreExpr us venv tenv expr
 246   = initUs us (substCoreExprUS venv tenv expr)
 247
 248 -- we are often already in a UniqSM world, so here are the interfaces
 249 -- for that:
 250 {- UNUSED:
 251 cloneCoreExprUS :: PlainCoreExpr{-template-} -> UniqSM PlainCoreExpr
 252
 253 cloneCoreExprUS = instCoreExprUS
 254
 255 instCoreExprUS  :: PlainCoreExpr -> UniqSM PlainCoreExpr
 256
 257 instCoreExprUS expr = do_CoreExpr nullIdEnv nullTyVarEnv expr
 258 -}
 259
 260 --------------------
 261
 262 substCoreExprUS :: ValEnv
 263                 -> TypeEnv -- TyVar=>UniType
 264                 -> PlainCoreExpr
 265                 -> UniqSM PlainCoreExpr
 266
 267 substCoreExprUS venv tenv expr
 268   -- if the envs are empty, then avoid doing anything
 269   = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
 270        returnUs expr
 271     else
 272        do_CoreExpr venv tenv expr
 273 \end{code}
 274
 275 %************************************************************************
 276 %*                                                                      *
 277 \subsection[CoreFuns-inst-exprs]{Actual expression-instantiating code}
 278 %*                                                                      *
 279 %************************************************************************
 280
 281 The equiv code for @UniTypes@ is in @UniTyFuns@.
 282
 283 Because binders aren't necessarily unique: we don't do @plusEnvs@
 284 (which check for duplicates); rather, we use the shadowing version,
 285 @growIdEnv@ (and shorthand @addOneToIdEnv@).
 286
 287 \begin{code}
 288 type ValEnv  = IdEnv PlainCoreExpr
 289
 290 do_CoreBinding :: ValEnv
 291                -> TypeEnv
 292                -> PlainCoreBinding
 293                -> UniqSM (PlainCoreBinding, ValEnv)
 294
 295 do_CoreBinding venv tenv (CoNonRec binder rhs)
 296   = do_CoreExpr venv tenv rhs   `thenUs` \ new_rhs ->
 297
 298     dup_binder tenv binder      `thenUs` \ (new_binder, (old, new)) ->
 299     -- now plug new bindings into envs
 300     let  new_venv = addOneToIdEnv venv old new  in
 301
 302     returnUs (CoNonRec new_binder new_rhs, new_venv)
 303
 304 do_CoreBinding venv tenv (CoRec binds)
 305   = -- for letrec, we plug in new bindings BEFORE cloning rhss
 306     mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
 307     let  new_venv = growIdEnvList venv new_maps in
 308
 309     mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
 310     returnUs (CoRec (new_binders `zip` new_rhss), new_venv)
 311   where
 312     binders     = map fst binds
 313     rhss        = map snd binds
 314 \end{code}
 315
 316 @do_CoreBindings@ takes into account the semantics of a list of
 317 @CoreBindings@---things defined early in the list are visible later in
 318 the list, but not vice versa.
 319
 320 \begin{code}
 321 do_CoreBindings :: ValEnv
 322                 -> TypeEnv
 323                 -> [PlainCoreBinding]
 324                 -> UniqSM [PlainCoreBinding]
 325
 326 do_CoreBindings venv tenv [] = returnUs []
 327 do_CoreBindings venv tenv (b:bs)
 328   = do_CoreBinding  venv     tenv b     `thenUs` \ (new_b,  new_venv) ->
 329     do_CoreBindings new_venv tenv bs    `thenUs` \  new_bs ->
 330     returnUs (new_b : new_bs)
 331 \end{code}
 332
 333 \begin{code}
 334 do_CoreAtom :: ValEnv
 335             -> TypeEnv
 336             -> PlainCoreAtom
 337             -> UniqSM PlainCoreExpr
 338
 339 do_CoreAtom venv tenv a@(CoLitAtom lit)   = returnUs (CoLit lit)
 340
 341 do_CoreAtom venv tenv orig_a@(CoVarAtom v)
 342   = returnUs (
 343       case (lookupIdEnv venv v) of
 344         Nothing   -> --false:ASSERT(toplevelishId v)
 345                      CoVar v
 346         Just expr -> expr
 347     )
 348 \end{code}
 349
 350 \begin{code}
 351 do_CoreExpr :: ValEnv
 352             -> TypeEnv
 353             -> PlainCoreExpr
 354             -> UniqSM PlainCoreExpr
 355
 356 do_CoreExpr venv tenv orig_expr@(CoVar var)
 357   = returnUs (
 358       case (lookupIdEnv venv var) of
 359         Nothing     -> --false:ASSERT(toplevelishId var) (SIGH)
 360                        orig_expr
 361         Just expr   -> expr
 362     )
 363
 364 do_CoreExpr venv tenv e@(CoLit _) = returnUs e
 365
 366 do_CoreExpr venv tenv (CoCon  con ts as)
 367   = let
 368         new_ts = map (applyTypeEnvToTy tenv) ts
 369     in
 370     mapUs  (do_CoreAtom venv tenv) as `thenUs`  \ new_as ->
 371     mkCoCon con new_ts new_as
 372
 373 do_CoreExpr venv tenv (CoPrim op tys as)
 374   = let
 375         new_tys = map (applyTypeEnvToTy tenv) tys
 376     in
 377     mapUs  (do_CoreAtom venv tenv) as   `thenUs`  \ new_as ->
 378     do_PrimOp op                        `thenUs`  \ new_op ->
 379     mkCoPrim new_op new_tys new_as
 380   where
 381     do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
 382       = let
 383             new_arg_tys   = map (applyTypeEnvToTy tenv) arg_tys
 384             new_result_ty = applyTypeEnvToTy tenv result_ty
 385         in
 386         returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
 387
 388     do_PrimOp other_op = returnUs other_op
 389
 390 do_CoreExpr venv tenv (CoLam binders expr)
 391   = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
 392     let  new_venv = growIdEnvList venv new_maps  in
 393     do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
 394     returnUs (CoLam new_binders new_expr)
 395
 396 do_CoreExpr venv tenv (CoTyLam tyvar expr)
 397   = dup_tyvar tyvar                 `thenUs` \ (new_tyvar, (old, new)) ->
 398     let
 399         new_tenv = addOneToTyVarEnv tenv old new
 400     in
 401     do_CoreExpr venv new_tenv expr  `thenUs` \ new_expr ->
 402     returnUs (CoTyLam new_tyvar new_expr)
 403
 404 do_CoreExpr venv tenv (CoApp expr atom)
 405   = do_CoreExpr venv tenv expr  `thenUs` \ new_expr ->
 406     do_CoreAtom venv tenv atom  `thenUs` \ new_atom ->
 407     mkCoApp new_expr new_atom
 408
 409 do_CoreExpr venv tenv (CoTyApp expr ty)
 410   = do_CoreExpr venv tenv expr      `thenUs`  \ new_expr ->
 411     let
 412         new_ty = applyTypeEnvToTy tenv ty
 413     in
 414     returnUs (CoTyApp new_expr new_ty)
 415
 416 do_CoreExpr venv tenv (CoCase expr alts)
 417   = do_CoreExpr venv tenv expr      `thenUs` \ new_expr ->
 418     do_alts venv tenv alts          `thenUs` \ new_alts ->
 419     returnUs (CoCase new_expr new_alts)
 420   where
 421     do_alts venv tenv (CoAlgAlts alts deflt)
 422       = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
 423         do_default venv tenv deflt          `thenUs` \ new_deflt ->
 424         returnUs (CoAlgAlts new_alts new_deflt)
 425       where
 426         do_boxed_alt venv tenv (con, binders, expr)
 427           = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
 428             let  new_venv = growIdEnvList venv new_vmaps  in
 429             do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
 430             returnUs (con, new_binders, new_expr)
 431
 432
 433     do_alts venv tenv (CoPrimAlts alts deflt)
 434       = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
 435         do_default venv tenv deflt            `thenUs` \ new_deflt ->
 436         returnUs (CoPrimAlts new_alts new_deflt)
 437       where
 438         do_unboxed_alt venv tenv (lit, expr)
 439           = do_CoreExpr venv tenv expr  `thenUs` \ new_expr ->
 440             returnUs (lit, new_expr)
 441 #ifdef DPH
 442     do_alts venv tenv (CoParAlgAlts tycon dim params alts deflt)
 443       = mapAndUnzipUs (dup_binder tenv) params `thenUs` \ (new_params,new_vmaps) ->
 444         let  new_venv = growIdEnvList venv new_vmaps  in
 445         mapUs (do_boxed_alt new_venv tenv) alts
 446                                          `thenUs` \ new_alts ->
 447         do_default venv tenv deflt       `thenUs` \ new_deflt ->
 448         returnUs (CoParAlgAlts tycon dim new_params new_alts new_deflt)
 449       where
 450         do_boxed_alt venv tenv (con, expr)
 451           = do_CoreExpr venv tenv expr  `thenUs` \ new_expr ->
 452             returnUs (con,  new_expr)
 453
 454     do_alts venv tenv (CoParPrimAlts tycon dim alts deflt)
 455       = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
 456         do_default venv tenv deflt            `thenUs` \ new_deflt ->
 457         returnUs (CoParPrimAlts tycon dim new_alts new_deflt)
 458       where
 459         do_unboxed_alt venv tenv (lit, expr)
 460           = do_CoreExpr venv tenv expr  `thenUs` \ new_expr ->
 461             returnUs (lit, new_expr)
 462 #endif {- Data Parallel Haskell -}
 463
 464     do_default venv tenv CoNoDefault = returnUs CoNoDefault
 465
 466     do_default venv tenv (CoBindDefault binder expr)
 467       = dup_binder tenv binder          `thenUs` \ (new_binder, (old, new)) ->
 468         let  new_venv = addOneToIdEnv venv old new  in
 469         do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
 470         returnUs (CoBindDefault new_binder new_expr)
 471
 472 do_CoreExpr venv tenv (CoLet core_bind expr)
 473   = do_CoreBinding venv tenv core_bind  `thenUs` \ (new_bind, new_venv) ->
 474     -- and do the body of the let
 475     do_CoreExpr new_venv tenv expr      `thenUs` \ new_expr ->
 476     returnUs (CoLet new_bind new_expr)
 477
 478 do_CoreExpr venv tenv (CoSCC label expr)
 479   = do_CoreExpr venv tenv expr          `thenUs` \ new_expr ->
 480     returnUs (CoSCC label new_expr)
 481
 482 #ifdef DPH
 483 do_CoreExpr venv tenv (CoParCon  con ctxt ts es)
 484   = let
 485         new_ts = map (applyTypeEnvToTy tenv) ts
 486     in
 487     mapUs  (do_CoreExpr venv tenv) es) `thenUs`  \ new_es ->
 488     returnUs (CoParCon con ctxt new_ts new_es)
 489
 490 do_CoreExpr venv tenv (CoZfExpr expr quals)
 491   = do_CoreParQuals  venv  tenv quals   `thenUs` \ (quals',venv') ->
 492     do_CoreExpr      venv' tenv expr    `thenUs` \ expr'  ->
 493     returnUs (CoZfExpr expr' quals')
 494
 495 do_CoreExpr venv tenv (CoParComm dim expr comm)
 496   = do_CoreExpr venv tenv expr          `thenUs` \ expr' ->
 497     do_ParComm  comm                    `thenUs` \ comm' ->
 498     returnUs (CoParComm dim expr' comm')
 499   where
 500      do_ParComm (CoParSend exprs)
 501        = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ exprs' ->
 502          returnUs (CoParSend exprs')
 503      do_ParComm (CoParFetch exprs)
 504        = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ exprs' ->
 505          returnUs (CoParFetch exprs')
 506      do_ParComm (CoToPodized)
 507        = returnUs (CoToPodized)
 508      do_ParComm (CoFromPodized)
 509        = returnUs (CoFromPodized)
 510 #endif {- Data Parallel Haskell -}
 511 \end{code}
 512
 513 \begin{code}
 514 #ifdef DPH
 515 do_CoreParQuals :: ValEnv
 516             -> TypeEnv
 517             -> PlainCoreParQuals
 518             -> UniqSM (PlainCoreParQuals, ValEnv)
 519
 520 do_CoreParQuals venv tenv (CoAndQuals l r)
 521    = do_CoreParQuals venv       tenv r  `thenUs` \ (r',right_venv) ->
 522      do_CoreParQuals right_venv tenv l  `thenUs` \ (l',left_env) ->
 523      returnUs (CoAndQuals l' r',left_env)
 524
 525 do_CoreParQuals venv tenv (CoParFilter expr)
 526    = do_CoreExpr venv tenv expr         `thenUs` \ expr' ->
 527      returnUs (CoParFilter expr',venv))
 528
 529 do_CoreParQuals venv tenv (CoDrawnGen binders binder expr)
 530    = mapAndUnzipUs (dup_binder tenv) binders `thenUs`   \ (newBs,newMs) ->
 531      let  new_venv = growIdEnvList venv newMs  in
 532      dup_binder tenv binder             `thenUs`        \ (newB,(old,new)) ->
 533      let  new_venv' = addOneToIdEnv new_venv old new in
 534      do_CoreExpr new_venv' tenv expr    `thenUs`        \ new_expr ->
 535      returnUs (CoDrawnGen newBs newB new_expr,new_venv')
 536
 537 do_CoreParQuals venv tenv (CoIndexGen exprs binder expr)
 538    = mapUs (do_CoreExpr venv tenv) exprs `thenUs`       \ new_exprs ->
 539      dup_binder tenv binder              `thenUs`       \ (newB,(old,new)) ->
 540      let  new_venv = addOneToIdEnv venv old new  in
 541      do_CoreExpr new_venv tenv expr     `thenUs`        \ new_expr ->
 542      returnUs (CoIndexGen new_exprs newB new_expr,new_venv)
 543 #endif {- Data Parallel Haskell -}
 544 \end{code}
 545
 546 \begin{code}
 547 dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, UniType))
 548 dup_tyvar tyvar
 549   = getUnique                   `thenUs` \ uniq ->
 550     let  new_tyvar = cloneTyVar tyvar uniq  in
 551     returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
 552
 553 -- same thing all over again --------------------
 554
 555 dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, PlainCoreExpr))
 556 dup_binder tenv b
 557   = if (toplevelishId b) then
 558         -- binder is "top-level-ish"; -- it should *NOT* be renamed
 559         -- ToDo: it's unsavoury that we return something to heave in env
 560         returnUs (b, (b, CoVar b))
 561
 562     else -- otherwise, the full business
 563         getUnique                           `thenUs`  \ uniq ->
 564         let
 565             new_b1 = mkIdWithNewUniq b uniq
 566             new_b2 = applyTypeEnvToId tenv new_b1
 567         in
 568         returnUs (new_b2, (b, CoVar new_b2))
 569 \end{code}
 570
 571 %************************************************************************
 572 %*                                                                      *
 573 \subsection[mk_CoreExpr_bits]{Routines to manufacture bits of @CoreExpr@}
 574 %*                                                                      *
 575 %************************************************************************
 576
 577 When making @CoLets@, we may want to take evasive action if the thing
 578 being bound has unboxed type. We have different variants ...
 579
 580 @mkCoLet(s|rec)Any@             let-binds any binding, regardless of type
 581 @mkCoLet(s|rec)NoUnboxed@       prohibits unboxed bindings
 582 @mkCoLet(s)UnboxedToCase@       converts an unboxed binding to a case
 583                                 (unboxed bindings in a letrec are still prohibited)
 584
 585 \begin{code}
 586 mkCoLetAny :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr
 587
 588 mkCoLetAny bind@(CoRec binds) body
 589   = mkCoLetrecAny binds body
 590 mkCoLetAny bind@(CoNonRec binder rhs) body
 591   = case body of
 592       CoVar binder2 | binder `eqId` binder2
 593          -> rhs   -- hey, I have the rhs
 594       other
 595          -> CoLet bind body
 596
 597 mkCoLetsAny []    expr = expr
 598 mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
 599
 600 mkCoLetrecAny :: [(Id, PlainCoreExpr)]  -- bindings
 601               -> PlainCoreExpr          -- body
 602               -> PlainCoreExpr          -- result
 603
 604 mkCoLetrecAny []    body = body
 605 mkCoLetrecAny binds body
 606   = CoLet (CoRec binds) body
 607 \end{code}
 608
 609 \begin{code}
 610 mkCoLetNoUnboxed :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr
 611
 612 mkCoLetNoUnboxed bind@(CoRec binds) body
 613   = mkCoLetrecNoUnboxed binds body
 614 mkCoLetNoUnboxed bind@(CoNonRec binder rhs) body
 615   = ASSERT (not (isUnboxedDataType (getIdUniType binder)))
 616     case body of
 617       CoVar binder2 | binder `eqId` binder2
 618          -> rhs   -- hey, I have the rhs
 619       other
 620          -> CoLet bind body
 621
 622 mkCoLetsNoUnboxed []    expr = expr
 623 mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
 624
 625 mkCoLetrecNoUnboxed :: [(Id, PlainCoreExpr)]    -- bindings
 626                     -> PlainCoreExpr            -- body
 627                     -> PlainCoreExpr            -- result
 628
 629 mkCoLetrecNoUnboxed []    body = body
 630 mkCoLetrecNoUnboxed binds body
 631   = ASSERT (all is_boxed_bind binds)
 632     CoLet (CoRec binds) body
 633   where
 634     is_boxed_bind (binder, rhs)
 635       = (not . isUnboxedDataType . getIdUniType) binder
 636 \end{code}
 637
 638 \begin{code}
 639 mkCoLetUnboxedToCase :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr
 640
 641 mkCoLetUnboxedToCase bind@(CoRec binds) body
 642   = mkCoLetrecNoUnboxed binds body
 643 mkCoLetUnboxedToCase bind@(CoNonRec binder rhs) body
 644   = case body of
 645       CoVar binder2 | binder `eqId` binder2
 646          -> rhs   -- hey, I have the rhs
 647       other
 648          -> if (not (isUnboxedDataType (getIdUniType binder))) then
 649                 CoLet bind body          -- boxed...
 650             else
 651 #ifdef DPH
 652                 let  (tycon,_,_) = getUniDataTyCon (getIdUniType binder) in
 653                 if isPodizedPodTyCon tycon
 654                 then CoCase rhs
 655                        (CoParPrimAlts tycon (getPodizedPodDimension tycon) []
 656                           (CoBindDefault binder body))
 657                 else
 658 #endif {- DPH -}
 659                 CoCase rhs                -- unboxed...
 660                   (CoPrimAlts []
 661                     (CoBindDefault binder body))
 662
 663 mkCoLetsUnboxedToCase []    expr = expr
 664 mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
 665 \end{code}
 666
 667 Clump CoLams together if possible; friendlier to the code generator.
 668
 669 \begin{code}
 670 mkCoLam :: [binder] -> CoreExpr binder bindee -> CoreExpr binder bindee
 671 mkCoLam []      body = body
 672 mkCoLam binders body
 673   = case (digForLambdas body) of { (tyvars, body_binders, body_expr) ->
 674     if not (null tyvars) then
 675         pprTrace "Inner /\\'s:" (ppr PprDebug tyvars)
 676           (CoLam binders (mkCoTyLam tyvars (mkCoLam body_binders body_expr)))
 677     else
 678         CoLam (binders ++ body_binders) body_expr
 679     }
 680
 681 mkCoTyLam :: [TyVar] -> CoreExpr binder bindee -> CoreExpr binder bindee
 682 mkCoTyLam tvs body = foldr CoTyLam body tvs
 683
 684 mkCoTyApps :: CoreExpr binder bindee -> [UniType] -> CoreExpr binder bindee
 685 mkCoTyApps expr tys = foldl mkCoTyApp expr tys
 686 \end{code}
 687
 688 \begin{code}
 689 mkCoreIfThenElse (CoVar bool) then_expr else_expr
 690     | bool `eqId` trueDataCon   = then_expr
 691     | bool `eqId` falseDataCon  = else_expr
 692
 693 mkCoreIfThenElse guard then_expr else_expr
 694   = CoCase guard
 695       (CoAlgAlts [ (trueDataCon,  [], then_expr),
 696                    (falseDataCon, [], else_expr) ]
 697                  CoNoDefault )
 698 \end{code}
 699
 700 \begin{code}
 701 mkErrorCoApp :: UniType -> Id -> String -> PlainCoreExpr
 702
 703 mkErrorCoApp ty str_var error_msg
 704 --OLD:  | not (isPrimType ty)
 705   = CoLet (CoNonRec str_var (CoLit (NoRepStr (_PK_ error_msg)))) (
 706     CoApp (CoTyApp (CoVar pAT_ERROR_ID) ty) (CoVarAtom str_var))
 707 {- TOO PARANOID: removed 95/02 WDP
 708   | otherwise
 709     -- for now, force the user to write their own suitably-typed error msg
 710   = error (ppShow 80 (ppAboves [
 711         ppStr "ERROR: can't generate a pattern-matching error message",
 712         ppStr " when a primitive type is involved.",
 713         ppCat [ppStr "Type:", ppr PprDebug ty],
 714         ppCat [ppStr "Var :", ppr PprDebug str_var],
 715         ppCat [ppStr "Msg :", ppStr error_msg]
 716     ]))
 717 -}
 718
 719 escErrorMsg [] = []
 720 escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
 721 escErrorMsg (x:xs)   = x : escErrorMsg xs
 722 \end{code}
 723
 724 For making @CoApps@ and @CoLets@, we must take appropriate evasive
 725 action if the thing being bound has unboxed type.  @mkCoApp@ requires
 726 a name supply to do its work.  Other-monad code will call @mkCoApp@
 727 through its own interface function (e.g., the desugarer uses
 728 @mkCoAppDs@).
 729
 730 @mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the
 731 arguments-must-be-atoms constraint.
 732
 733 \begin{code}
 734 mkCoApp :: PlainCoreExpr -> PlainCoreExpr -> UniqSM PlainCoreExpr
 735
 736 mkCoApp e1 (CoVar v) = returnUs (CoApp e1 (CoVarAtom v))
 737 mkCoApp e1 (CoLit l) = returnUs (CoApp e1 (CoLitAtom l))
 738 mkCoApp e1 e2
 739   = let
 740         e2_ty = typeOfCoreExpr e2
 741     in
 742     getUnique   `thenUs` \ uniq ->
 743     let
 744         new_var = mkSysLocal SLIT("a") uniq e2_ty mkUnknownSrcLoc
 745     in
 746     returnUs (
 747         mkCoLetUnboxedToCase (CoNonRec new_var e2)
 748                              (CoApp e1 (CoVarAtom new_var))
 749     )
 750 \end{code}
 751
 752 \begin{code}
 753 mkCoCon  :: Id     -> [UniType] -> [PlainCoreExpr] -> UniqSM PlainCoreExpr
 754 mkCoPrim :: PrimOp -> [UniType] -> [PlainCoreExpr] -> UniqSM PlainCoreExpr
 755
 756 mkCoCon con tys args = mkCoThing (CoCon con) tys args
 757 mkCoPrim op tys args = mkCoThing (CoPrim op) tys args
 758
 759 mkCoThing thing tys args
 760   = mapAndUnzipUs expr_to_atom args `thenUs` \ (atoms, maybe_binds) ->
 761     returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing tys atoms))
 762   where
 763     expr_to_atom :: PlainCoreExpr
 764                -> UniqSM (PlainCoreAtom, Maybe PlainCoreBinding)
 765
 766     expr_to_atom (CoVar v) = returnUs (CoVarAtom v, Nothing)
 767     expr_to_atom (CoLit l) = returnUs (CoLitAtom l, Nothing)
 768     expr_to_atom other_expr
 769       = let
 770             e_ty = typeOfCoreExpr other_expr
 771         in
 772         getUnique       `thenUs` \ uniq ->
 773         let
 774             new_var  = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
 775             new_atom = CoVarAtom new_var
 776         in
 777         returnUs (new_atom, Just (CoNonRec new_var other_expr))
 778 \end{code}
 779
 780 \begin{code}
 781 atomToExpr :: CoreAtom bindee -> CoreExpr binder bindee
 782
 783 atomToExpr (CoVarAtom v)   = CoVar v
 784 atomToExpr (CoLitAtom lit) = CoLit lit
 785 \end{code}
 786
 787 \begin{code}
 788 pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)]
 789
 790 pairsFromCoreBinds []                    = []
 791 pairsFromCoreBinds ((CoNonRec b e) : bs) = (b,e) :  (pairsFromCoreBinds bs)
 792 pairsFromCoreBinds ((CoRec  pairs) : bs) = pairs ++ (pairsFromCoreBinds bs)
 793 \end{code}
 794
 795 \begin{code}
 796 #ifdef DPH
 797 mkNonRecBinds :: [(a, CoreExpr a b)] -> [CoreBinding a b]
 798 mkNonRecBinds xs = [ CoNonRec b e | (b,e) <- xs ]
 799
 800 isParCoreCaseAlternative :: CoreCaseAlternatives a b -> Bool
 801 {-
 802 isParCoreCaseAlternative (CoParAlgAlts _ _ _ _ _) = True
 803 isParCoreCaseAlternative (CoParPrimAlts _ _ _ _)  = True
 804 -}
 805 isParCoreCaseAlternative  _                       = False
 806 #endif {- Data Parallel Haskell -}
 807 \end{code}
 808
 809 \begin{code}
 810 mkFunction tys args e
 811   = foldr CoTyLam (mkCoLam args e) tys
 812
 813 mkCoApps :: PlainCoreExpr -> [PlainCoreExpr] -> UniqSM PlainCoreExpr
 814
 815 mkCoApps fun []  = returnUs fun
 816 mkCoApps fun (arg:args)
 817   = mkCoApp fun arg `thenUs` \ new_fun ->
 818     mkCoApps new_fun args
 819 \end{code}
 820
 821 We often want to strip off leading \tr{/\}-bound @TyVars@ and
 822 \tr{\}-bound binders, before we get down to business.  @digForLambdas@
 823 is your friend.
 824
 825 \begin{code}
 826 digForLambdas :: CoreExpr bndr bdee -> ([TyVar], [bndr], CoreExpr bndr bdee)
 827
 828 digForLambdas (CoTyLam tyvar body)
 829   = let
 830         (tyvars, args, final_body) = digForLambdas body
 831     in
 832     (tyvar:tyvars, args, final_body)
 833
 834 digForLambdas other
 835   = let
 836         (args, body) = dig_in_lambdas other
 837     in
 838     ([], args, body)
 839   where
 840     dig_in_lambdas (CoLam args_here body)
 841       = let
 842             (args, final_body) = dig_in_lambdas body
 843         in
 844         (args_here ++ args, final_body)
 845
 846 #ifdef DEBUG
 847     dig_in_lambdas body@(CoTyLam ty expr)
 848       = trace "Inner /\\'s when digging" ([],body)
 849 #endif
 850
 851     dig_in_lambdas body
 852       = ([], body)
 853 \end{code}
 854
 855 \begin{code}
 856 exprSmallEnoughToDup :: CoreExpr binder Id -> Bool
 857
 858 exprSmallEnoughToDup (CoCon _ _ _)   = True     -- Could check # of args
 859 exprSmallEnoughToDup (CoPrim op _ _) = not (fragilePrimOp op)   -- Could check # of args
 860 exprSmallEnoughToDup (CoLit lit) = not (isNoRepLit lit)
 861
 862 exprSmallEnoughToDup expr  -- for now, just: <var> applied to <args>
 863   = case (collectArgs expr) of { (fun, args) ->
 864     case fun of
 865       CoVar v -> v /= buildId && length args <= 6 -- or 10 or 1 or 4 or anything smallish.
 866       _       -> False
 867     }
 868 \end{code}
 869 Question (ADR): What is the above used for?  Is a _ccall_ really small
 870 enough?
 871
 872 @manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
 873 it is obviously in weak head normal form.  It isn't a disaster if it
 874 errs on the conservative side (returning \tr{False})---I've probably
 875 left something out... [WDP]
 876
 877 \begin{code}
 878 manifestlyWHNF :: CoreExpr bndr Id -> Bool
 879
 880 manifestlyWHNF (CoVar _)     = True
 881 manifestlyWHNF (CoLit _)     = True
 882 manifestlyWHNF (CoCon _ _ _) = True  -- ToDo: anything for CoPrim?
 883 manifestlyWHNF (CoLam _ _)   = True
 884 manifestlyWHNF (CoTyLam _ e) = manifestlyWHNF e
 885 manifestlyWHNF (CoSCC _ e)   = manifestlyWHNF e
 886 manifestlyWHNF (CoLet _ e)   = False
 887 manifestlyWHNF (CoCase _ _)  = False
 888
 889 manifestlyWHNF other_expr   -- look for manifest partial application
 890   = case (collectArgs other_expr) of { (fun, args) ->
 891     case fun of
 892       CoVar f -> let
 893                     num_val_args = length [ a | (ValArg a) <- args ]
 894                  in
 895                  num_val_args == 0 ||           -- Just a type application of
 896                                                 -- a variable (f t1 t2 t3)
 897                                                 -- counts as WHNF
 898                  case (arityMaybe (getIdArity f)) of
 899                    Nothing     -> False
 900                    Just arity  -> num_val_args < arity
 901
 902       _ -> False
 903     }
 904 \end{code}
 905
 906 @manifestlyBottom@ looks at a Core expression and returns \tr{True} if
 907 it is obviously bottom, that is, it will certainly return bottom at
 908 some point.  It isn't a disaster if it errs on the conservative side
 909 (returning \tr{False}).
 910
 911 \begin{code}
 912 manifestlyBottom :: CoreExpr bndr Id -> Bool
 913
 914 manifestlyBottom (CoVar v)     = isBottomingId v
 915 manifestlyBottom (CoLit _)     = False
 916 manifestlyBottom (CoCon _ _ _) = False
 917 manifestlyBottom (CoPrim _ _ _)= False
 918 manifestlyBottom (CoLam _ _)   = False  -- we do not assume \x.bottom == bottom. should we? ToDo
 919 manifestlyBottom (CoTyLam _ e) = manifestlyBottom e
 920 manifestlyBottom (CoSCC _ e)   = manifestlyBottom e
 921 manifestlyBottom (CoLet _ e)   = manifestlyBottom e
 922
 923 manifestlyBottom (CoCase e a)
 924   = manifestlyBottom e
 925   || (case a of
 926         CoAlgAlts  alts def -> all mbalg  alts && mbdef def
 927         CoPrimAlts alts def -> all mbprim alts && mbdef def
 928      )
 929   where
 930     mbalg  (_,_,e') = manifestlyBottom e'
 931
 932     mbprim (_,e')   = manifestlyBottom e'
 933
 934     mbdef CoNoDefault          = True
 935     mbdef (CoBindDefault _ e') = manifestlyBottom e'
 936
 937 manifestlyBottom other_expr   -- look for manifest partial application
 938   = case (collectArgs other_expr) of { (fun, args) ->
 939     case fun of
 940       CoVar f | isBottomingId f -> True         -- Application of a function which
 941                                                 -- always gives bottom; we treat this as
 942                                                 -- a WHNF, because it certainly doesn't
 943                                                 -- need to be shared!
 944       _ -> False
 945     }
 946 \end{code}
 947
 948 UNUSED: @manifestWHNFArgs@ guarantees that an expression can absorb n args
 949 before it ceases to be a manifest WHNF.  E.g.,
 950 \begin{verbatim}
 951   (\x->x)        gives 1
 952   (\x -> +Int x) gives 2
 953 \end{verbatim}
 954
 955 The function guarantees to err on the side of conservatism: the
 956 conservative result is (Just 0).
 957
 958 An applications of @error@ are special, because it can absorb as many
 959 arguments as you care to give it.  For this special case we return Nothing.
 960
 961 \begin{code}
 962 {- UNUSED:
 963 manifestWHNFArgs :: CoreExpr bndr Id
 964                  -> Maybe Int           -- Nothing indicates applicn of "error"
 965
 966 manifestWHNFArgs expr
 967   = my_trace (man expr)
 968   where
 969     man (CoLit _)       = Just 0
 970     man (CoCon _ _ _)   = Just 0
 971     man (CoLam bs e)    = man e `plus_args`  length bs
 972     man (CoApp e _)     = man e `minus_args` 1
 973     man (CoTyLam _ e)   = man e
 974     man (CoSCC _ e)     = man e
 975     man (CoLet _ e)     = man e
 976
 977     man (CoVar f)
 978       | isBottomingId f = Nothing
 979       | otherwise       = case (arityMaybe (getIdArity f)) of
 980                             Nothing    -> Just 0
 981                             Just arity -> Just arity
 982
 983     man other           = Just 0 -- Give up on case
 984
 985     plus_args, minus_args :: Maybe Int -> Int -> Maybe Int
 986
 987     plus_args Nothing m = Nothing
 988     plus_args (Just n) m = Just (n+m)
 989
 990     minus_args Nothing m = Nothing
 991     minus_args (Just n) m = Just (n-m)
 992
 993     my_trace n = n
 994     -- if n == 0 then n
 995     -- else pprTrace "manifest:" (ppCat [ppr PprDebug fun,
 996     --                            ppr PprDebug args, ppStr "=>", ppInt n])
 997     --                            n
 998 -}
 999 \end{code}
1000
1001 \begin{code}
1002 coreExprArity
1003         :: (Id -> Maybe (CoreExpr bndr Id))
1004         -> CoreExpr bndr Id
1005         -> Int
1006 coreExprArity f (CoLam bnds expr) = coreExprArity f expr + length (bnds)
1007 coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
1008 coreExprArity f (CoApp expr arg) = max (coreExprArity f expr - 1) 0
1009 coreExprArity f (CoTyApp expr _) = coreExprArity f expr
1010 coreExprArity f (CoVar v) = max further info
1011    where
1012         further
1013              = case f v of
1014                 Nothing -> 0
1015                 Just expr -> coreExprArity f expr
1016         info = case (arityMaybe (getIdArity v)) of
1017                 Nothing    -> 0
1018                 Just arity -> arity
1019 coreExprArity f _ = 0
1020 \end{code}
1021
1022 @isWrapperFor@: we want to see exactly:
1023 \begin{verbatim}
1024 /\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
1025 \end{verbatim}
1026
1027 Probably a little too HACKY [WDP].
1028
1029 \begin{code}
1030 isWrapperFor :: PlainCoreExpr -> Id -> Bool
1031
1032 expr `isWrapperFor` var
1033   = case (digForLambdas  expr) of { (_, args, body) -> -- lambdas off the front
1034     unravel_casing args body
1035     --NO, THANKS: && not (null args)
1036     }
1037   where
1038     var's_worker = getWorkerId (getIdStrictness var)
1039
1040     is_elem = isIn "isWrapperFor"
1041
1042     --------------
1043     unravel_casing case_ables (CoCase scrut alts)
1044       = case (collectArgs scrut) of { (fun, args) ->
1045         case fun of
1046           CoVar scrut_var -> let
1047                                 answer =
1048                                      scrut_var /= var && all (doesn't_mention var) args
1049                                   && scrut_var `is_elem` case_ables
1050                                   && unravel_alts case_ables alts
1051                              in
1052                              answer
1053
1054           _ -> False
1055         }
1056
1057     unravel_casing case_ables other_expr
1058       = case (collectArgs other_expr) of { (fun, args) ->
1059         case fun of
1060           CoVar wrkr -> let
1061                             answer =
1062                                 -- DOESN'T WORK: wrkr == var's_worker
1063                                 wrkr /= var
1064                              && isWorkerId wrkr
1065                              && all (doesn't_mention var)  args
1066                              && all (only_from case_ables) args
1067                         in
1068                         answer
1069
1070           _ -> False
1071         }
1072
1073     --------------
1074     unravel_alts case_ables (CoAlgAlts [(_,params,rhs)] CoNoDefault)
1075       = unravel_casing (params ++ case_ables) rhs
1076     unravel_alts case_ables other = False
1077
1078     -------------------------
1079     doesn't_mention var (ValArg (CoVarAtom v)) = v /= var
1080     doesn't_mention var other = True
1081
1082     -------------------------
1083     only_from case_ables (ValArg (CoVarAtom v)) = v `is_elem` case_ables
1084     only_from case_ables other = True
1085 \end{code}
1086
1087 All the following functions operate on binders, perform a uniform
1088 transformation on them; ie. the function @(\ x -> (x,False))@
1089 annotates all binders with False.
1090
1091 \begin{code}
1092 unTagBinders :: CoreExpr (Id,tag) bdee -> CoreExpr Id bdee
1093 unTagBinders e        = bop_expr fst e
1094
1095 unTagBindersAlts :: CoreCaseAlternatives (Id,tag) bdee -> CoreCaseAlternatives Id bdee
1096 unTagBindersAlts alts = bop_alts fst alts
1097 \end{code}
1098
1099 \begin{code}
1100 bop_expr  :: (a -> b) -> (CoreExpr a c) -> CoreExpr b c
1101
1102 bop_expr f (CoVar b)            = CoVar b
1103 bop_expr f (CoLit lit)          = CoLit lit
1104 bop_expr f (CoCon id u atoms)   = CoCon id u atoms
1105 bop_expr f (CoPrim op tys atoms)= CoPrim op tys atoms
1106 bop_expr f (CoLam binders expr) = CoLam [ f x | x <- binders ] (bop_expr f expr)
1107 bop_expr f (CoTyLam ty expr)    = CoTyLam ty (bop_expr f expr)
1108 bop_expr f (CoApp expr atom)    = CoApp (bop_expr f expr) atom
1109 bop_expr f (CoTyApp expr ty)    = CoTyApp (bop_expr f expr) ty
1110 bop_expr f (CoSCC label expr)   = CoSCC label (bop_expr f expr)
1111 bop_expr f (CoLet bind expr)    = CoLet (bop_bind f bind) (bop_expr f expr)
1112 bop_expr f (CoCase expr alts)
1113   = CoCase (bop_expr f expr) (bop_alts f alts)
1114
1115 bop_bind f (CoNonRec b e)       = CoNonRec (f b) (bop_expr f e)
1116 bop_bind f (CoRec pairs)        = CoRec [(f b, bop_expr f e) | (b, e) <- pairs]
1117
1118 bop_alts f (CoAlgAlts alts deflt)
1119   = CoAlgAlts [ (con, [f b | b <- binders], bop_expr f e)
1120           | (con, binders, e) <- alts ]
1121           (bop_deflt f deflt)
1122
1123 bop_alts f (CoPrimAlts alts deflt)
1124   = CoPrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
1125            (bop_deflt f deflt)
1126
1127 bop_deflt f (CoNoDefault)               = CoNoDefault
1128 bop_deflt f (CoBindDefault b expr)      = CoBindDefault (f b) (bop_expr f expr)
1129
1130 #ifdef DPH
1131 bop_expr f (CoZfExpr expr quals)
1132   = CoZfExpr (bop_expr f expr) (bop_quals quals)
1133   where
1134     bop_quals (CoAndQuals l r)    = CoAndQuals (bop_quals l) (bop_quals r)
1135     bop_quals (CoParFilter e)     = CoParFilter (bop_expr f e)
1136     bop_quals (CoDrawnGen bs b e) = CoDrawnGen (map f bs) (f b) (bop_expr f e)
1137     bop_quals (CoIndexGen es b e) = CoIndexGen (map (bop_expr f) es) (f b)
1138                                                (bop_expr f e)
1139
1140 bop_expr f (CoParCon con ctxt tys args)
1141   = CoParCon con ctxt tys (map (bop_expr f) args)
1142
1143 bop_expr f (CoParComm ctxt e comm)
1144   = CoParComm ctxt (bop_expr f e) (bop_comm comm)
1145   where
1146     bop_comm (CoParSend es)  = CoParSend  (map (bop_expr f) es)
1147     bop_comm (CoParFetch es) = CoParFetch (map (bop_expr f) es)
1148     bop_comm (CoToPodized)   = CoToPodized
1149     bop_comm (CoFromPodized) = CoFromPodized
1150 #endif {- DPH -}
1151 \end{code}
1152
1153 OLD (but left here because of the nice example): @singleAlt@ checks
1154 whether a bunch of case alternatives is actually just one alternative.
1155 It specifically {\em ignores} alternatives which consist of just a
1156 call to @error@, because they won't result in any code duplication.
1157
1158 Example:
1159 \begin{verbatim}
1160         case (case <something> of
1161                 True  -> <rhs>
1162                 False -> error "Foo") of
1163         <alts>
1164
1165 ===>
1166
1167         case <something> of
1168            True ->  case <rhs> of
1169                     <alts>
1170            False -> case error "Foo" of
1171                     <alts>
1172
1173 ===>
1174
1175         case <something> of
1176            True ->  case <rhs> of
1177                     <alts>
1178            False -> error "Foo"
1179 \end{verbatim}
1180 Notice that the \tr{<alts>} don't get duplicated.
1181
1182 \begin{code}
1183 {- UNUSED:
1184 boilsDownToConApp :: CoreExpr bndr bdee -> Bool -- Looks through lets
1185   -- ToDo: could add something for NoRep literals...
1186
1187 boilsDownToConApp (CoCon _ _ _) = True
1188 boilsDownToConApp (CoTyLam _ e) = boilsDownToConApp e
1189 boilsDownToConApp (CoTyApp e _) = boilsDownToConApp e
1190 boilsDownToConApp (CoLet _ e)   = boilsDownToConApp e
1191 boilsDownToConApp other         = False
1192 -}
1193 \end{code}
1194
1195 \begin{code}
1196 nonErrorRHSs :: CoreCaseAlternatives binder Id -> [CoreExpr binder Id]
1197
1198 nonErrorRHSs alts = filter not_error_app (find_rhss alts)
1199   where
1200     find_rhss (CoAlgAlts  alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt
1201     find_rhss (CoPrimAlts alts deflt) = [rhs | (_,rhs)   <- alts] ++ deflt_rhs deflt
1202
1203     deflt_rhs CoNoDefault           = []
1204     deflt_rhs (CoBindDefault _ rhs) = [rhs]
1205
1206     not_error_app rhs = case maybeErrorApp rhs Nothing of
1207                          Just _  -> False
1208                          Nothing -> True
1209 \end{code}
1210
1211 maybeErrorApp checkes whether an expression is of the form
1212
1213         error ty args
1214
1215 If so, it returns
1216
1217         Just (error ty' args)
1218
1219 where ty' is supplied as an argument to maybeErrorApp.
1220
1221 Here's where it is useful:
1222
1223                 case (error ty "Foo" e1 e2) of <alts>
1224  ===>
1225                 error ty' "Foo"
1226
1227 where ty' is the type of any of the alternatives.
1228 You might think this never occurs, but see the comments on
1229 the definition of @singleAlt@.
1230
1231 Note: we *avoid* the case where ty' might end up as a
1232 primitive type: this is very uncool (totally wrong).
1233
1234 NOTICE: in the example above we threw away e1 and e2, but
1235 not the string "Foo".  How did we know to do that?
1236
1237 Answer: for now anyway, we only handle the case of a function
1238 whose type is of form
1239
1240         bottomingFn :: forall a. t1 -> ... -> tn -> a
1241                               ^---------------------^ NB!
1242
1243 Furthermore, we only count a bottomingApp if the function is
1244 applied to more than n args.  If so, we transform:
1245
1246         bottomingFn ty e1 ... en en+1 ... em
1247 to
1248         bottomingFn ty' e1 ... en
1249
1250 That is, we discard en+1 .. em
1251
1252 \begin{code}
1253 maybeErrorApp :: CoreExpr bndr Id   -- Expr to look at
1254               -> Maybe UniType      -- Just ty => a result type *already cloned*;
1255                                     -- Nothing => don't know result ty; we
1256                                     -- *pretend* that the result ty won't be
1257                                     -- primitive -- somebody later must
1258                                     -- ensure this.
1259                -> Maybe (CoreExpr bndr Id)
1260
1261 maybeErrorApp expr result_ty_maybe
1262   = case collectArgs expr of
1263       (CoVar fun, (TypeArg ty : other_args))
1264         | isBottomingId fun
1265         && maybeToBool result_ty_maybe -- we *know* the result type
1266                                        -- (otherwise: live a fairy-tale existence...)
1267         && not (isPrimType result_ty) ->
1268         case splitType (getIdUniType fun) of
1269           ([tyvar_tmpl], [], tau_ty) ->
1270               case (splitTyArgs tau_ty) of { (arg_tys, res_ty) ->
1271               let
1272                   n_args_to_keep = length arg_tys
1273                   args_to_keep   = take n_args_to_keep other_args
1274               in
1275               if  res_ty == mkTyVarTemplateTy tyvar_tmpl &&
1276                   n_args_to_keep <= length other_args
1277               then
1278                     -- Phew!  We're in business
1279                   Just (applyToArgs (CoVar fun)
1280                                     (TypeArg result_ty : args_to_keep))
1281               else
1282                   Nothing
1283               }
1284
1285           other ->      -- Function type wrong shape
1286                     Nothing
1287       other -> Nothing
1288   where
1289     Just result_ty = result_ty_maybe
1290 \end{code}
1291
1292 \begin{code}
1293 squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool
1294
1295 squashableDictishCcExpr cc expr
1296   = if not (isDictCC cc) then
1297         False -- that was easy...
1298     else
1299         squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
1300   where
1301     squashable (CoVar _)      = True
1302     squashable (CoTyApp f _)  = squashable f
1303     squashable (CoCon _ _ _)  = True -- I think so... WDP 94/09
1304     squashable (CoPrim _ _ _) = True -- ditto
1305     squashable other          = False
1306 \end{code}
1307