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 literal patterns like "foo" to 'f':'o':'o':[]
  95   | str_lit lit           = mk_list lit
  96
  97   | otherwise = default_pat
  98
  99   where
 100     mk_int    (HsInt i)      = HsIntPrim i
 101     mk_int    l@(HsLitLit s) = l
 102
 103     mk_char   (HsChar c)     = HsCharPrim c
 104     mk_char   l@(HsLitLit s) = l
 105
 106     mk_word   l@(HsLitLit s) = l
 107
 108     mk_addr   l@(HsLitLit s) = l
 109
 110     mk_float  (HsInt i)      = HsFloatPrim (fromInteger i)
 111     mk_float  (HsFrac f)     = HsFloatPrim f
 112     mk_float  l@(HsLitLit s) = l
 113
 114     mk_double (HsInt i)      = HsDoublePrim (fromInteger i)
 115     mk_double (HsFrac f)     = HsDoublePrim f
 116     mk_double l@(HsLitLit s) = l
 117
 118     null_str_lit (HsString s) = _NULL_ s
 119     null_str_lit other_lit    = False
 120
 121     str_lit (HsString s)     = True
 122     str_lit _                = False
 123
 124     mk_list (HsString s)     = foldr
 125         (\c pat -> ConPat consDataCon lit_ty [] [] [mk_char_lit c,pat])
 126         (ConPat nilDataCon lit_ty [] [] []) (_UNPK_ s)
 127
 128     mk_char_lit c            = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
 129 \end{code}
 130
 131
 132 %************************************************************************
 133 %*                                                                      *
 134 \subsection{Building lets}
 135 %*                                                                      *
 136 %************************************************************************
 137
 138 Use case, not let for unlifted types.  The simplifier will turn some
 139 back again.
 140
 141 \begin{code}
 142 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
 143 mkDsLet (NonRec bndr rhs) body
 144   | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
 145 mkDsLet bind body
 146   = Let bind body
 147
 148 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
 149 mkDsLets binds body = foldr mkDsLet body binds
 150 \end{code}
 151
 152
 153 %************************************************************************
 154 %*                                                                      *
 155 \subsection{ Selecting match variables}
 156 %*                                                                      *
 157 %************************************************************************
 158
 159 We're about to match against some patterns.  We want to make some
 160 @Ids@ to use as match variables.  If a pattern has an @Id@ readily at
 161 hand, which should indeed be bound to the pattern as a whole, then use it;
 162 otherwise, make one up.
 163
 164 \begin{code}
 165 selectMatchVar :: TypecheckedPat -> DsM Id
 166 selectMatchVar (VarPat var)     = returnDs var
 167 selectMatchVar (AsPat var pat)  = returnDs var
 168 selectMatchVar (LazyPat pat)    = selectMatchVar pat
 169 selectMatchVar other_pat        = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
 170 \end{code}
 171
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 %* type synonym EquationInfo and access functions for its pieces        *
 176 %*                                                                      *
 177 %************************************************************************
 178 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
 179
 180 The ``equation info'' used by @match@ is relatively complicated and
 181 worthy of a type synonym and a few handy functions.
 182
 183 \begin{code}
 184
 185 type EqnNo   = Int
 186 type EqnSet  = UniqSet EqnNo
 187
 188 data EquationInfo
 189   = EqnInfo
 190         EqnNo           -- The number of the equation
 191
 192         DsMatchContext  -- The context info is used when producing warnings
 193                         -- about shadowed patterns.  It's the context
 194                         -- of the *first* thing matched in this group.
 195                         -- Should perhaps be a list of them all!
 196
 197         [TypecheckedPat]    -- The patterns for an eqn
 198
 199         MatchResult         -- Encapsulates the guards and bindings
 200 \end{code}
 201
 202 \begin{code}
 203 data MatchResult
 204   = MatchResult
 205         CanItFail       -- Tells whether the failure expression is used
 206         (CoreExpr -> DsM CoreExpr)
 207                         -- Takes a expression to plug in at the
 208                         -- failure point(s). The expression should
 209                         -- be duplicatable!
 210
 211 data CanItFail = CanFail | CantFail
 212
 213 orFail CantFail CantFail = CantFail
 214 orFail _        _        = CanFail
 215 \end{code}
 216
 217 Functions on MatchResults
 218
 219 \begin{code}
 220 cantFailMatchResult :: CoreExpr -> MatchResult
 221 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
 222
 223 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
 224 extractMatchResult (MatchResult CantFail match_fn) fail_expr
 225   = match_fn (error "It can't fail!")
 226
 227 extractMatchResult (MatchResult CanFail match_fn) fail_expr
 228   = mkFailurePair fail_expr             `thenDs` \ (fail_bind, if_it_fails) ->
 229     match_fn if_it_fails                `thenDs` \ body ->
 230     returnDs (mkDsLet fail_bind body)
 231
 232
 233 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
 234 combineMatchResults (MatchResult CanFail      body_fn1)
 235                     (MatchResult can_it_fail2 body_fn2)
 236   = MatchResult can_it_fail2 body_fn
 237   where
 238     body_fn fail = body_fn2 fail                        `thenDs` \ body2 ->
 239                    mkFailurePair body2                  `thenDs` \ (fail_bind, duplicatable_expr) ->
 240                    body_fn1 duplicatable_expr           `thenDs` \ body1 ->
 241                    returnDs (Let fail_bind body1)
 242
 243 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
 244   = match_result1
 245
 246
 247 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
 248 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
 249   = MatchResult can_it_fail (\fail -> body_fn fail      `thenDs` \ body ->
 250                                       returnDs (encl_fn body))
 251
 252 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
 253 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
 254   = MatchResult can_it_fail (\fail -> body_fn fail      `thenDs` \ body ->
 255                                       encl_fn body)
 256
 257
 258 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
 259 mkCoLetsMatchResult binds match_result
 260   = adjustMatchResult (mkDsLets binds) match_result
 261
 262
 263 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
 264 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
 265   = MatchResult CanFail (\fail -> body_fn fail  `thenDs` \ body ->
 266                                   returnDs (mkIfThenElse pred_expr body fail))
 267
 268 mkCoPrimCaseMatchResult :: Id                           -- Scrutinee
 269                     -> [(Literal, MatchResult)]         -- Alternatives
 270                     -> MatchResult
 271 mkCoPrimCaseMatchResult var match_alts
 272   = MatchResult CanFail mk_case
 273   where
 274     mk_case fail
 275       = mapDs (mk_alt fail) match_alts          `thenDs` \ alts ->
 276         returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)]))
 277
 278     mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail     `thenDs` \ body ->
 279                                                returnDs (LitAlt lit, [], body)
 280
 281
 282 mkCoAlgCaseMatchResult :: Id                                    -- Scrutinee
 283                     -> [(DataCon, [CoreBndr], MatchResult)]     -- Alternatives
 284                     -> MatchResult
 285
 286 mkCoAlgCaseMatchResult var match_alts
 287   | isNewTyCon tycon            -- Newtype case; use a let
 288   = ASSERT( newtype_sanity )
 289     mkCoLetsMatchResult [coercion_bind] match_result
 290
 291   | otherwise                   -- Datatype case; use a case
 292   = MatchResult fail_flag mk_case
 293   where
 294         -- Common stuff
 295     scrut_ty = idType var
 296     (tycon, _, _) = splitAlgTyConApp scrut_ty
 297
 298         -- Stuff for newtype
 299     (_, arg_ids, match_result) = head match_alts
 300     arg_id                     = head arg_ids
 301     coercion_bind              = NonRec arg_id (Note (Coerce (unUsgTy (idType arg_id))
 302                                                              (unUsgTy scrut_ty))
 303                                                      (Var var))
 304     newtype_sanity             = null (tail match_alts) && null (tail arg_ids)
 305
 306         -- Stuff for data types
 307     data_cons = tyConDataCons tycon
 308
 309     match_results             = [match_result | (_,_,match_result) <- match_alts]
 310
 311     fail_flag | exhaustive_case
 312               = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
 313               | otherwise
 314               = CanFail
 315
 316     wild_var = mkWildId (idType var)
 317     mk_case fail = mapDs (mk_alt fail) match_alts       `thenDs` \ alts ->
 318                    returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
 319
 320     mk_alt fail (con, args, MatchResult _ body_fn)
 321         = body_fn fail          `thenDs` \ body ->
 322           rebuildConArgs con args (dataConStrictMarks con) body
 323                                 `thenDs` \ (body', real_args) ->
 324           returnDs (DataAlt con, real_args, body')
 325
 326     mk_default fail | exhaustive_case = []
 327                     | otherwise       = [(DEFAULT, [], fail)]
 328
 329     un_mentioned_constructors
 330         = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
 331     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
 332 \end{code}
 333 %
 334 For each constructor we match on, we might need to re-pack some
 335 of the strict fields if they are unpacked in the constructor.
 336 %
 337 \begin{code}
 338 rebuildConArgs
 339   :: DataCon                            -- the con we're matching on
 340   -> [Id]                               -- the source-level args
 341   -> [StrictnessMark]                   -- the strictness annotations (per-arg)
 342   -> CoreExpr                           -- the body
 343   -> DsM (CoreExpr, [Id])
 344
 345 rebuildConArgs con [] stricts body = returnDs (body, [])
 346 rebuildConArgs con (arg:args) stricts body | isTyVar arg
 347   = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
 348     returnDs (body',arg:args')
 349 rebuildConArgs con (arg:args) (str:stricts) body
 350   = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
 351     case maybeMarkedUnboxed str of
 352         Just (pack_con1, _) ->
 353             case splitProductType_maybe (idType arg) of
 354                 Just (_, tycon_args, pack_con, con_arg_tys) ->
 355                     ASSERT( pack_con == pack_con1 )
 356                     newSysLocalsDs con_arg_tys          `thenDs` \ unpacked_args ->
 357                     returnDs (
 358                          mkDsLet (NonRec arg (mkConApp pack_con
 359                                                   (map Type tycon_args ++
 360                                                    map Var  unpacked_args))) body',
 361                          unpacked_args ++ real_args
 362                     )
 363
 364         _ -> returnDs (body', arg:real_args)
 365 \end{code}
 366
 367 %************************************************************************
 368 %*                                                                      *
 369 \subsection{Desugarer's versions of some Core functions}
 370 %*                                                                      *
 371 %************************************************************************
 372
 373 \begin{code}
 374 mkErrorAppDs :: Id              -- The error function
 375              -> Type            -- Type to which it should be applied
 376              -> String          -- The error message string to pass
 377              -> DsM CoreExpr
 378
 379 mkErrorAppDs err_id ty msg
 380   = getSrcLocDs                 `thenDs` \ src_loc ->
 381     let
 382         full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
 383     in
 384     mkStringLit full_msg                `thenDs` \ core_msg ->
 385     returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, core_msg])
 386     -- unUsgTy *required* -- KSW 1999-04-07
 387
 388 mkStringLit   :: String       -> DsM CoreExpr
 389 mkStringLit str = mkStringLitFS (_PK_ str)
 390
 391 mkStringLitFS :: FAST_STRING  -> DsM CoreExpr
 392 mkStringLitFS str
 393   | any is_NUL (_UNPK_ str)
 394   =      -- Must cater for NULs in literal string
 395     dsLookupGlobalValue unpackCString2IdKey     `thenDs` \ unpack_id ->
 396     returnDs (mkApps (Var unpack_id)
 397                      [Lit (MachStr str),
 398                      mkIntLitInt (_LENGTH_ str)])
 399
 400   | otherwise
 401   =     -- No NULs in the string
 402     dsLookupGlobalValue unpackCStringIdKey      `thenDs` \ unpack_id ->
 403     returnDs (App (Var unpack_id) (Lit (MachStr str)))
 404
 405   where
 406     is_NUL c = c == '\0'
 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