ghc/compiler/deSugar/DsUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[DsUtils]{Utilities for desugaring}
   5
   6 This module exports some utility functions of no great interest.
   7
   8 \begin{code}
   9 module DsUtils (
  10         CanItFail(..), EquationInfo(..), MatchResult(..),
  11         EqnNo, EqnSet,
  12
  13         tidyLitPat,
  14
  15         mkDsLet, mkDsLets,
  16
  17         cantFailMatchResult, extractMatchResult,
  18         combineMatchResults,
  19         adjustMatchResult, adjustMatchResultDs,
  20         mkCoLetsMatchResult, mkGuardedMatchResult,
  21         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
  22
  23         mkErrorAppDs, mkNilExpr, mkConsExpr,
  24
  25         mkSelectorBinds, mkTupleExpr, mkTupleSelector,
  26
  27         selectMatchVar
  28     ) where
  29
  30 #include "HsVersions.h"
  31
  32 import {-# SOURCE #-} Match ( matchSimply )
  33
  34 import HsSyn
  35 import TcHsSyn          ( TypecheckedPat )
  36 import DsHsSyn          ( outPatType, collectTypedPatBinders )
  37 import CoreSyn
  38
  39 import DsMonad
  40
  41 import CoreUtils        ( exprType, mkIfThenElse )
  42 import PrelInfo         ( iRREFUT_PAT_ERROR_ID )
  43 import Id               ( idType, Id, mkWildId )
  44 import Literal          ( Literal )
  45 import TyCon            ( isNewTyCon, tyConDataCons )
  46 import DataCon          ( DataCon, StrictnessMark, maybeMarkedUnboxed,
  47                           dataConStrictMarks, dataConId, splitProductType_maybe
  48                         )
  49 import Type             ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy,
  50                           Type
  51                         )
  52 import TysPrim          ( intPrimTy,
  53                           charPrimTy,
  54                           floatPrimTy,
  55                           doublePrimTy,
  56                           addrPrimTy,
  57                           wordPrimTy
  58                         )
  59 import TysWiredIn       ( nilDataCon, consDataCon,
  60                           tupleCon,
  61                           stringTy,
  62                           unitDataConId, unitTy,
  63                           charTy, charDataCon,
  64                           intTy, intDataCon,
  65                           floatTy, floatDataCon,
  66                           doubleTy, doubleDataCon,
  67                           addrTy, addrDataCon,
  68                           wordTy, wordDataCon
  69                         )
  70 import UniqSet          ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
  71 import Outputable
  72 \end{code}
  73
  74
  75
  76 %************************************************************************
  77 %*                                                                      *
  78 \subsection{Tidying lit pats}
  79 %*                                                                      *
  80 %************************************************************************
  81
  82 \begin{code}
  83 tidyLitPat lit lit_ty default_pat
  84   | lit_ty == charTy      = ConPat charDataCon   lit_ty [] [] [LitPat (mk_char lit)   charPrimTy]
  85   | lit_ty == intTy       = ConPat intDataCon    lit_ty [] [] [LitPat (mk_int lit)    intPrimTy]
  86   | lit_ty == wordTy      = ConPat wordDataCon   lit_ty [] [] [LitPat (mk_word lit)   wordPrimTy]
  87   | lit_ty == addrTy      = ConPat addrDataCon   lit_ty [] [] [LitPat (mk_addr lit)   addrPrimTy]
  88   | lit_ty == floatTy     = ConPat floatDataCon  lit_ty [] [] [LitPat (mk_float lit)  floatPrimTy]
  89   | lit_ty == doubleTy    = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
  90
  91                 -- Convert the literal pattern "" to the constructor pattern [].
  92   | null_str_lit lit       = ConPat nilDataCon lit_ty [] [] []
  93                 -- Similar special case for "x"
  94   | one_str_lit lit        = ConPat consDataCon lit_ty [] []
  95                                 [mk_first_char_lit lit, ConPat nilDataCon lit_ty [] [] []]
  96
  97   | otherwise = default_pat
  98
  99   where
 100     mk_int    (HsInt i)      = HsIntPrim i
 101     mk_int    l@(HsLitLit s) = l
 102
 103     mk_char   (HsChar c)     = HsCharPrim c
 104     mk_char   l@(HsLitLit s) = l
 105
 106     mk_word   l@(HsLitLit s) = l
 107
 108     mk_addr   l@(HsLitLit s) = l
 109
 110     mk_float  (HsInt i)      = HsFloatPrim (fromInteger i)
 111     mk_float  (HsFrac f)     = HsFloatPrim f
 112     mk_float  l@(HsLitLit s) = l
 113
 114     mk_double (HsInt i)      = HsDoublePrim (fromInteger i)
 115     mk_double (HsFrac f)     = HsDoublePrim f
 116     mk_double l@(HsLitLit s) = l
 117
 118     null_str_lit (HsString s) = _NULL_ s
 119     null_str_lit other_lit    = False
 120
 121     one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
 122     one_str_lit other_lit    = False
 123     mk_first_char_lit (HsString s) = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim (_HEAD_ s)) charPrimTy]
 124 \end{code}
 125
 126
 127 %************************************************************************
 128 %*                                                                      *
 129 \subsection{Building lets}
 130 %*                                                                      *
 131 %************************************************************************
 132
 133 Use case, not let for unlifted types.  The simplifier will turn some
 134 back again.
 135
 136 \begin{code}
 137 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
 138 mkDsLet (NonRec bndr rhs) body
 139   | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
 140 mkDsLet bind body
 141   = Let bind body
 142
 143 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
 144 mkDsLets binds body = foldr mkDsLet body binds
 145 \end{code}
 146
 147
 148 %************************************************************************
 149 %*                                                                      *
 150 \subsection{ Selecting match variables}
 151 %*                                                                      *
 152 %************************************************************************
 153
 154 We're about to match against some patterns.  We want to make some
 155 @Ids@ to use as match variables.  If a pattern has an @Id@ readily at
 156 hand, which should indeed be bound to the pattern as a whole, then use it;
 157 otherwise, make one up.
 158
 159 \begin{code}
 160 selectMatchVar :: TypecheckedPat -> DsM Id
 161 selectMatchVar (VarPat var)     = returnDs var
 162 selectMatchVar (AsPat var pat)  = returnDs var
 163 selectMatchVar (LazyPat pat)    = selectMatchVar pat
 164 selectMatchVar other_pat        = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
 165 \end{code}
 166
 167
 168 %************************************************************************
 169 %*                                                                      *
 170 %* type synonym EquationInfo and access functions for its pieces        *
 171 %*                                                                      *
 172 %************************************************************************
 173 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
 174
 175 The ``equation info'' used by @match@ is relatively complicated and
 176 worthy of a type synonym and a few handy functions.
 177
 178 \begin{code}
 179
 180 type EqnNo   = Int
 181 type EqnSet  = UniqSet EqnNo
 182
 183 data EquationInfo
 184   = EqnInfo
 185         EqnNo           -- The number of the equation
 186
 187         DsMatchContext  -- The context info is used when producing warnings
 188                         -- about shadowed patterns.  It's the context
 189                         -- of the *first* thing matched in this group.
 190                         -- Should perhaps be a list of them all!
 191
 192         [TypecheckedPat]    -- The patterns for an eqn
 193
 194         MatchResult         -- Encapsulates the guards and bindings
 195 \end{code}
 196
 197 \begin{code}
 198 data MatchResult
 199   = MatchResult
 200         CanItFail       -- Tells whether the failure expression is used
 201         (CoreExpr -> DsM CoreExpr)
 202                         -- Takes a expression to plug in at the
 203                         -- failure point(s). The expression should
 204                         -- be duplicatable!
 205
 206 data CanItFail = CanFail | CantFail
 207
 208 orFail CantFail CantFail = CantFail
 209 orFail _        _        = CanFail
 210 \end{code}
 211
 212 Functions on MatchResults
 213
 214 \begin{code}
 215 cantFailMatchResult :: CoreExpr -> MatchResult
 216 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
 217
 218 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
 219 extractMatchResult (MatchResult CantFail match_fn) fail_expr
 220   = match_fn (error "It can't fail!")
 221
 222 extractMatchResult (MatchResult CanFail match_fn) fail_expr
 223   = mkFailurePair fail_expr             `thenDs` \ (fail_bind, if_it_fails) ->
 224     match_fn if_it_fails                `thenDs` \ body ->
 225     returnDs (mkDsLet fail_bind body)
 226
 227
 228 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
 229 combineMatchResults (MatchResult CanFail      body_fn1)
 230                     (MatchResult can_it_fail2 body_fn2)
 231   = MatchResult can_it_fail2 body_fn
 232   where
 233     body_fn fail = body_fn2 fail                        `thenDs` \ body2 ->
 234                    mkFailurePair body2                  `thenDs` \ (fail_bind, duplicatable_expr) ->
 235                    body_fn1 duplicatable_expr           `thenDs` \ body1 ->
 236                    returnDs (Let fail_bind body1)
 237
 238 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
 239   = match_result1
 240
 241
 242 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
 243 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
 244   = MatchResult can_it_fail (\fail -> body_fn fail      `thenDs` \ body ->
 245                                       returnDs (encl_fn body))
 246
 247 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
 248 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
 249   = MatchResult can_it_fail (\fail -> body_fn fail      `thenDs` \ body ->
 250                                       encl_fn body)
 251
 252
 253 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
 254 mkCoLetsMatchResult binds match_result
 255   = adjustMatchResult (mkDsLets binds) match_result
 256
 257
 258 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
 259 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
 260   = MatchResult CanFail (\fail -> body_fn fail  `thenDs` \ body ->
 261                                   returnDs (mkIfThenElse pred_expr body fail))
 262
 263 mkCoPrimCaseMatchResult :: Id                           -- Scrutinee
 264                     -> [(Literal, MatchResult)]         -- Alternatives
 265                     -> MatchResult
 266 mkCoPrimCaseMatchResult var match_alts
 267   = MatchResult CanFail mk_case
 268   where
 269     mk_case fail
 270       = mapDs (mk_alt fail) match_alts          `thenDs` \ alts ->
 271         returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)]))
 272
 273     mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail     `thenDs` \ body ->
 274                                                returnDs (LitAlt lit, [], body)
 275
 276
 277 mkCoAlgCaseMatchResult :: Id                                    -- Scrutinee
 278                     -> [(DataCon, [CoreBndr], MatchResult)]     -- Alternatives
 279                     -> MatchResult
 280
 281 mkCoAlgCaseMatchResult var match_alts
 282   | isNewTyCon tycon            -- Newtype case; use a let
 283   = ASSERT( newtype_sanity )
 284     mkCoLetsMatchResult [coercion_bind] match_result
 285
 286   | otherwise                   -- Datatype case; use a case
 287   = MatchResult fail_flag mk_case
 288   where
 289         -- Common stuff
 290     scrut_ty = idType var
 291     (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty
 292
 293         -- Stuff for newtype
 294     (con_id, arg_ids, match_result) = head match_alts
 295     arg_id                          = head arg_ids
 296     coercion_bind                   = NonRec arg_id
 297                         (Note (Coerce (unUsgTy (idType arg_id)) (unUsgTy scrut_ty)) (Var var))
 298     newtype_sanity                  = null (tail match_alts) && null (tail arg_ids)
 299
 300         -- Stuff for data types
 301     data_cons = tyConDataCons tycon
 302
 303     match_results             = [match_result | (_,_,match_result) <- match_alts]
 304
 305     fail_flag | exhaustive_case
 306               = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
 307               | otherwise
 308               = CanFail
 309
 310     wild_var = mkWildId (idType var)
 311     mk_case fail = mapDs (mk_alt fail) match_alts       `thenDs` \ alts ->
 312                    returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
 313
 314     mk_alt fail (con, args, MatchResult _ body_fn)
 315         = body_fn fail          `thenDs` \ body ->
 316           rebuildConArgs con args (dataConStrictMarks con) body
 317                                 `thenDs` \ (body', real_args) ->
 318           returnDs (DataAlt con, real_args, body')
 319
 320     mk_default fail | exhaustive_case = []
 321                     | otherwise       = [(DEFAULT, [], fail)]
 322
 323     un_mentioned_constructors
 324         = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
 325     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
 326 \end{code}
 327 %
 328 For each constructor we match on, we might need to re-pack some
 329 of the strict fields if they are unpacked in the constructor.
 330 %
 331 \begin{code}
 332 rebuildConArgs
 333   :: DataCon                            -- the con we're matching on
 334   -> [Id]                               -- the source-level args
 335   -> [StrictnessMark]                   -- the strictness annotations (per-arg)
 336   -> CoreExpr                           -- the body
 337   -> DsM (CoreExpr, [Id])
 338
 339 rebuildConArgs con [] stricts body = returnDs (body, [])
 340 rebuildConArgs con (arg:args) stricts body | isTyVar arg
 341   = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
 342     returnDs (body',arg:args')
 343 rebuildConArgs con (arg:args) (str:stricts) body
 344   = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
 345     case maybeMarkedUnboxed str of
 346         Just (pack_con1, _) ->
 347             case splitProductType_maybe (idType arg) of
 348                 Just (_, tycon_args, pack_con, con_arg_tys) ->
 349                     ASSERT( pack_con == pack_con1 )
 350                     newSysLocalsDs con_arg_tys          `thenDs` \ unpacked_args ->
 351                     returnDs (
 352                          mkDsLet (NonRec arg (mkConApp pack_con
 353                                                   (map Type tycon_args ++
 354                                                    map Var  unpacked_args))) body',
 355                          unpacked_args ++ real_args
 356                     )
 357
 358         _ -> returnDs (body', arg:real_args)
 359 \end{code}
 360
 361 %************************************************************************
 362 %*                                                                      *
 363 \subsection{Desugarer's versions of some Core functions}
 364 %*                                                                      *
 365 %************************************************************************
 366
 367 \begin{code}
 368 mkErrorAppDs :: Id              -- The error function
 369              -> Type            -- Type to which it should be applied
 370              -> String          -- The error message string to pass
 371              -> DsM CoreExpr
 372
 373 mkErrorAppDs err_id ty msg
 374   = getSrcLocDs                 `thenDs` \ src_loc ->
 375     let
 376         full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
 377     in
 378     returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg])
 379     -- unUsgTy *required* -- KSW 1999-04-07
 380 \end{code}
 381
 382 %************************************************************************
 383 %*                                                                      *
 384 \subsection[mkSelectorBind]{Make a selector bind}
 385 %*                                                                      *
 386 %************************************************************************
 387
 388 This is used in various places to do with lazy patterns.
 389 For each binder $b$ in the pattern, we create a binding:
 390 \begin{verbatim}
 391     b = case v of pat' -> b'
 392 \end{verbatim}
 393 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
 394
 395 ToDo: making these bindings should really depend on whether there's
 396 much work to be done per binding.  If the pattern is complex, it
 397 should be de-mangled once, into a tuple (and then selected from).
 398 Otherwise the demangling can be in-line in the bindings (as here).
 399
 400 Boring!  Boring!  One error message per binder.  The above ToDo is
 401 even more helpful.  Something very similar happens for pattern-bound
 402 expressions.
 403
 404 \begin{code}
 405 mkSelectorBinds :: TypecheckedPat       -- The pattern
 406                 -> CoreExpr             -- Expression to which the pattern is bound
 407                 -> DsM [(Id,CoreExpr)]
 408
 409 mkSelectorBinds (VarPat v) val_expr
 410   = returnDs [(v, val_expr)]
 411
 412 mkSelectorBinds pat val_expr
 413   | length binders == 1 || is_simple_pat pat
 414   = newSysLocalDs (exprType val_expr)   `thenDs` \ val_var ->
 415
 416         -- For the error message we don't use mkErrorAppDs to avoid
 417         -- duplicating the string literal each time
 418     newSysLocalDs stringTy                      `thenDs` \ msg_var ->
 419     getSrcLocDs                                 `thenDs` \ src_loc ->
 420     let
 421         full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
 422     in
 423     mapDs (mk_bind val_var msg_var) binders     `thenDs` \ binds ->
 424     returnDs ( (val_var, val_expr) :
 425                (msg_var, mkStringLit full_msg) :
 426                binds )
 427
 428
 429   | otherwise
 430   = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
 431     `thenDs` \ error_expr ->
 432     matchSimply val_expr LetMatch pat local_tuple error_expr
 433     `thenDs` \ tuple_expr ->
 434     newSysLocalDs tuple_ty
 435     `thenDs` \ tuple_var ->
 436     let
 437         mk_tup_bind binder =
 438           (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
 439     in
 440     returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
 441   where
 442     binders     = collectTypedPatBinders pat
 443     local_tuple = mkTupleExpr binders
 444     tuple_ty    = exprType local_tuple
 445
 446     mk_bind scrut_var msg_var bndr_var
 447     -- (mk_bind sv bv) generates
 448     --          bv = case sv of { pat -> bv; other -> error-msg }
 449     -- Remember, pat binds bv
 450       = matchSimply (Var scrut_var) LetMatch pat
 451                     (Var bndr_var) error_expr                   `thenDs` \ rhs_expr ->
 452         returnDs (bndr_var, rhs_expr)
 453       where
 454         binder_ty = idType bndr_var
 455         error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
 456
 457     is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps
 458     is_simple_pat (ConPat _ _ _ _ ps)  = all is_triv_pat ps
 459     is_simple_pat (VarPat _)           = True
 460     is_simple_pat (RecPat _ _ _ _ ps)  = and [is_triv_pat p | (_,p,_) <- ps]
 461     is_simple_pat other                = False
 462
 463     is_triv_pat (VarPat v)  = True
 464     is_triv_pat (WildPat _) = True
 465     is_triv_pat other       = False
 466 \end{code}
 467
 468
 469 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  If it
 470 has only one element, it is the identity function.  Notice we must
 471 throw out any usage annotation on the outside of an Id.
 472
 473 \begin{code}
 474 mkTupleExpr :: [Id] -> CoreExpr
 475
 476 mkTupleExpr []   = Var unitDataConId
 477 mkTupleExpr [id] = Var id
 478 mkTupleExpr ids  = mkConApp (tupleCon (length ids))
 479                             (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
 480 \end{code}
 481
 482
 483 @mkTupleSelector@ builds a selector which scrutises the given
 484 expression and extracts the one name from the list given.
 485 If you want the no-shadowing rule to apply, the caller
 486 is responsible for making sure that none of these names
 487 are in scope.
 488
 489 If there is just one id in the ``tuple'', then the selector is
 490 just the identity.
 491
 492 \begin{code}
 493 mkTupleSelector :: [Id]         -- The tuple args
 494                 -> Id           -- The selected one
 495                 -> Id           -- A variable of the same type as the scrutinee
 496                 -> CoreExpr     -- Scrutinee
 497                 -> CoreExpr
 498
 499 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
 500   = ASSERT(var == should_be_the_same_var)
 501     scrut
 502
 503 mkTupleSelector vars the_var scrut_var scrut
 504   = ASSERT( not (null vars) )
 505     Case scrut scrut_var [(DataAlt (tupleCon (length vars)), vars, Var the_var)]
 506 \end{code}
 507
 508
 509 %************************************************************************
 510 %*                                                                      *
 511 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 512 %*                                                                      *
 513 %************************************************************************
 514
 515 Call the constructor Ids when building explicit lists, so that they
 516 interact well with rules.
 517
 518 \begin{code}
 519 mkNilExpr :: Type -> CoreExpr
 520 mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
 521
 522 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
 523 mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
 524 \end{code}
 525
 526
 527 %************************************************************************
 528 %*                                                                      *
 529 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 530 %*                                                                      *
 531 %************************************************************************
 532
 533 Generally, we handle pattern matching failure like this: let-bind a
 534 fail-variable, and use that variable if the thing fails:
 535 \begin{verbatim}
 536         let fail.33 = error "Help"
 537         in
 538         case x of
 539                 p1 -> ...
 540                 p2 -> fail.33
 541                 p3 -> fail.33
 542                 p4 -> ...
 543 \end{verbatim}
 544 Then
 545 \begin{itemize}
 546 \item
 547 If the case can't fail, then there'll be no mention of @fail.33@, and the
 548 simplifier will later discard it.
 549
 550 \item
 551 If it can fail in only one way, then the simplifier will inline it.
 552
 553 \item
 554 Only if it is used more than once will the let-binding remain.
 555 \end{itemize}
 556
 557 There's a problem when the result of the case expression is of
 558 unboxed type.  Then the type of @fail.33@ is unboxed too, and
 559 there is every chance that someone will change the let into a case:
 560 \begin{verbatim}
 561         case error "Help" of
 562           fail.33 -> case ....
 563 \end{verbatim}
 564
 565 which is of course utterly wrong.  Rather than drop the condition that
 566 only boxed types can be let-bound, we just turn the fail into a function
 567 for the primitive case:
 568 \begin{verbatim}
 569         let fail.33 :: Void -> Int#
 570             fail.33 = \_ -> error "Help"
 571         in
 572         case x of
 573                 p1 -> ...
 574                 p2 -> fail.33 void
 575                 p3 -> fail.33 void
 576                 p4 -> ...
 577 \end{verbatim}
 578
 579 Now @fail.33@ is a function, so it can be let-bound.
 580
 581 \begin{code}
 582 mkFailurePair :: CoreExpr       -- Result type of the whole case expression
 583               -> DsM (CoreBind, -- Binds the newly-created fail variable
 584                                 -- to either the expression or \ _ -> expression
 585                       CoreExpr) -- Either the fail variable, or fail variable
 586                                 -- applied to unit tuple
 587 mkFailurePair expr
 588   | isUnLiftedType ty
 589   = newFailLocalDs (unitTy `mkFunTy` ty)        `thenDs` \ fail_fun_var ->
 590     newSysLocalDs unitTy                        `thenDs` \ fail_fun_arg ->
 591     returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
 592               App (Var fail_fun_var) (Var unitDataConId))
 593
 594   | otherwise
 595   = newFailLocalDs ty           `thenDs` \ fail_var ->
 596     returnDs (NonRec fail_var expr, Var fail_var)
 597   where
 598     ty = exprType expr
 599 \end{code}
 600
 601
 602