ghc/compiler/deSugar/DsUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[DsUtils]{Utilities for desugaring}
   5
   6 This module exports some utility functions of no great interest.
   7
   8 \begin{code}
   9 #include "HsVersions.h"
  10
  11 module DsUtils (
  12         CanItFail(..), EquationInfo(..), MatchResult(..),
  13
  14         combineGRHSMatchResults,
  15         combineMatchResults,
  16         dsExprToAtom, SYN_IE(DsCoreArg),
  17         mkCoAlgCaseMatchResult,
  18         mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
  19         mkCoLetsMatchResult,
  20         mkCoPrimCaseMatchResult,
  21         mkFailurePair,
  22         mkGuardedMatchResult,
  23         mkSelectorBinds,
  24         mkTupleBind,
  25         mkTupleExpr,
  26         selectMatchVars,
  27         showForErr
  28     ) where
  29
  30 IMP_Ubiq()
  31 IMPORT_DELOOPER(DsLoop)         ( match, matchSimply )
  32
  33 import HsSyn            ( HsExpr(..), OutPat(..), HsLit(..), Fixity,
  34                           Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo )
  35 import TcHsSyn          ( SYN_IE(TypecheckedPat) )
  36 import DsHsSyn          ( outPatType )
  37 import CoreSyn
  38
  39 import DsMonad
  40
  41 import CoreUtils        ( coreExprType, mkCoreIfThenElse )
  42 import PprStyle         ( PprStyle(..) )
  43 import PrelVals         ( iRREFUT_PAT_ERROR_ID, voidId )
  44 import Pretty           ( ppShow, ppBesides, ppStr )
  45 import Id               ( idType, dataConArgTys,
  46 --                        pprId{-ToDo:rm-},
  47                           SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
  48 import Literal          ( Literal(..) )
  49 import TyCon            ( isNewTyCon, tyConDataCons )
  50 import Type             ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
  51                           mkTheta, isUnboxedType, applyTyCon, getAppTyCon
  52                         )
  53 import TysPrim          ( voidTy )
  54 import TysWiredIn       ( tupleTyCon, unitDataCon, tupleCon )
  55 import UniqSet          ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
  56 import Util             ( panic, assertPanic{-, pprTrace ToDo:rm-} )
  57 import Usage            ( SYN_IE(UVar) )
  58 import SrcLoc           ( SrcLoc {- instance Outputable -} )
  59 --import PprCore{-ToDo:rm-}
  60 --import PprType--ToDo:rm
  61 --import Pretty--ToDo:rm
  62 --import TyVar--ToDo:rm
  63 --import Unique--ToDo:rm
  64 \end{code}
  65
  66 %************************************************************************
  67 %*                                                                      *
  68 %* type synonym EquationInfo and access functions for its pieces        *
  69 %*                                                                      *
  70 %************************************************************************
  71 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
  72
  73 The ``equation info'' used by @match@ is relatively complicated and
  74 worthy of a type synonym and a few handy functions.
  75
  76 \begin{code}
  77 data EquationInfo
  78   = EqnInfo
  79         [TypecheckedPat]    -- the patterns for an eqn
  80         MatchResult         -- Encapsulates the guards and bindings
  81 \end{code}
  82
  83 \begin{code}
  84 data MatchResult
  85   = MatchResult
  86         CanItFail
  87         Type            -- Type of argument expression
  88
  89         (CoreExpr -> CoreExpr)
  90                         -- Takes a expression to plug in at the
  91                         -- failure point(s). The expression should
  92                         -- be duplicatable!
  93
  94         DsMatchContext  -- The context info is used when producing warnings
  95                         -- about shadowed patterns.  It's the context
  96                         -- of the *first* thing matched in this group.
  97                         -- Should perhaps be a list of them all!
  98
  99 data CanItFail = CanFail | CantFail
 100
 101 orFail CantFail CantFail = CantFail
 102 orFail _        _        = CanFail
 103
 104
 105 mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
 106 mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)
 107   = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
 108
 109 mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
 110 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
 111   = returnDs (MatchResult CanFail
 112                           ty
 113                           (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
 114                           cxt
 115     )
 116
 117 mkCoPrimCaseMatchResult :: Id                           -- Scrutinee
 118                     -> [(Literal, MatchResult)] -- Alternatives
 119                     -> DsM MatchResult
 120 mkCoPrimCaseMatchResult var alts
 121   = newSysLocalDs (idType var)  `thenDs` \ wild ->
 122     returnDs (MatchResult CanFail
 123                           ty1
 124                           (mk_case alts wild)
 125                           cxt1)
 126   where
 127     ((_,MatchResult _ ty1 _ cxt1) : _) = alts
 128
 129     mk_case alts wild fail_expr
 130       = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
 131       where
 132         final_alts = [ (lit, body_fn fail_expr)
 133                      | (lit, MatchResult _ _ body_fn _) <- alts
 134                      ]
 135
 136
 137 mkCoAlgCaseMatchResult :: Id                            -- Scrutinee
 138                     -> [(DataCon, [Id], MatchResult)]   -- Alternatives
 139                     -> DsM MatchResult
 140
 141 mkCoAlgCaseMatchResult var alts
 142   | isNewTyCon tycon            -- newtype case; use a let
 143   = ASSERT( newtype_sanity )
 144     returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
 145
 146   | otherwise                   -- datatype case
 147   =         -- Find all the constructors in the type which aren't
 148             -- explicitly mentioned in the alternatives:
 149     case un_mentioned_constructors of
 150         [] ->   -- All constructors mentioned, so no default needed
 151                 returnDs (MatchResult can_any_alt_fail
 152                                       ty1
 153                                       (mk_case alts (\ignore -> NoDefault))
 154                                       cxt1)
 155
 156         [con] ->     -- Just one constructor missing, so add a case for it
 157                      -- We need to build new locals for the args of the constructor,
 158                      -- and figuring out their types is somewhat tiresome.
 159                 let
 160                         arg_tys = dataConArgTys con tycon_arg_tys
 161                 in
 162                 newSysLocalsDs arg_tys  `thenDs` \ arg_ids ->
 163
 164                      -- Now we are ready to construct the new alternative
 165                 let
 166                         new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
 167                 in
 168                 returnDs (MatchResult CanFail
 169                                       ty1
 170                                       (mk_case (new_alt:alts) (\ignore -> NoDefault))
 171                                       cxt1)
 172
 173         other ->      -- Many constructors missing, so use a default case
 174                 newSysLocalDs scrut_ty          `thenDs` \ wild ->
 175                 returnDs (MatchResult CanFail
 176                                       ty1
 177                                       (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
 178                                       cxt1)
 179   where
 180         -- Common stuff
 181     scrut_ty = idType var
 182     (tycon, tycon_arg_tys) = --pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $
 183                              getAppTyCon scrut_ty
 184
 185         -- Stuff for newtype
 186     (con_id, arg_ids, match_result) = head alts
 187     arg_id                          = head arg_ids
 188     coercion_bind                   = NonRec arg_id (Coerce (CoerceOut con_id)
 189                                                             (idType arg_id)
 190                                                             (Var var))
 191     newtype_sanity                  = null (tail alts) && null (tail arg_ids)
 192
 193         -- Stuff for data types
 194     data_cons = tyConDataCons tycon
 195
 196     un_mentioned_constructors
 197       = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
 198
 199     match_results = [match_result | (_,_,match_result) <- alts]
 200     (MatchResult _ ty1 _ cxt1 : _) = match_results
 201     can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
 202
 203     mk_case alts deflt_fn fail_expr
 204       = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
 205       where
 206         final_alts = [ (con, args, body_fn fail_expr)
 207                      | (con, args, MatchResult _ _ body_fn _) <- alts
 208                      ]
 209
 210
 211 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
 212 combineMatchResults (MatchResult CanFail      ty1 body_fn1 cxt1)
 213                     (MatchResult can_it_fail2 ty2 body_fn2 cxt2)
 214   = mkFailurePair ty1           `thenDs` \ (bind_fn, duplicatable_expr) ->
 215     let
 216         new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
 217         new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
 218     in
 219     returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
 220
 221 combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
 222                                   match_result2
 223   = returnDs match_result1
 224
 225
 226 -- The difference in combineGRHSMatchResults is that there is no
 227 -- need to let-bind to avoid code duplication
 228 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
 229 combineGRHSMatchResults (MatchResult CanFail     ty1 body_fn1 cxt1)
 230                         (MatchResult can_it_fail ty2 body_fn2 cxt2)
 231   = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
 232
 233 combineGRHSMatchResults match_result1 match_result2
 234   =     -- Delegate to avoid duplication of code
 235     combineMatchResults match_result1 match_result2
 236 \end{code}
 237
 238 %************************************************************************
 239 %*                                                                      *
 240 \subsection[dsExprToAtom]{Take an expression and produce an atom}
 241 %*                                                                      *
 242 %************************************************************************
 243
 244 \begin{code}
 245 dsExprToAtom :: DsCoreArg                   -- The argument expression
 246              -> (CoreArg -> DsM CoreExpr)   -- Something taking the argument *atom*,
 247                                             -- and delivering an expression E
 248              -> DsM CoreExpr                -- Either E or let x=arg-expr in E
 249
 250 dsExprToAtom (UsageArg u) continue_with = continue_with (UsageArg u)
 251 dsExprToAtom (TyArg    t) continue_with = continue_with (TyArg    t)
 252 dsExprToAtom (LitArg   l) continue_with = continue_with (LitArg   l)
 253
 254 dsExprToAtom (VarArg (Var v)) continue_with = continue_with (VarArg v)
 255 dsExprToAtom (VarArg (Lit v)) continue_with = continue_with (LitArg v)
 256
 257 dsExprToAtom (VarArg arg_expr) continue_with
 258   = let
 259         ty = coreExprType arg_expr
 260     in
 261     newSysLocalDs ty                    `thenDs` \ arg_id ->
 262     continue_with (VarArg arg_id)       `thenDs` \ body   ->
 263     returnDs (
 264         if isUnboxedType ty
 265         then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
 266         else Let (NonRec arg_id arg_expr) body
 267     )
 268
 269 dsExprsToAtoms :: [DsCoreArg]
 270                -> ([CoreArg] -> DsM CoreExpr)
 271                -> DsM CoreExpr
 272
 273 dsExprsToAtoms [] continue_with = continue_with []
 274
 275 dsExprsToAtoms (arg:args) continue_with
 276   = dsExprToAtom   arg  $ \ arg_atom  ->
 277     dsExprsToAtoms args $ \ arg_atoms ->
 278     continue_with (arg_atom:arg_atoms)
 279 \end{code}
 280
 281 %************************************************************************
 282 %*                                                                      *
 283 \subsection{Desugarer's versions of some Core functions}
 284 %*                                                                      *
 285 %************************************************************************
 286
 287 \begin{code}
 288 type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
 289
 290 mkAppDs  :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
 291 mkConDs  :: Id       -> [DsCoreArg] -> DsM CoreExpr
 292 mkPrimDs :: PrimOp   -> [DsCoreArg] -> DsM CoreExpr
 293
 294 mkAppDs fun args
 295   = dsExprsToAtoms args $ \ atoms ->
 296     returnDs (mkGenApp fun atoms)
 297
 298 mkConDs con args
 299   = dsExprsToAtoms args $ \ atoms ->
 300     returnDs (Con  con atoms)
 301
 302 mkPrimDs op args
 303   = dsExprsToAtoms args $ \ atoms ->
 304     returnDs (Prim op  atoms)
 305 \end{code}
 306
 307 \begin{code}
 308 showForErr :: Outputable a => a -> String               -- Boring but useful
 309 showForErr thing = ppShow 80 (ppr PprForUser thing)
 310
 311 mkErrorAppDs :: Id              -- The error function
 312              -> Type            -- Type to which it should be applied
 313              -> String          -- The error message string to pass
 314              -> DsM CoreExpr
 315
 316 mkErrorAppDs err_id ty msg
 317   = getSrcLocDs                 `thenDs` \ src_loc ->
 318     let
 319         full_msg = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr ": ", ppStr msg])
 320         msg_lit  = NoRepStr (_PK_ full_msg)
 321     in
 322     returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
 323 \end{code}
 324
 325 %************************************************************************
 326 %*                                                                      *
 327 \subsection[mkSelectorBind]{Make a selector bind}
 328 %*                                                                      *
 329 %************************************************************************
 330
 331 This is used in various places to do with lazy patterns.
 332 For each binder $b$ in the pattern, we create a binding:
 333
 334     b = case v of pat' -> b'
 335
 336 where pat' is pat with each binder b cloned into b'.
 337
 338 ToDo: making these bindings should really depend on whether there's
 339 much work to be done per binding.  If the pattern is complex, it
 340 should be de-mangled once, into a tuple (and then selected from).
 341 Otherwise the demangling can be in-line in the bindings (as here).
 342
 343 Boring!  Boring!  One error message per binder.  The above ToDo is
 344 even more helpful.  Something very similar happens for pattern-bound
 345 expressions.
 346
 347 \begin{code}
 348 mkSelectorBinds :: [TyVar]          -- Variables wrt which the pattern is polymorphic
 349                 -> TypecheckedPat   -- The pattern
 350                 -> [(Id,Id)]        -- Monomorphic and polymorphic binders for
 351                                     -- the pattern
 352                 -> CoreExpr    -- Expression to which the pattern is bound
 353                 -> DsM [(Id,CoreExpr)]
 354
 355 mkSelectorBinds tyvars pat locals_and_globals val_expr
 356   = if is_simple_tuple_pat pat then
 357         mkTupleBind tyvars [] locals_and_globals val_expr
 358     else
 359         mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty ""     `thenDs` \ error_msg ->
 360         matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
 361         mkTupleBind tyvars [] locals_and_globals tuple_expr
 362   where
 363     locals      = [local | (local, _) <- locals_and_globals]
 364     local_tuple = mkTupleExpr locals
 365     res_ty      = coreExprType local_tuple
 366
 367     is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
 368     is_simple_tuple_pat other         = False
 369
 370     is_var_pat (VarPat v) = True
 371     is_var_pat other      = False -- Even wild-card patterns aren't acceptable
 372 \end{code}
 373
 374 We're about to match against some patterns.  We want to make some
 375 @Ids@ to use as match variables.  If a pattern has an @Id@ readily at
 376 hand, which should indeed be bound to the pattern as a whole, then use it;
 377 otherwise, make one up.
 378 \begin{code}
 379 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
 380 selectMatchVars pats
 381   = mapDs var_from_pat_maybe pats
 382   where
 383     var_from_pat_maybe (VarPat var)     = returnDs var
 384     var_from_pat_maybe (AsPat var pat)  = returnDs var
 385     var_from_pat_maybe (LazyPat pat)    = var_from_pat_maybe pat
 386     var_from_pat_maybe other_pat
 387       = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
 388 \end{code}
 389
 390 \begin{code}
 391 mkTupleBind :: [TyVar]      -- Abstract wrt these...
 392         -> [DictVar]        -- ... and these
 393
 394         -> [(Id, Id)]       -- Local, global pairs, equal in number
 395                             -- to the size of the tuple.  The types
 396                             -- of the globals is the generalisation of
 397                             -- the corresp local, wrt the tyvars and dicts
 398
 399         -> CoreExpr    -- Expr whose value is a tuple; the expression
 400                             -- may mention the tyvars and dicts
 401
 402         -> DsM [(Id, CoreExpr)] -- Bindings for the globals
 403 \end{code}
 404
 405 The general call is
 406 \begin{verbatim}
 407         mkTupleBind tyvars dicts [(l1,g1), ..., (ln,gn)] tup_expr
 408 \end{verbatim}
 409 If $n=1$, the result is:
 410 \begin{verbatim}
 411         g1 = /\ tyvars -> \ dicts -> rhs
 412 \end{verbatim}
 413 Otherwise, the result is:
 414 \begin{verbatim}
 415         tup = /\ tyvars -> \ dicts -> tup_expr
 416         g1  = /\ tyvars -> \ dicts -> case (tup tyvars dicts) of
 417                                         (l1, ..., ln) -> l1
 418         ...etc...
 419 \end{verbatim}
 420
 421 \begin{code}
 422 mkTupleBind tyvars dicts [(local,global)] tuple_expr
 423   = returnDs [(global, mkLam tyvars dicts tuple_expr)]
 424 \end{code}
 425
 426 The general case:
 427
 428 \begin{code}
 429 mkTupleBind tyvars dicts local_global_prs tuple_expr
 430   = --pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
 431
 432     newSysLocalDs tuple_var_ty  `thenDs` \ tuple_var ->
 433
 434     zipWithDs (mk_selector (Var tuple_var))
 435               local_global_prs
 436               [(0::Int) .. (length local_global_prs - 1)]
 437                                 `thenDs` \ tup_selectors ->
 438     returnDs (
 439         (tuple_var, mkLam tyvars dicts tuple_expr)
 440         : tup_selectors
 441     )
 442   where
 443     locals, globals :: [Id]
 444     locals  = [local  | (local,global) <- local_global_prs]
 445     globals = [global | (local,global) <- local_global_prs]
 446
 447     no_of_binders = length local_global_prs
 448     tyvar_tys = mkTyVarTys tyvars
 449
 450     tuple_var_ty :: Type
 451     tuple_var_ty
 452       = mkForAllTys tyvars $
 453         mkRhoTy theta      $
 454         applyTyCon (tupleTyCon no_of_binders)
 455                    (map idType locals)
 456       where
 457         theta = mkTheta (map idType dicts)
 458
 459     mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
 460
 461     mk_selector tuple_var_expr (local, global) which_local
 462       = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->
 463         let
 464             selected = binders !! which_local
 465         in
 466         returnDs (
 467             global,
 468             mkLam tyvars dicts (
 469                 mkTupleSelector
 470                     (mkValApp (mkTyApp tuple_var_expr tyvar_tys)
 471                               (map VarArg dicts))
 472                     binders
 473                     selected)
 474         )
 475 \end{code}
 476
 477 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  If it
 478 has only one element, it is the identity function.
 479 \begin{code}
 480 mkTupleExpr :: [Id] -> CoreExpr
 481
 482 mkTupleExpr []   = Con unitDataCon []
 483 mkTupleExpr [id] = Var id
 484 mkTupleExpr ids  = mkCon (tupleCon (length ids))
 485                          [{-usages-}]
 486                          (map idType ids)
 487                          [ VarArg i | i <- ids ]
 488 \end{code}
 489
 490
 491 @mkTupleSelector@ builds a selector which scrutises the given
 492 expression and extracts the one name from the list given.
 493 If you want the no-shadowing rule to apply, the caller
 494 is responsible for making sure that none of these names
 495 are in scope.
 496
 497 If there is just one id in the ``tuple'', then the selector is
 498 just the identity.
 499
 500 \begin{code}
 501 mkTupleSelector :: CoreExpr     -- Scrutinee
 502                 -> [Id]                 -- The tuple args
 503                 -> Id                   -- The selected one
 504                 -> CoreExpr
 505
 506 mkTupleSelector expr [] the_var = panic "mkTupleSelector"
 507
 508 mkTupleSelector expr [var] should_be_the_same_var
 509   = ASSERT(var == should_be_the_same_var)
 510     expr
 511
 512 mkTupleSelector expr vars the_var
 513  = Case expr (AlgAlts [(tupleCon arity, vars, Var the_var)]
 514                           NoDefault)
 515  where
 516    arity = length vars
 517 \end{code}
 518
 519
 520 %************************************************************************
 521 %*                                                                      *
 522 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 523 %*                                                                      *
 524 %************************************************************************
 525
 526 Generally, we handle pattern matching failure like this: let-bind a
 527 fail-variable, and use that variable if the thing fails:
 528 \begin{verbatim}
 529         let fail.33 = error "Help"
 530         in
 531         case x of
 532                 p1 -> ...
 533                 p2 -> fail.33
 534                 p3 -> fail.33
 535                 p4 -> ...
 536 \end{verbatim}
 537 Then
 538 \begin{itemize}
 539 \item
 540 If the case can't fail, then there'll be no mention of fail.33, and the
 541 simplifier will later discard it.
 542
 543 \item
 544 If it can fail in only one way, then the simplifier will inline it.
 545
 546 \item
 547 Only if it is used more than once will the let-binding remain.
 548 \end{itemize}
 549
 550 There's a problem when the result of the case expression is of
 551 unboxed type.  Then the type of fail.33 is unboxed too, and
 552 there is every chance that someone will change the let into a case:
 553 \begin{verbatim}
 554         case error "Help" of
 555           fail.33 -> case ....
 556 \end{verbatim}
 557
 558 which is of course utterly wrong.  Rather than drop the condition that
 559 only boxed types can be let-bound, we just turn the fail into a function
 560 for the primitive case:
 561 \begin{verbatim}
 562         let fail.33 :: Void -> Int#
 563             fail.33 = \_ -> error "Help"
 564         in
 565         case x of
 566                 p1 -> ...
 567                 p2 -> fail.33 void
 568                 p3 -> fail.33 void
 569                 p4 -> ...
 570 \end{verbatim}
 571
 572 Now fail.33 is a function, so it can be let-bound.
 573
 574 \begin{code}
 575 mkFailurePair :: Type           -- Result type of the whole case expression
 576               -> DsM (CoreExpr -> CoreBinding,
 577                                 -- Binds the newly-created fail variable
 578                                 -- to either the expression or \ _ -> expression
 579                       CoreExpr) -- Either the fail variable, or fail variable
 580                                 -- applied to unit tuple
 581 mkFailurePair ty
 582   | isUnboxedType ty
 583   = newFailLocalDs (voidTy `mkFunTy` ty)        `thenDs` \ fail_fun_var ->
 584     newSysLocalDs voidTy                        `thenDs` \ fail_fun_arg ->
 585     returnDs (\ body ->
 586                 NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
 587               App (Var fail_fun_var) (VarArg voidId))
 588
 589   | otherwise
 590   = newFailLocalDs ty           `thenDs` \ fail_var ->
 591     returnDs (\ body -> NonRec fail_var body, Var fail_var)
 592 \end{code}
 593
 594
 595