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