ghc/compiler/deSugar/DsUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[DsUtils]{Utilities for desugaring}
   5
   6 This module exports some utility functions of no great interest.
   7
   8 \begin{code}
   9 module DsUtils (
  10         CanItFail(..), EquationInfo(..), MatchResult(..),
  11         EqnNo, EqnSet,
  12
  13         tidyLitPat, tidyNPat,
  14
  15         mkDsLet, mkDsLets,
  16
  17         cantFailMatchResult, extractMatchResult,
  18         combineMatchResults,
  19         adjustMatchResult, adjustMatchResultDs,
  20         mkCoLetsMatchResult, mkGuardedMatchResult,
  21         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
  22
  23         mkErrorAppDs, mkNilExpr, mkConsExpr,
  24         mkStringLit, mkStringLitFS, mkIntegerLit,
  25
  26         mkSelectorBinds, mkTupleExpr, mkTupleSelector,
  27
  28         selectMatchVar
  29     ) where
  30
  31 #include "HsVersions.h"
  32
  33 import {-# SOURCE #-} Match ( matchSimply )
  34
  35 import HsSyn
  36 import TcHsSyn          ( TypecheckedPat )
  37 import DsHsSyn          ( outPatType, collectTypedPatBinders )
  38 import CoreSyn
  39
  40 import DsMonad
  41
  42 import CoreUtils        ( exprType, mkIfThenElse )
  43 import PrelInfo         ( iRREFUT_PAT_ERROR_ID )
  44 import Id               ( idType, Id, mkWildId )
  45 import Literal          ( Literal(..), inIntRange, tARGET_MAX_INT )
  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, charPrimTy, floatPrimTy, doublePrimTy )
  54 import TysWiredIn       ( nilDataCon, consDataCon,
  55                           tupleCon,
  56                           stringTy,
  57                           unitDataConId, unitTy,
  58                           charTy, charDataCon,
  59                           intTy, intDataCon, smallIntegerDataCon,
  60                           floatTy, floatDataCon,
  61                           doubleTy, doubleDataCon,
  62                           stringTy
  63                         )
  64 import BasicTypes       ( Boxity(..) )
  65 import UniqSet          ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
  66 import PrelNames        ( unpackCStringName, unpackCStringUtf8Name,
  67                           plusIntegerName, timesIntegerName )
  68 import Outputable
  69 import UnicodeUtil      ( stringToUtf8 )
  70 \end{code}
  71
  72
  73
  74 %************************************************************************
  75 %*                                                                      *
  76 \subsection{Tidying lit pats}
  77 %*                                                                      *
  78 %************************************************************************
  79
  80 \begin{code}
  81 tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat
  82 tidyLitPat (HsChar c) pat = ConPat charDataCon   charTy [] [] [LitPat (HsCharPrim c)   charPrimTy]
  83 tidyLitPat lit        pat = pat
  84
  85 tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat
  86 tidyNPat (HsString s) _ pat
  87   | _LENGTH_ s <= 1     -- Short string literals only
  88   = foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
  89           (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s)
  90         -- The stringTy is the type of the whole pattern, not
  91         -- the type to instantiate (:) or [] with!
  92   where
  93     mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
  94
  95 tidyNPat lit lit_ty default_pat
  96   | lit_ty == intTy     = ConPat intDataCon    lit_ty [] [] [LitPat (mk_int lit)    intPrimTy]
  97   | lit_ty == floatTy   = ConPat floatDataCon  lit_ty [] [] [LitPat (mk_float lit)  floatPrimTy]
  98   | lit_ty == doubleTy  = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
  99   | otherwise           = default_pat
 100
 101   where
 102     mk_int    (HsInteger i) = HsIntPrim i
 103
 104     mk_float  (HsInteger i) = HsFloatPrim (fromInteger i)
 105     mk_float  (HsRat f _)   = HsFloatPrim f
 106
 107     mk_double (HsInteger i) = HsDoublePrim (fromInteger i)
 108     mk_double (HsRat f _)   = HsDoublePrim f
 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 (LitAlt 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, _, _) = splitAlgTyConApp scrut_ty
 277
 278         -- Stuff for newtype
 279     (_, arg_ids, match_result) = head match_alts
 280     arg_id                     = head arg_ids
 281     coercion_bind              = NonRec arg_id (Note (Coerce (unUsgTy (idType arg_id))
 282                                                              (unUsgTy scrut_ty))
 283                                                      (Var var))
 284     newtype_sanity             = null (tail match_alts) && null (tail arg_ids)
 285
 286         -- Stuff for data types
 287     data_cons = tyConDataCons tycon
 288
 289     match_results             = [match_result | (_,_,match_result) <- match_alts]
 290
 291     fail_flag | exhaustive_case
 292               = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
 293               | otherwise
 294               = CanFail
 295
 296     wild_var = mkWildId (idType var)
 297     mk_case fail = mapDs (mk_alt fail) match_alts       `thenDs` \ alts ->
 298                    returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
 299
 300     mk_alt fail (con, args, MatchResult _ body_fn)
 301         = body_fn fail          `thenDs` \ body ->
 302           rebuildConArgs con args (dataConStrictMarks con) body
 303                                 `thenDs` \ (body', real_args) ->
 304           returnDs (DataAlt con, real_args, body')
 305
 306     mk_default fail | exhaustive_case = []
 307                     | otherwise       = [(DEFAULT, [], fail)]
 308
 309     un_mentioned_constructors
 310         = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
 311     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
 312 \end{code}
 313 %
 314 For each constructor we match on, we might need to re-pack some
 315 of the strict fields if they are unpacked in the constructor.
 316 %
 317 \begin{code}
 318 rebuildConArgs
 319   :: DataCon                            -- the con we're matching on
 320   -> [Id]                               -- the source-level args
 321   -> [StrictnessMark]                   -- the strictness annotations (per-arg)
 322   -> CoreExpr                           -- the body
 323   -> DsM (CoreExpr, [Id])
 324
 325 rebuildConArgs con [] stricts body = returnDs (body, [])
 326 rebuildConArgs con (arg:args) stricts body | isTyVar arg
 327   = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
 328     returnDs (body',arg:args')
 329 rebuildConArgs con (arg:args) (str:stricts) body
 330   = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
 331     case maybeMarkedUnboxed str of
 332         Just (pack_con1, _) ->
 333             case splitProductType_maybe (idType arg) of
 334                 Just (_, tycon_args, pack_con, con_arg_tys) ->
 335                     ASSERT( pack_con == pack_con1 )
 336                     newSysLocalsDs con_arg_tys          `thenDs` \ unpacked_args ->
 337                     returnDs (
 338                          mkDsLet (NonRec arg (mkConApp pack_con
 339                                                   (map Type tycon_args ++
 340                                                    map Var  unpacked_args))) body',
 341                          unpacked_args ++ real_args
 342                     )
 343
 344         _ -> returnDs (body', arg:real_args)
 345 \end{code}
 346
 347 %************************************************************************
 348 %*                                                                      *
 349 \subsection{Desugarer's versions of some Core functions}
 350 %*                                                                      *
 351 %************************************************************************
 352
 353 \begin{code}
 354 mkErrorAppDs :: Id              -- The error function
 355              -> Type            -- Type to which it should be applied
 356              -> String          -- The error message string to pass
 357              -> DsM CoreExpr
 358
 359 mkErrorAppDs err_id ty msg
 360   = getSrcLocDs                 `thenDs` \ src_loc ->
 361     let
 362         full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
 363     in
 364     mkStringLit full_msg                `thenDs` \ core_msg ->
 365     returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, core_msg])
 366     -- unUsgTy *required* -- KSW 1999-04-07
 367 \end{code}
 368
 369
 370 *************************************************************
 371 %*                                                                      *
 372 \subsection{Making literals}
 373 %*                                                                      *
 374 %************************************************************************
 375
 376 \begin{code}
 377 mkIntegerLit :: Integer -> DsM CoreExpr
 378 mkIntegerLit i
 379   | inIntRange i        -- Small enough, so start from an Int
 380   = returnDs (mkSmallIntegerLit i)
 381
 382 -- Special case for integral literals with a large magnitude:
 383 -- They are transformed into an expression involving only smaller
 384 -- integral literals. This improves constant folding.
 385
 386   | otherwise           -- Big, so start from a string
 387   = dsLookupGlobalValue plusIntegerName         `thenDs` \ plus_id ->
 388     dsLookupGlobalValue timesIntegerName        `thenDs` \ times_id ->
 389     let
 390         plus a b  = Var plus_id  `App` a `App` b
 391         times a b = Var times_id `App` a `App` b
 392
 393         -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
 394         horner :: Integer -> Integer -> CoreExpr
 395         horner b i | abs q <= 1 = if r == 0 || r == i
 396                                   then mkSmallIntegerLit i
 397                                   else mkSmallIntegerLit r `plus` mkSmallIntegerLit (i-r)
 398                    | r == 0     =                             horner b q `times` mkSmallIntegerLit b
 399                    | otherwise  = mkSmallIntegerLit r `plus` (horner b q `times` mkSmallIntegerLit b)
 400                    where
 401                      (q,r) = i `quotRem` b
 402
 403     in
 404     returnDs (horner tARGET_MAX_INT i)
 405
 406 mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i]
 407
 408 mkStringLit   :: String       -> DsM CoreExpr
 409 mkStringLit str = mkStringLitFS (_PK_ str)
 410
 411 mkStringLitFS :: FAST_STRING  -> DsM CoreExpr
 412 mkStringLitFS str
 413   | _NULL_ str
 414   = returnDs (mkNilExpr charTy)
 415
 416   | _LENGTH_ str == 1
 417   = let
 418         the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_INT_ str))]
 419     in
 420     returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
 421
 422   | all safeChar chars
 423   = dsLookupGlobalValue unpackCStringName       `thenDs` \ unpack_id ->
 424     returnDs (App (Var unpack_id) (Lit (MachStr str)))
 425
 426   | otherwise
 427   = dsLookupGlobalValue unpackCStringUtf8Name   `thenDs` \ unpack_id ->
 428     returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
 429
 430   where
 431     chars = _UNPK_INT_ str
 432     safeChar c = c >= 1 && c <= 0xFF
 433 \end{code}
 434
 435
 436 %************************************************************************
 437 %*                                                                      *
 438 \subsection[mkSelectorBind]{Make a selector bind}
 439 %*                                                                      *
 440 %************************************************************************
 441
 442 This is used in various places to do with lazy patterns.
 443 For each binder $b$ in the pattern, we create a binding:
 444 \begin{verbatim}
 445     b = case v of pat' -> b'
 446 \end{verbatim}
 447 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
 448
 449 ToDo: making these bindings should really depend on whether there's
 450 much work to be done per binding.  If the pattern is complex, it
 451 should be de-mangled once, into a tuple (and then selected from).
 452 Otherwise the demangling can be in-line in the bindings (as here).
 453
 454 Boring!  Boring!  One error message per binder.  The above ToDo is
 455 even more helpful.  Something very similar happens for pattern-bound
 456 expressions.
 457
 458 \begin{code}
 459 mkSelectorBinds :: TypecheckedPat       -- The pattern
 460                 -> CoreExpr             -- Expression to which the pattern is bound
 461                 -> DsM [(Id,CoreExpr)]
 462
 463 mkSelectorBinds (VarPat v) val_expr
 464   = returnDs [(v, val_expr)]
 465
 466 mkSelectorBinds pat val_expr
 467   | length binders == 1 || is_simple_pat pat
 468   = newSysLocalDs (exprType val_expr)   `thenDs` \ val_var ->
 469
 470         -- For the error message we don't use mkErrorAppDs to avoid
 471         -- duplicating the string literal each time
 472     newSysLocalDs stringTy                      `thenDs` \ msg_var ->
 473     getSrcLocDs                                 `thenDs` \ src_loc ->
 474     let
 475         full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
 476     in
 477     mkStringLit full_msg                        `thenDs` \ core_msg ->
 478     mapDs (mk_bind val_var msg_var) binders     `thenDs` \ binds ->
 479     returnDs ( (val_var, val_expr) :
 480                (msg_var, core_msg) :
 481                binds )
 482
 483
 484   | otherwise
 485   = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
 486     `thenDs` \ error_expr ->
 487     matchSimply val_expr LetMatch pat local_tuple error_expr
 488     `thenDs` \ tuple_expr ->
 489     newSysLocalDs tuple_ty
 490     `thenDs` \ tuple_var ->
 491     let
 492         mk_tup_bind binder =
 493           (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
 494     in
 495     returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
 496   where
 497     binders     = collectTypedPatBinders pat
 498     local_tuple = mkTupleExpr binders
 499     tuple_ty    = exprType local_tuple
 500
 501     mk_bind scrut_var msg_var bndr_var
 502     -- (mk_bind sv bv) generates
 503     --          bv = case sv of { pat -> bv; other -> error-msg }
 504     -- Remember, pat binds bv
 505       = matchSimply (Var scrut_var) LetMatch pat
 506                     (Var bndr_var) error_expr                   `thenDs` \ rhs_expr ->
 507         returnDs (bndr_var, rhs_expr)
 508       where
 509         binder_ty = idType bndr_var
 510         error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
 511
 512     is_simple_pat (TuplePat ps Boxed)  = all is_triv_pat ps
 513     is_simple_pat (ConPat _ _ _ _ ps)  = all is_triv_pat ps
 514     is_simple_pat (VarPat _)           = True
 515     is_simple_pat (RecPat _ _ _ _ ps)  = and [is_triv_pat p | (_,p,_) <- ps]
 516     is_simple_pat other                = False
 517
 518     is_triv_pat (VarPat v)  = True
 519     is_triv_pat (WildPat _) = True
 520     is_triv_pat other       = False
 521 \end{code}
 522
 523
 524 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  If it
 525 has only one element, it is the identity function.  Notice we must
 526 throw out any usage annotation on the outside of an Id.
 527
 528 \begin{code}
 529 mkTupleExpr :: [Id] -> CoreExpr
 530
 531 mkTupleExpr []   = Var unitDataConId
 532 mkTupleExpr [id] = Var id
 533 mkTupleExpr ids  = mkConApp (tupleCon Boxed (length ids))
 534                             (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
 535 \end{code}
 536
 537
 538 @mkTupleSelector@ builds a selector which scrutises the given
 539 expression and extracts the one name from the list given.
 540 If you want the no-shadowing rule to apply, the caller
 541 is responsible for making sure that none of these names
 542 are in scope.
 543
 544 If there is just one id in the ``tuple'', then the selector is
 545 just the identity.
 546
 547 \begin{code}
 548 mkTupleSelector :: [Id]         -- The tuple args
 549                 -> Id           -- The selected one
 550                 -> Id           -- A variable of the same type as the scrutinee
 551                 -> CoreExpr     -- Scrutinee
 552                 -> CoreExpr
 553
 554 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
 555   = ASSERT(var == should_be_the_same_var)
 556     scrut
 557
 558 mkTupleSelector vars the_var scrut_var scrut
 559   = ASSERT( not (null vars) )
 560     Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
 561 \end{code}
 562
 563
 564 %************************************************************************
 565 %*                                                                      *
 566 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 567 %*                                                                      *
 568 %************************************************************************
 569
 570 Call the constructor Ids when building explicit lists, so that they
 571 interact well with rules.
 572
 573 \begin{code}
 574 mkNilExpr :: Type -> CoreExpr
 575 mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
 576
 577 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
 578 mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
 579 \end{code}
 580
 581
 582 %************************************************************************
 583 %*                                                                      *
 584 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 585 %*                                                                      *
 586 %************************************************************************
 587
 588 Generally, we handle pattern matching failure like this: let-bind a
 589 fail-variable, and use that variable if the thing fails:
 590 \begin{verbatim}
 591         let fail.33 = error "Help"
 592         in
 593         case x of
 594                 p1 -> ...
 595                 p2 -> fail.33
 596                 p3 -> fail.33
 597                 p4 -> ...
 598 \end{verbatim}
 599 Then
 600 \begin{itemize}
 601 \item
 602 If the case can't fail, then there'll be no mention of @fail.33@, and the
 603 simplifier will later discard it.
 604
 605 \item
 606 If it can fail in only one way, then the simplifier will inline it.
 607
 608 \item
 609 Only if it is used more than once will the let-binding remain.
 610 \end{itemize}
 611
 612 There's a problem when the result of the case expression is of
 613 unboxed type.  Then the type of @fail.33@ is unboxed too, and
 614 there is every chance that someone will change the let into a case:
 615 \begin{verbatim}
 616         case error "Help" of
 617           fail.33 -> case ....
 618 \end{verbatim}
 619
 620 which is of course utterly wrong.  Rather than drop the condition that
 621 only boxed types can be let-bound, we just turn the fail into a function
 622 for the primitive case:
 623 \begin{verbatim}
 624         let fail.33 :: Void -> Int#
 625             fail.33 = \_ -> error "Help"
 626         in
 627         case x of
 628                 p1 -> ...
 629                 p2 -> fail.33 void
 630                 p3 -> fail.33 void
 631                 p4 -> ...
 632 \end{verbatim}
 633
 634 Now @fail.33@ is a function, so it can be let-bound.
 635
 636 \begin{code}
 637 mkFailurePair :: CoreExpr       -- Result type of the whole case expression
 638               -> DsM (CoreBind, -- Binds the newly-created fail variable
 639                                 -- to either the expression or \ _ -> expression
 640                       CoreExpr) -- Either the fail variable, or fail variable
 641                                 -- applied to unit tuple
 642 mkFailurePair expr
 643   | isUnLiftedType ty
 644   = newFailLocalDs (unitTy `mkFunTy` ty)        `thenDs` \ fail_fun_var ->
 645     newSysLocalDs unitTy                        `thenDs` \ fail_fun_arg ->
 646     returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
 647               App (Var fail_fun_var) (Var unitDataConId))
 648
 649   | otherwise
 650   = newFailLocalDs ty           `thenDs` \ fail_var ->
 651     returnDs (NonRec fail_var expr, Var fail_var)
 652   where
 653     ty = exprType expr
 654 \end{code}
 655
 656
 657