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