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