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