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