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