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, _, _) = splitAlgTyConApp scrut_ty
 292
 293         -- Stuff for newtype
 294     (_, arg_ids, match_result) = head match_alts
 295     arg_id                     = head arg_ids
 296     coercion_bind              = NonRec arg_id (Note (Coerce (unUsgTy (idType arg_id))
 297                                                              (unUsgTy scrut_ty))
 298                                                      (Var var))
 299     newtype_sanity             = null (tail match_alts) && null (tail arg_ids)
 300
 301         -- Stuff for data types
 302     data_cons = tyConDataCons tycon
 303
 304     match_results             = [match_result | (_,_,match_result) <- match_alts]
 305
 306     fail_flag | exhaustive_case
 307               = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
 308               | otherwise
 309               = CanFail
 310
 311     wild_var = mkWildId (idType var)
 312     mk_case fail = mapDs (mk_alt fail) match_alts       `thenDs` \ alts ->
 313                    returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
 314
 315     mk_alt fail (con, args, MatchResult _ body_fn)
 316         = body_fn fail          `thenDs` \ body ->
 317           rebuildConArgs con args (dataConStrictMarks con) body
 318                                 `thenDs` \ (body', real_args) ->
 319           returnDs (DataAlt con, real_args, body')
 320
 321     mk_default fail | exhaustive_case = []
 322                     | otherwise       = [(DEFAULT, [], fail)]
 323
 324     un_mentioned_constructors
 325         = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
 326     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
 327 \end{code}
 328 %
 329 For each constructor we match on, we might need to re-pack some
 330 of the strict fields if they are unpacked in the constructor.
 331 %
 332 \begin{code}
 333 rebuildConArgs
 334   :: DataCon                            -- the con we're matching on
 335   -> [Id]                               -- the source-level args
 336   -> [StrictnessMark]                   -- the strictness annotations (per-arg)
 337   -> CoreExpr                           -- the body
 338   -> DsM (CoreExpr, [Id])
 339
 340 rebuildConArgs con [] stricts body = returnDs (body, [])
 341 rebuildConArgs con (arg:args) stricts body | isTyVar arg
 342   = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
 343     returnDs (body',arg:args')
 344 rebuildConArgs con (arg:args) (str:stricts) body
 345   = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
 346     case maybeMarkedUnboxed str of
 347         Just (pack_con1, _) ->
 348             case splitProductType_maybe (idType arg) of
 349                 Just (_, tycon_args, pack_con, con_arg_tys) ->
 350                     ASSERT( pack_con == pack_con1 )
 351                     newSysLocalsDs con_arg_tys          `thenDs` \ unpacked_args ->
 352                     returnDs (
 353                          mkDsLet (NonRec arg (mkConApp pack_con
 354                                                   (map Type tycon_args ++
 355                                                    map Var  unpacked_args))) body',
 356                          unpacked_args ++ real_args
 357                     )
 358
 359         _ -> returnDs (body', arg:real_args)
 360 \end{code}
 361
 362 %************************************************************************
 363 %*                                                                      *
 364 \subsection{Desugarer's versions of some Core functions}
 365 %*                                                                      *
 366 %************************************************************************
 367
 368 \begin{code}
 369 mkErrorAppDs :: Id              -- The error function
 370              -> Type            -- Type to which it should be applied
 371              -> String          -- The error message string to pass
 372              -> DsM CoreExpr
 373
 374 mkErrorAppDs err_id ty msg
 375   = getSrcLocDs                 `thenDs` \ src_loc ->
 376     let
 377         full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
 378     in
 379     returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg])
 380     -- unUsgTy *required* -- KSW 1999-04-07
 381 \end{code}
 382
 383 %************************************************************************
 384 %*                                                                      *
 385 \subsection[mkSelectorBind]{Make a selector bind}
 386 %*                                                                      *
 387 %************************************************************************
 388
 389 This is used in various places to do with lazy patterns.
 390 For each binder $b$ in the pattern, we create a binding:
 391 \begin{verbatim}
 392     b = case v of pat' -> b'
 393 \end{verbatim}
 394 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
 395
 396 ToDo: making these bindings should really depend on whether there's
 397 much work to be done per binding.  If the pattern is complex, it
 398 should be de-mangled once, into a tuple (and then selected from).
 399 Otherwise the demangling can be in-line in the bindings (as here).
 400
 401 Boring!  Boring!  One error message per binder.  The above ToDo is
 402 even more helpful.  Something very similar happens for pattern-bound
 403 expressions.
 404
 405 \begin{code}
 406 mkSelectorBinds :: TypecheckedPat       -- The pattern
 407                 -> CoreExpr             -- Expression to which the pattern is bound
 408                 -> DsM [(Id,CoreExpr)]
 409
 410 mkSelectorBinds (VarPat v) val_expr
 411   = returnDs [(v, val_expr)]
 412
 413 mkSelectorBinds pat val_expr
 414   | length binders == 1 || is_simple_pat pat
 415   = newSysLocalDs (exprType val_expr)   `thenDs` \ val_var ->
 416
 417         -- For the error message we don't use mkErrorAppDs to avoid
 418         -- duplicating the string literal each time
 419     newSysLocalDs stringTy                      `thenDs` \ msg_var ->
 420     getSrcLocDs                                 `thenDs` \ src_loc ->
 421     let
 422         full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
 423     in
 424     mapDs (mk_bind val_var msg_var) binders     `thenDs` \ binds ->
 425     returnDs ( (val_var, val_expr) :
 426                (msg_var, mkStringLit full_msg) :
 427                binds )
 428
 429
 430   | otherwise
 431   = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
 432     `thenDs` \ error_expr ->
 433     matchSimply val_expr LetMatch pat local_tuple error_expr
 434     `thenDs` \ tuple_expr ->
 435     newSysLocalDs tuple_ty
 436     `thenDs` \ tuple_var ->
 437     let
 438         mk_tup_bind binder =
 439           (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
 440     in
 441     returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
 442   where
 443     binders     = collectTypedPatBinders pat
 444     local_tuple = mkTupleExpr binders
 445     tuple_ty    = exprType local_tuple
 446
 447     mk_bind scrut_var msg_var bndr_var
 448     -- (mk_bind sv bv) generates
 449     --          bv = case sv of { pat -> bv; other -> error-msg }
 450     -- Remember, pat binds bv
 451       = matchSimply (Var scrut_var) LetMatch pat
 452                     (Var bndr_var) error_expr                   `thenDs` \ rhs_expr ->
 453         returnDs (bndr_var, rhs_expr)
 454       where
 455         binder_ty = idType bndr_var
 456         error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
 457
 458     is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps
 459     is_simple_pat (ConPat _ _ _ _ ps)  = all is_triv_pat ps
 460     is_simple_pat (VarPat _)           = True
 461     is_simple_pat (RecPat _ _ _ _ ps)  = and [is_triv_pat p | (_,p,_) <- ps]
 462     is_simple_pat other                = False
 463
 464     is_triv_pat (VarPat v)  = True
 465     is_triv_pat (WildPat _) = True
 466     is_triv_pat other       = False
 467 \end{code}
 468
 469
 470 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  If it
 471 has only one element, it is the identity function.  Notice we must
 472 throw out any usage annotation on the outside of an Id.
 473
 474 \begin{code}
 475 mkTupleExpr :: [Id] -> CoreExpr
 476
 477 mkTupleExpr []   = Var unitDataConId
 478 mkTupleExpr [id] = Var id
 479 mkTupleExpr ids  = mkConApp (tupleCon (length ids))
 480                             (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
 481 \end{code}
 482
 483
 484 @mkTupleSelector@ builds a selector which scrutises the given
 485 expression and extracts the one name from the list given.
 486 If you want the no-shadowing rule to apply, the caller
 487 is responsible for making sure that none of these names
 488 are in scope.
 489
 490 If there is just one id in the ``tuple'', then the selector is
 491 just the identity.
 492
 493 \begin{code}
 494 mkTupleSelector :: [Id]         -- The tuple args
 495                 -> Id           -- The selected one
 496                 -> Id           -- A variable of the same type as the scrutinee
 497                 -> CoreExpr     -- Scrutinee
 498                 -> CoreExpr
 499
 500 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
 501   = ASSERT(var == should_be_the_same_var)
 502     scrut
 503
 504 mkTupleSelector vars the_var scrut_var scrut
 505   = ASSERT( not (null vars) )
 506     Case scrut scrut_var [(DataAlt (tupleCon (length vars)), vars, Var the_var)]
 507 \end{code}
 508
 509
 510 %************************************************************************
 511 %*                                                                      *
 512 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 513 %*                                                                      *
 514 %************************************************************************
 515
 516 Call the constructor Ids when building explicit lists, so that they
 517 interact well with rules.
 518
 519 \begin{code}
 520 mkNilExpr :: Type -> CoreExpr
 521 mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
 522
 523 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
 524 mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
 525 \end{code}
 526
 527
 528 %************************************************************************
 529 %*                                                                      *
 530 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 531 %*                                                                      *
 532 %************************************************************************
 533
 534 Generally, we handle pattern matching failure like this: let-bind a
 535 fail-variable, and use that variable if the thing fails:
 536 \begin{verbatim}
 537         let fail.33 = error "Help"
 538         in
 539         case x of
 540                 p1 -> ...
 541                 p2 -> fail.33
 542                 p3 -> fail.33
 543                 p4 -> ...
 544 \end{verbatim}
 545 Then
 546 \begin{itemize}
 547 \item
 548 If the case can't fail, then there'll be no mention of @fail.33@, and the
 549 simplifier will later discard it.
 550
 551 \item
 552 If it can fail in only one way, then the simplifier will inline it.
 553
 554 \item
 555 Only if it is used more than once will the let-binding remain.
 556 \end{itemize}
 557
 558 There's a problem when the result of the case expression is of
 559 unboxed type.  Then the type of @fail.33@ is unboxed too, and
 560 there is every chance that someone will change the let into a case:
 561 \begin{verbatim}
 562         case error "Help" of
 563           fail.33 -> case ....
 564 \end{verbatim}
 565
 566 which is of course utterly wrong.  Rather than drop the condition that
 567 only boxed types can be let-bound, we just turn the fail into a function
 568 for the primitive case:
 569 \begin{verbatim}
 570         let fail.33 :: Void -> Int#
 571             fail.33 = \_ -> error "Help"
 572         in
 573         case x of
 574                 p1 -> ...
 575                 p2 -> fail.33 void
 576                 p3 -> fail.33 void
 577                 p4 -> ...
 578 \end{verbatim}
 579
 580 Now @fail.33@ is a function, so it can be let-bound.
 581
 582 \begin{code}
 583 mkFailurePair :: CoreExpr       -- Result type of the whole case expression
 584               -> DsM (CoreBind, -- Binds the newly-created fail variable
 585                                 -- to either the expression or \ _ -> expression
 586                       CoreExpr) -- Either the fail variable, or fail variable
 587                                 -- applied to unit tuple
 588 mkFailurePair expr
 589   | isUnLiftedType ty
 590   = newFailLocalDs (unitTy `mkFunTy` ty)        `thenDs` \ fail_fun_var ->
 591     newSysLocalDs unitTy                        `thenDs` \ fail_fun_arg ->
 592     returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
 593               App (Var fail_fun_var) (Var unitDataConId))
 594
 595   | otherwise
 596   = newFailLocalDs ty           `thenDs` \ fail_var ->
 597     returnDs (NonRec fail_var expr, Var fail_var)
 598   where
 599     ty = exprType expr
 600 \end{code}
 601
 602
 603