ghc/compiler/coreSyn/CoreFuns.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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, augmentId,
  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
 866                  && v /= augmentId
 867                  && length args <= 6 -- or 10 or 1 or 4 or anything smallish.
 868       _       -> False
 869     }
 870 \end{code}
 871 Question (ADR): What is the above used for?  Is a _ccall_ really small
 872 enough?
 873
 874 @manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
 875 it is obviously in weak head normal form.  It isn't a disaster if it
 876 errs on the conservative side (returning \tr{False})---I've probably
 877 left something out... [WDP]
 878
 879 \begin{code}
 880 manifestlyWHNF :: CoreExpr bndr Id -> Bool
 881
 882 manifestlyWHNF (CoVar _)     = True
 883 manifestlyWHNF (CoLit _)     = True
 884 manifestlyWHNF (CoCon _ _ _) = True  -- ToDo: anything for CoPrim?
 885 manifestlyWHNF (CoLam _ _)   = True
 886 manifestlyWHNF (CoTyLam _ e) = manifestlyWHNF e
 887 manifestlyWHNF (CoSCC _ e)   = manifestlyWHNF e
 888 manifestlyWHNF (CoLet _ e)   = False
 889 manifestlyWHNF (CoCase _ _)  = False
 890
 891 manifestlyWHNF other_expr   -- look for manifest partial application
 892   = case (collectArgs other_expr) of { (fun, args) ->
 893     case fun of
 894       CoVar f -> let
 895                     num_val_args = length [ a | (ValArg a) <- args ]
 896                  in
 897                  num_val_args == 0 ||           -- Just a type application of
 898                                                 -- a variable (f t1 t2 t3)
 899                                                 -- counts as WHNF
 900                  case (arityMaybe (getIdArity f)) of
 901                    Nothing     -> False
 902                    Just arity  -> num_val_args < arity
 903
 904       _ -> False
 905     }
 906 \end{code}
 907
 908 @manifestlyBottom@ looks at a Core expression and returns \tr{True} if
 909 it is obviously bottom, that is, it will certainly return bottom at
 910 some point.  It isn't a disaster if it errs on the conservative side
 911 (returning \tr{False}).
 912
 913 \begin{code}
 914 manifestlyBottom :: CoreExpr bndr Id -> Bool
 915
 916 manifestlyBottom (CoVar v)     = isBottomingId v
 917 manifestlyBottom (CoLit _)     = False
 918 manifestlyBottom (CoCon _ _ _) = False
 919 manifestlyBottom (CoPrim _ _ _)= False
 920 manifestlyBottom (CoLam _ _)   = False  -- we do not assume \x.bottom == bottom. should we? ToDo
 921 manifestlyBottom (CoTyLam _ e) = manifestlyBottom e
 922 manifestlyBottom (CoSCC _ e)   = manifestlyBottom e
 923 manifestlyBottom (CoLet _ e)   = manifestlyBottom e
 924
 925 manifestlyBottom (CoCase e a)
 926   = manifestlyBottom e
 927   || (case a of
 928         CoAlgAlts  alts def -> all mbalg  alts && mbdef def
 929         CoPrimAlts alts def -> all mbprim alts && mbdef def
 930      )
 931   where
 932     mbalg  (_,_,e') = manifestlyBottom e'
 933
 934     mbprim (_,e')   = manifestlyBottom e'
 935
 936     mbdef CoNoDefault          = True
 937     mbdef (CoBindDefault _ e') = manifestlyBottom e'
 938
 939 manifestlyBottom other_expr   -- look for manifest partial application
 940   = case (collectArgs other_expr) of { (fun, args) ->
 941     case fun of
 942       CoVar f | isBottomingId f -> True         -- Application of a function which
 943                                                 -- always gives bottom; we treat this as
 944                                                 -- a WHNF, because it certainly doesn't
 945                                                 -- need to be shared!
 946       _ -> False
 947     }
 948 \end{code}
 949
 950 UNUSED: @manifestWHNFArgs@ guarantees that an expression can absorb n args
 951 before it ceases to be a manifest WHNF.  E.g.,
 952 \begin{verbatim}
 953   (\x->x)        gives 1
 954   (\x -> +Int x) gives 2
 955 \end{verbatim}
 956
 957 The function guarantees to err on the side of conservatism: the
 958 conservative result is (Just 0).
 959
 960 An applications of @error@ are special, because it can absorb as many
 961 arguments as you care to give it.  For this special case we return Nothing.
 962
 963 \begin{code}
 964 {- UNUSED:
 965 manifestWHNFArgs :: CoreExpr bndr Id
 966                  -> Maybe Int           -- Nothing indicates applicn of "error"
 967
 968 manifestWHNFArgs expr
 969   = my_trace (man expr)
 970   where
 971     man (CoLit _)       = Just 0
 972     man (CoCon _ _ _)   = Just 0
 973     man (CoLam bs e)    = man e `plus_args`  length bs
 974     man (CoApp e _)     = man e `minus_args` 1
 975     man (CoTyLam _ e)   = man e
 976     man (CoSCC _ e)     = man e
 977     man (CoLet _ e)     = man e
 978
 979     man (CoVar f)
 980       | isBottomingId f = Nothing
 981       | otherwise       = case (arityMaybe (getIdArity f)) of
 982                             Nothing    -> Just 0
 983                             Just arity -> Just arity
 984
 985     man other           = Just 0 -- Give up on case
 986
 987     plus_args, minus_args :: Maybe Int -> Int -> Maybe Int
 988
 989     plus_args Nothing m = Nothing
 990     plus_args (Just n) m = Just (n+m)
 991
 992     minus_args Nothing m = Nothing
 993     minus_args (Just n) m = Just (n-m)
 994
 995     my_trace n = n
 996     -- if n == 0 then n
 997     -- else pprTrace "manifest:" (ppCat [ppr PprDebug fun,
 998     --                            ppr PprDebug args, ppStr "=>", ppInt n])
 999     --                            n
1000 -}
1001 \end{code}
1002
1003 \begin{code}
1004 coreExprArity
1005         :: (Id -> Maybe (CoreExpr bndr Id))
1006         -> CoreExpr bndr Id
1007         -> Int
1008 coreExprArity f (CoLam bnds expr) = coreExprArity f expr + length (bnds)
1009 coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
1010 coreExprArity f (CoApp expr arg) = max (coreExprArity f expr - 1) 0
1011 coreExprArity f (CoTyApp expr _) = coreExprArity f expr
1012 coreExprArity f (CoVar v) = max further info
1013    where
1014         further
1015              = case f v of
1016                 Nothing -> 0
1017                 Just expr -> coreExprArity f expr
1018         info = case (arityMaybe (getIdArity v)) of
1019                 Nothing    -> 0
1020                 Just arity -> arity
1021 coreExprArity f _ = 0
1022 \end{code}
1023
1024 @isWrapperFor@: we want to see exactly:
1025 \begin{verbatim}
1026 /\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
1027 \end{verbatim}
1028
1029 Probably a little too HACKY [WDP].
1030
1031 \begin{code}
1032 isWrapperFor :: PlainCoreExpr -> Id -> Bool
1033
1034 expr `isWrapperFor` var
1035   = case (digForLambdas  expr) of { (_, args, body) -> -- lambdas off the front
1036     unravel_casing args body
1037     --NO, THANKS: && not (null args)
1038     }
1039   where
1040     var's_worker = getWorkerId (getIdStrictness var)
1041
1042     is_elem = isIn "isWrapperFor"
1043
1044     --------------
1045     unravel_casing case_ables (CoCase scrut alts)
1046       = case (collectArgs scrut) of { (fun, args) ->
1047         case fun of
1048           CoVar scrut_var -> let
1049                                 answer =
1050                                      scrut_var /= var && all (doesn't_mention var) args
1051                                   && scrut_var `is_elem` case_ables
1052                                   && unravel_alts case_ables alts
1053                              in
1054                              answer
1055
1056           _ -> False
1057         }
1058
1059     unravel_casing case_ables other_expr
1060       = case (collectArgs other_expr) of { (fun, args) ->
1061         case fun of
1062           CoVar wrkr -> let
1063                             answer =
1064                                 -- DOESN'T WORK: wrkr == var's_worker
1065                                 wrkr /= var
1066                              && isWorkerId wrkr
1067                              && all (doesn't_mention var)  args
1068                              && all (only_from case_ables) args
1069                         in
1070                         answer
1071
1072           _ -> False
1073         }
1074
1075     --------------
1076     unravel_alts case_ables (CoAlgAlts [(_,params,rhs)] CoNoDefault)
1077       = unravel_casing (params ++ case_ables) rhs
1078     unravel_alts case_ables other = False
1079
1080     -------------------------
1081     doesn't_mention var (ValArg (CoVarAtom v)) = v /= var
1082     doesn't_mention var other = True
1083
1084     -------------------------
1085     only_from case_ables (ValArg (CoVarAtom v)) = v `is_elem` case_ables
1086     only_from case_ables other = True
1087 \end{code}
1088
1089 All the following functions operate on binders, perform a uniform
1090 transformation on them; ie. the function @(\ x -> (x,False))@
1091 annotates all binders with False.
1092
1093 \begin{code}
1094 unTagBinders :: CoreExpr (Id,tag) bdee -> CoreExpr Id bdee
1095 unTagBinders e        = bop_expr fst e
1096
1097 unTagBindersAlts :: CoreCaseAlternatives (Id,tag) bdee -> CoreCaseAlternatives Id bdee
1098 unTagBindersAlts alts = bop_alts fst alts
1099 \end{code}
1100
1101 \begin{code}
1102 bop_expr  :: (a -> b) -> (CoreExpr a c) -> CoreExpr b c
1103
1104 bop_expr f (CoVar b)            = CoVar b
1105 bop_expr f (CoLit lit)          = CoLit lit
1106 bop_expr f (CoCon id u atoms)   = CoCon id u atoms
1107 bop_expr f (CoPrim op tys atoms)= CoPrim op tys atoms
1108 bop_expr f (CoLam binders expr) = CoLam [ f x | x <- binders ] (bop_expr f expr)
1109 bop_expr f (CoTyLam ty expr)    = CoTyLam ty (bop_expr f expr)
1110 bop_expr f (CoApp expr atom)    = CoApp (bop_expr f expr) atom
1111 bop_expr f (CoTyApp expr ty)    = CoTyApp (bop_expr f expr) ty
1112 bop_expr f (CoSCC label expr)   = CoSCC label (bop_expr f expr)
1113 bop_expr f (CoLet bind expr)    = CoLet (bop_bind f bind) (bop_expr f expr)
1114 bop_expr f (CoCase expr alts)
1115   = CoCase (bop_expr f expr) (bop_alts f alts)
1116
1117 bop_bind f (CoNonRec b e)       = CoNonRec (f b) (bop_expr f e)
1118 bop_bind f (CoRec pairs)        = CoRec [(f b, bop_expr f e) | (b, e) <- pairs]
1119
1120 bop_alts f (CoAlgAlts alts deflt)
1121   = CoAlgAlts [ (con, [f b | b <- binders], bop_expr f e)
1122           | (con, binders, e) <- alts ]
1123           (bop_deflt f deflt)
1124
1125 bop_alts f (CoPrimAlts alts deflt)
1126   = CoPrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
1127            (bop_deflt f deflt)
1128
1129 bop_deflt f (CoNoDefault)               = CoNoDefault
1130 bop_deflt f (CoBindDefault b expr)      = CoBindDefault (f b) (bop_expr f expr)
1131
1132 #ifdef DPH
1133 bop_expr f (CoZfExpr expr quals)
1134   = CoZfExpr (bop_expr f expr) (bop_quals quals)
1135   where
1136     bop_quals (CoAndQuals l r)    = CoAndQuals (bop_quals l) (bop_quals r)
1137     bop_quals (CoParFilter e)     = CoParFilter (bop_expr f e)
1138     bop_quals (CoDrawnGen bs b e) = CoDrawnGen (map f bs) (f b) (bop_expr f e)
1139     bop_quals (CoIndexGen es b e) = CoIndexGen (map (bop_expr f) es) (f b)
1140                                                (bop_expr f e)
1141
1142 bop_expr f (CoParCon con ctxt tys args)
1143   = CoParCon con ctxt tys (map (bop_expr f) args)
1144
1145 bop_expr f (CoParComm ctxt e comm)
1146   = CoParComm ctxt (bop_expr f e) (bop_comm comm)
1147   where
1148     bop_comm (CoParSend es)  = CoParSend  (map (bop_expr f) es)
1149     bop_comm (CoParFetch es) = CoParFetch (map (bop_expr f) es)
1150     bop_comm (CoToPodized)   = CoToPodized
1151     bop_comm (CoFromPodized) = CoFromPodized
1152 #endif {- DPH -}
1153 \end{code}
1154
1155 OLD (but left here because of the nice example): @singleAlt@ checks
1156 whether a bunch of case alternatives is actually just one alternative.
1157 It specifically {\em ignores} alternatives which consist of just a
1158 call to @error@, because they won't result in any code duplication.
1159
1160 Example:
1161 \begin{verbatim}
1162         case (case <something> of
1163                 True  -> <rhs>
1164                 False -> error "Foo") of
1165         <alts>
1166
1167 ===>
1168
1169         case <something> of
1170            True ->  case <rhs> of
1171                     <alts>
1172            False -> case error "Foo" of
1173                     <alts>
1174
1175 ===>
1176
1177         case <something> of
1178            True ->  case <rhs> of
1179                     <alts>
1180            False -> error "Foo"
1181 \end{verbatim}
1182 Notice that the \tr{<alts>} don't get duplicated.
1183
1184 \begin{code}
1185 {- UNUSED:
1186 boilsDownToConApp :: CoreExpr bndr bdee -> Bool -- Looks through lets
1187   -- ToDo: could add something for NoRep literals...
1188
1189 boilsDownToConApp (CoCon _ _ _) = True
1190 boilsDownToConApp (CoTyLam _ e) = boilsDownToConApp e
1191 boilsDownToConApp (CoTyApp e _) = boilsDownToConApp e
1192 boilsDownToConApp (CoLet _ e)   = boilsDownToConApp e
1193 boilsDownToConApp other         = False
1194 -}
1195 \end{code}
1196
1197 \begin{code}
1198 nonErrorRHSs :: CoreCaseAlternatives binder Id -> [CoreExpr binder Id]
1199
1200 nonErrorRHSs alts = filter not_error_app (find_rhss alts)
1201   where
1202     find_rhss (CoAlgAlts  alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt
1203     find_rhss (CoPrimAlts alts deflt) = [rhs | (_,rhs)   <- alts] ++ deflt_rhs deflt
1204
1205     deflt_rhs CoNoDefault           = []
1206     deflt_rhs (CoBindDefault _ rhs) = [rhs]
1207
1208     not_error_app rhs = case maybeErrorApp rhs Nothing of
1209                          Just _  -> False
1210                          Nothing -> True
1211 \end{code}
1212
1213 maybeErrorApp checkes whether an expression is of the form
1214
1215         error ty args
1216
1217 If so, it returns
1218
1219         Just (error ty' args)
1220
1221 where ty' is supplied as an argument to maybeErrorApp.
1222
1223 Here's where it is useful:
1224
1225                 case (error ty "Foo" e1 e2) of <alts>
1226  ===>
1227                 error ty' "Foo"
1228
1229 where ty' is the type of any of the alternatives.
1230 You might think this never occurs, but see the comments on
1231 the definition of @singleAlt@.
1232
1233 Note: we *avoid* the case where ty' might end up as a
1234 primitive type: this is very uncool (totally wrong).
1235
1236 NOTICE: in the example above we threw away e1 and e2, but
1237 not the string "Foo".  How did we know to do that?
1238
1239 Answer: for now anyway, we only handle the case of a function
1240 whose type is of form
1241
1242         bottomingFn :: forall a. t1 -> ... -> tn -> a
1243                               ^---------------------^ NB!
1244
1245 Furthermore, we only count a bottomingApp if the function is
1246 applied to more than n args.  If so, we transform:
1247
1248         bottomingFn ty e1 ... en en+1 ... em
1249 to
1250         bottomingFn ty' e1 ... en
1251
1252 That is, we discard en+1 .. em
1253
1254 \begin{code}
1255 maybeErrorApp :: CoreExpr bndr Id   -- Expr to look at
1256               -> Maybe UniType      -- Just ty => a result type *already cloned*;
1257                                     -- Nothing => don't know result ty; we
1258                                     -- *pretend* that the result ty won't be
1259                                     -- primitive -- somebody later must
1260                                     -- ensure this.
1261                -> Maybe (CoreExpr bndr Id)
1262
1263 maybeErrorApp expr result_ty_maybe
1264   = case collectArgs expr of
1265       (CoVar fun, (TypeArg ty : other_args))
1266         | isBottomingId fun
1267         && maybeToBool result_ty_maybe -- we *know* the result type
1268                                        -- (otherwise: live a fairy-tale existence...)
1269         && not (isPrimType result_ty) ->
1270         case splitType (getIdUniType fun) of
1271           ([tyvar_tmpl], [], tau_ty) ->
1272               case (splitTyArgs tau_ty) of { (arg_tys, res_ty) ->
1273               let
1274                   n_args_to_keep = length arg_tys
1275                   args_to_keep   = take n_args_to_keep other_args
1276               in
1277               if  res_ty == mkTyVarTemplateTy tyvar_tmpl &&
1278                   n_args_to_keep <= length other_args
1279               then
1280                     -- Phew!  We're in business
1281                   Just (applyToArgs (CoVar fun)
1282                                     (TypeArg result_ty : args_to_keep))
1283               else
1284                   Nothing
1285               }
1286
1287           other ->      -- Function type wrong shape
1288                     Nothing
1289       other -> Nothing
1290   where
1291     Just result_ty = result_ty_maybe
1292 \end{code}
1293
1294 \begin{code}
1295 squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool
1296
1297 squashableDictishCcExpr cc expr
1298   = if not (isDictCC cc) then
1299         False -- that was easy...
1300     else
1301         squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
1302   where
1303     squashable (CoVar _)      = True
1304     squashable (CoTyApp f _)  = squashable f
1305     squashable (CoCon _ _ _)  = True -- I think so... WDP 94/09
1306     squashable (CoPrim _ _ _) = True -- ditto
1307     squashable other          = False
1308 \end{code}
1309