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