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, mkListExpr,
  24         mkIntExpr, mkCharExpr,
  25         mkStringLit, mkStringLitFS, mkIntegerExpr,
  26
  27         mkSelectorBinds, mkTupleExpr, mkTupleSelector, mkCoreTup,
  28
  29         selectMatchVar
  30     ) where
  31
  32 #include "HsVersions.h"
  33
  34 import {-# SOURCE #-} Match ( matchSimply )
  35
  36 import HsSyn
  37 import TcHsSyn          ( TypecheckedPat, hsPatType )
  38 import CoreSyn
  39 import Constants        ( mAX_TUPLE_SIZE )
  40 import DsMonad
  41
  42 import CoreUtils        ( exprType, mkIfThenElse, mkCoerce )
  43 import MkId             ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody )
  44 import Id               ( idType, Id, mkWildId, mkTemplateLocals )
  45 import Literal          ( Literal(..), inIntRange, tARGET_MAX_INT )
  46 import TyCon            ( isNewTyCon, tyConDataCons )
  47 import DataCon          ( DataCon, dataConSourceArity )
  48 import Type             ( mkFunTy, isUnLiftedType, Type, splitTyConApp )
  49 import TcType           ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy )
  50 import TysPrim          ( intPrimTy )
  51 import TysWiredIn       ( nilDataCon, consDataCon,
  52                           tupleCon, mkTupleTy,
  53                           unitDataConId, unitTy,
  54                           charTy, charDataCon,
  55                           intTy, intDataCon, smallIntegerDataCon,
  56                           floatDataCon,
  57                           doubleDataCon,
  58                           stringTy, isPArrFakeCon )
  59 import BasicTypes       ( Boxity(..) )
  60 import UniqSet          ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
  61 import PrelNames        ( unpackCStringName, unpackCStringUtf8Name,
  62                           plusIntegerName, timesIntegerName,
  63                           lengthPName, indexPName )
  64 import Outputable
  65 import UnicodeUtil      ( intsToUtf8, stringToUtf8 )
  66 import Util             ( isSingleton, notNull, zipEqual )
  67 import FastString
  68 \end{code}
  69
  70
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 \subsection{Tidying lit pats}
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 \begin{code}
  79 tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat
  80 tidyLitPat (HsChar c) pat = mkCharLitPat c
  81 tidyLitPat lit        pat = pat
  82
  83 tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat
  84 tidyNPat (HsString s) _ pat
  85   | lengthFS s <= 1     -- Short string literals only
  86   = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
  87           (mkNilPat stringTy) (unpackIntFS s)
  88         -- The stringTy is the type of the whole pattern, not
  89         -- the type to instantiate (:) or [] with!
  90   where
  91
  92 tidyNPat lit lit_ty default_pat
  93   | isIntTy lit_ty      = mkPrefixConPat intDataCon    [LitPat (mk_int lit)]    lit_ty
  94   | isFloatTy lit_ty    = mkPrefixConPat floatDataCon  [LitPat (mk_float lit)]  lit_ty
  95   | isDoubleTy lit_ty   = mkPrefixConPat doubleDataCon [LitPat (mk_double lit)] lit_ty
  96   | otherwise           = default_pat
  97
  98   where
  99     mk_int    (HsInteger i) = HsIntPrim i
 100
 101     mk_float  (HsInteger i) = HsFloatPrim (fromInteger i)
 102     mk_float  (HsRat f _)   = HsFloatPrim f
 103
 104     mk_double (HsInteger i) = HsDoublePrim (fromInteger i)
 105     mk_double (HsRat f _)   = HsDoublePrim f
 106 \end{code}
 107
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 \subsection{Building lets}
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 Use case, not let for unlifted types.  The simplifier will turn some
 116 back again.
 117
 118 \begin{code}
 119 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
 120 mkDsLet (NonRec bndr rhs) body
 121   | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
 122 mkDsLet bind body
 123   = Let bind body
 124
 125 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
 126 mkDsLets binds body = foldr mkDsLet body binds
 127 \end{code}
 128
 129
 130 %************************************************************************
 131 %*                                                                      *
 132 \subsection{ Selecting match variables}
 133 %*                                                                      *
 134 %************************************************************************
 135
 136 We're about to match against some patterns.  We want to make some
 137 @Ids@ to use as match variables.  If a pattern has an @Id@ readily at
 138 hand, which should indeed be bound to the pattern as a whole, then use it;
 139 otherwise, make one up.
 140
 141 \begin{code}
 142 selectMatchVar :: TypecheckedPat -> DsM Id
 143 selectMatchVar (VarPat var)     = returnDs var
 144 selectMatchVar (AsPat var pat)  = returnDs var
 145 selectMatchVar (LazyPat pat)    = selectMatchVar pat
 146 selectMatchVar other_pat        = newSysLocalDs (hsPatType other_pat) -- OK, better make up one...
 147 \end{code}
 148
 149
 150 %************************************************************************
 151 %*                                                                      *
 152 %* type synonym EquationInfo and access functions for its pieces        *
 153 %*                                                                      *
 154 %************************************************************************
 155 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
 156
 157 The ``equation info'' used by @match@ is relatively complicated and
 158 worthy of a type synonym and a few handy functions.
 159
 160 \begin{code}
 161
 162 type EqnNo   = Int
 163 type EqnSet  = UniqSet EqnNo
 164
 165 data EquationInfo
 166   = EqnInfo
 167         EqnNo           -- The number of the equation
 168
 169         DsMatchContext  -- The context info is used when producing warnings
 170                         -- about shadowed patterns.  It's the context
 171                         -- of the *first* thing matched in this group.
 172                         -- Should perhaps be a list of them all!
 173
 174         [TypecheckedPat]    -- The patterns for an eqn
 175
 176         MatchResult         -- Encapsulates the guards and bindings
 177 \end{code}
 178
 179 \begin{code}
 180 data MatchResult
 181   = MatchResult
 182         CanItFail       -- Tells whether the failure expression is used
 183         (CoreExpr -> DsM CoreExpr)
 184                         -- Takes a expression to plug in at the
 185                         -- failure point(s). The expression should
 186                         -- be duplicatable!
 187
 188 data CanItFail = CanFail | CantFail
 189
 190 orFail CantFail CantFail = CantFail
 191 orFail _        _        = CanFail
 192 \end{code}
 193
 194 Functions on MatchResults
 195
 196 \begin{code}
 197 cantFailMatchResult :: CoreExpr -> MatchResult
 198 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
 199
 200 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
 201 extractMatchResult (MatchResult CantFail match_fn) fail_expr
 202   = match_fn (error "It can't fail!")
 203
 204 extractMatchResult (MatchResult CanFail match_fn) fail_expr
 205   = mkFailurePair fail_expr             `thenDs` \ (fail_bind, if_it_fails) ->
 206     match_fn if_it_fails                `thenDs` \ body ->
 207     returnDs (mkDsLet fail_bind body)
 208
 209
 210 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
 211 combineMatchResults (MatchResult CanFail      body_fn1)
 212                     (MatchResult can_it_fail2 body_fn2)
 213   = MatchResult can_it_fail2 body_fn
 214   where
 215     body_fn fail = body_fn2 fail                        `thenDs` \ body2 ->
 216                    mkFailurePair body2                  `thenDs` \ (fail_bind, duplicatable_expr) ->
 217                    body_fn1 duplicatable_expr           `thenDs` \ body1 ->
 218                    returnDs (Let fail_bind body1)
 219
 220 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
 221   = match_result1
 222
 223
 224 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
 225 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
 226   = MatchResult can_it_fail (\fail -> body_fn fail      `thenDs` \ body ->
 227                                       returnDs (encl_fn body))
 228
 229 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
 230 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
 231   = MatchResult can_it_fail (\fail -> body_fn fail      `thenDs` \ body ->
 232                                       encl_fn body)
 233
 234
 235 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
 236 mkCoLetsMatchResult binds match_result
 237   = adjustMatchResult (mkDsLets binds) match_result
 238
 239
 240 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
 241 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
 242   = MatchResult CanFail (\fail -> body_fn fail  `thenDs` \ body ->
 243                                   returnDs (mkIfThenElse pred_expr body fail))
 244
 245 mkCoPrimCaseMatchResult :: Id                           -- Scrutinee
 246                     -> [(Literal, MatchResult)]         -- Alternatives
 247                     -> MatchResult
 248 mkCoPrimCaseMatchResult var match_alts
 249   = MatchResult CanFail mk_case
 250   where
 251     mk_case fail
 252       = mapDs (mk_alt fail) match_alts          `thenDs` \ alts ->
 253         returnDs (Case (Var var) var ((DEFAULT, [], fail) : alts))
 254
 255     mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail     `thenDs` \ body ->
 256                                                returnDs (LitAlt lit, [], body)
 257
 258
 259 mkCoAlgCaseMatchResult :: Id                                    -- Scrutinee
 260                     -> [(DataCon, [CoreBndr], MatchResult)]     -- Alternatives
 261                     -> MatchResult
 262
 263 mkCoAlgCaseMatchResult var match_alts
 264   | isNewTyCon tycon            -- Newtype case; use a let
 265   = ASSERT( null (tail match_alts) && null (tail arg_ids) )
 266     mkCoLetsMatchResult [NonRec arg_id newtype_rhs] match_result
 267
 268   | isPArrFakeAlts match_alts   -- Sugared parallel array; use a literal case
 269   = MatchResult CanFail mk_parrCase
 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    = tcTyConAppTyCon scrut_ty         -- Newtypes must be opaque here
 277
 278         -- Stuff for newtype
 279     (_, arg_ids, match_result) = head match_alts
 280     arg_id                     = head arg_ids
 281     newtype_rhs                = mkNewTypeBody tycon (idType arg_id) (Var var)
 282
 283         -- Stuff for data types
 284     data_cons      = tyConDataCons tycon
 285     match_results  = [match_result | (_,_,match_result) <- match_alts]
 286
 287     fail_flag | exhaustive_case
 288               = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
 289               | otherwise
 290               = CanFail
 291
 292     wild_var = mkWildId (idType var)
 293     mk_case fail = mapDs (mk_alt fail) match_alts       `thenDs` \ alts ->
 294                    returnDs (Case (Var var) wild_var (mk_default fail ++ alts))
 295
 296     mk_alt fail (con, args, MatchResult _ body_fn)
 297         = body_fn fail                          `thenDs` \ body ->
 298           getUniquesDs                          `thenDs` \ us ->
 299           returnDs (mkReboxingAlt us con args body)
 300
 301     mk_default fail | exhaustive_case = []
 302                     | otherwise       = [(DEFAULT, [], fail)]
 303
 304     un_mentioned_constructors
 305         = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
 306     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
 307
 308         -- Stuff for parallel arrays
 309         --
 310         -- * the following is to desugar cases over fake constructors for
 311         --   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
 312         --   case
 313         --
 314         -- Concerning `isPArrFakeAlts':
 315         --
 316         -- * it is *not* sufficient to just check the type of the type
 317         --   constructor, as we have to be careful not to confuse the real
 318         --   representation of parallel arrays with the fake constructors;
 319         --   moreover, a list of alternatives must not mix fake and real
 320         --   constructors (this is checked earlier on)
 321         --
 322         -- FIXME: We actually go through the whole list and make sure that
 323         --        either all or none of the constructors are fake parallel
 324         --        array constructors.  This is to spot equations that mix fake
 325         --        constructors with the real representation defined in
 326         --        `PrelPArr'.  It would be nicer to spot this situation
 327         --        earlier and raise a proper error message, but it can really
 328         --        only happen in `PrelPArr' anyway.
 329         --
 330     isPArrFakeAlts [(dcon, _, _)]      = isPArrFakeCon dcon
 331     isPArrFakeAlts ((dcon, _, _):alts) =
 332       case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
 333         (True , True ) -> True
 334         (False, False) -> False
 335         _              ->
 336           panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
 337     --
 338     mk_parrCase fail =
 339       dsLookupGlobalId lengthPName                      `thenDs` \lengthP  ->
 340       unboxAlt                                          `thenDs` \alt      ->
 341       returnDs (Case (len lengthP) (mkWildId intTy) [alt])
 342       where
 343         elemTy      = case splitTyConApp (idType var) of
 344                         (_, [elemTy]) -> elemTy
 345                         _               -> panic panicMsg
 346         panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
 347         len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
 348         --
 349         unboxAlt =
 350           newSysLocalDs intPrimTy                       `thenDs` \l        ->
 351           dsLookupGlobalId indexPName           `thenDs` \indexP   ->
 352           mapDs (mkAlt indexP) match_alts               `thenDs` \alts     ->
 353           returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts)))
 354           where
 355             wild = mkWildId intPrimTy
 356             dft  = (DEFAULT, [], fail)
 357         --
 358         -- each alternative matches one array length (corresponding to one
 359         -- fake array constructor), so the match is on a literal; each
 360         -- alternative's body is extended by a local binding for each
 361         -- constructor argument, which are bound to array elements starting
 362         -- with the first
 363         --
 364         mkAlt indexP (con, args, MatchResult _ bodyFun) =
 365           bodyFun fail                                  `thenDs` \body     ->
 366           returnDs (LitAlt lit, [], mkDsLets binds body)
 367           where
 368             lit   = MachInt $ toInteger (dataConSourceArity con)
 369             binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
 370             --
 371             indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
 372 \end{code}
 373
 374
 375 %************************************************************************
 376 %*                                                                      *
 377 \subsection{Desugarer's versions of some Core functions}
 378 %*                                                                      *
 379 %************************************************************************
 380
 381 \begin{code}
 382 mkErrorAppDs :: Id              -- The error function
 383              -> Type            -- Type to which it should be applied
 384              -> String          -- The error message string to pass
 385              -> DsM CoreExpr
 386
 387 mkErrorAppDs err_id ty msg
 388   = getSrcLocDs                 `thenDs` \ src_loc ->
 389     let
 390         full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
 391         core_msg = Lit (MachStr (mkFastString (stringToUtf8 full_msg)))
 392     in
 393     returnDs (mkApps (Var err_id) [Type ty, core_msg])
 394 \end{code}
 395
 396
 397 *************************************************************
 398 %*                                                                      *
 399 \subsection{Making literals}
 400 %*                                                                      *
 401 %************************************************************************
 402
 403 \begin{code}
 404 mkCharExpr    :: Int        -> CoreExpr      -- Returns C# c :: Int
 405 mkIntExpr     :: Integer    -> CoreExpr      -- Returns I# i :: Int
 406 mkIntegerExpr :: Integer    -> DsM CoreExpr  -- Result :: Integer
 407 mkStringLit   :: String     -> DsM CoreExpr  -- Result :: String
 408 mkStringLitFS :: FastString -> DsM CoreExpr  -- Result :: String
 409
 410 mkIntExpr  i = mkConApp intDataCon  [mkIntLit i]
 411 mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]
 412
 413 mkIntegerExpr i
 414   | inIntRange i        -- Small enough, so start from an Int
 415   = returnDs (mkSmallIntegerLit i)
 416
 417 -- Special case for integral literals with a large magnitude:
 418 -- They are transformed into an expression involving only smaller
 419 -- integral literals. This improves constant folding.
 420
 421   | otherwise           -- Big, so start from a string
 422   = dsLookupGlobalId plusIntegerName            `thenDs` \ plus_id ->
 423     dsLookupGlobalId timesIntegerName   `thenDs` \ times_id ->
 424     let
 425         plus a b  = Var plus_id  `App` a `App` b
 426         times a b = Var times_id `App` a `App` b
 427
 428         -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
 429         horner :: Integer -> Integer -> CoreExpr
 430         horner b i | abs q <= 1 = if r == 0 || r == i
 431                                   then mkSmallIntegerLit i
 432                                   else mkSmallIntegerLit r `plus` mkSmallIntegerLit (i-r)
 433                    | r == 0     =                             horner b q `times` mkSmallIntegerLit b
 434                    | otherwise  = mkSmallIntegerLit r `plus` (horner b q `times` mkSmallIntegerLit b)
 435                    where
 436                      (q,r) = i `quotRem` b
 437
 438     in
 439     returnDs (horner tARGET_MAX_INT i)
 440
 441 mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i]
 442
 443 mkStringLit str = mkStringLitFS (mkFastString str)
 444
 445 mkStringLitFS str
 446   | nullFastString str
 447   = returnDs (mkNilExpr charTy)
 448
 449   | lengthFS str == 1
 450   = let
 451         the_char = mkCharExpr (headIntFS str)
 452     in
 453     returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
 454
 455   | all safeChar int_chars
 456   = dsLookupGlobalId unpackCStringName  `thenDs` \ unpack_id ->
 457     returnDs (App (Var unpack_id) (Lit (MachStr str)))
 458
 459   | otherwise
 460   = dsLookupGlobalId unpackCStringUtf8Name      `thenDs` \ unpack_id ->
 461     returnDs (App (Var unpack_id) (Lit (MachStr (mkFastString (intsToUtf8 int_chars)))))
 462
 463   where
 464     int_chars = unpackIntFS str
 465     safeChar c = c >= 1 && c <= 0xFF
 466 \end{code}
 467
 468
 469 %************************************************************************
 470 %*                                                                      *
 471 \subsection[mkSelectorBind]{Make a selector bind}
 472 %*                                                                      *
 473 %************************************************************************
 474
 475 This is used in various places to do with lazy patterns.
 476 For each binder $b$ in the pattern, we create a binding:
 477 \begin{verbatim}
 478     b = case v of pat' -> b'
 479 \end{verbatim}
 480 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
 481
 482 ToDo: making these bindings should really depend on whether there's
 483 much work to be done per binding.  If the pattern is complex, it
 484 should be de-mangled once, into a tuple (and then selected from).
 485 Otherwise the demangling can be in-line in the bindings (as here).
 486
 487 Boring!  Boring!  One error message per binder.  The above ToDo is
 488 even more helpful.  Something very similar happens for pattern-bound
 489 expressions.
 490
 491 \begin{code}
 492 mkSelectorBinds :: TypecheckedPat       -- The pattern
 493                 -> CoreExpr             -- Expression to which the pattern is bound
 494                 -> DsM [(Id,CoreExpr)]
 495
 496 mkSelectorBinds (VarPat v) val_expr
 497   = returnDs [(v, val_expr)]
 498
 499 mkSelectorBinds pat val_expr
 500   | isSingleton binders || is_simple_pat pat
 501   =     -- Given   p = e, where p binds x,y
 502         -- we are going to make
 503         --      v = p   (where v is fresh)
 504         --      x = case v of p -> x
 505         --      y = case v of p -> x
 506
 507         -- Make up 'v'
 508         -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
 509         -- This does not matter after desugaring, but there's a subtle
 510         -- issue with implicit parameters. Consider
 511         --      (x,y) = ?i
 512         -- Then, ?i is given type {?i :: Int}, a SourceType, which is opaque
 513         -- to the desugarer.  (Why opaque?  Because newtypes have to be.  Why
 514         -- does it get that type?  So that when we abstract over it we get the
 515         -- right top-level type  (?i::Int) => ...)
 516         --
 517         -- So to get the type of 'v', use the pattern not the rhs.  Often more
 518         -- efficient too.
 519     newSysLocalDs (hsPatType pat)       `thenDs` \ val_var ->
 520
 521         -- For the error message we make one error-app, to avoid duplication.
 522         -- But we need it at different types... so we use coerce for that
 523     mkErrorAppDs iRREFUT_PAT_ERROR_ID
 524                  unitTy (showSDoc (ppr pat))    `thenDs` \ err_expr ->
 525     newSysLocalDs unitTy                        `thenDs` \ err_var ->
 526     mapDs (mk_bind val_var err_var) binders     `thenDs` \ binds ->
 527     returnDs ( (val_var, val_expr) :
 528                (err_var, err_expr) :
 529                binds )
 530
 531
 532   | otherwise
 533   = mkErrorAppDs iRREFUT_PAT_ERROR_ID
 534                  tuple_ty (showSDoc (ppr pat))                  `thenDs` \ error_expr ->
 535     matchSimply val_expr PatBindRhs pat local_tuple error_expr  `thenDs` \ tuple_expr ->
 536     newSysLocalDs tuple_ty                                      `thenDs` \ tuple_var ->
 537     let
 538         mk_tup_bind binder
 539           = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
 540     in
 541     returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
 542   where
 543     binders     = collectPatBinders pat
 544     local_tuple = mkTupleExpr binders
 545     tuple_ty    = exprType local_tuple
 546
 547     mk_bind scrut_var err_var bndr_var
 548     -- (mk_bind sv err_var) generates
 549     --          bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
 550     -- Remember, pat binds bv
 551       = matchSimply (Var scrut_var) PatBindRhs pat
 552                     (Var bndr_var) error_expr                   `thenDs` \ rhs_expr ->
 553         returnDs (bndr_var, rhs_expr)
 554       where
 555         error_expr = mkCoerce (idType bndr_var) (Var err_var)
 556
 557     is_simple_pat (TuplePat ps Boxed)    = all is_triv_pat ps
 558     is_simple_pat (ConPatOut _ ps _ _ _) = all is_triv_pat (hsConArgs ps)
 559     is_simple_pat (VarPat _)             = True
 560     is_simple_pat (ParPat p)             = is_simple_pat p
 561     is_simple_pat other                  = False
 562
 563     is_triv_pat (VarPat v)  = True
 564     is_triv_pat (WildPat _) = True
 565     is_triv_pat (ParPat p)  = is_triv_pat p
 566     is_triv_pat other       = False
 567 \end{code}
 568
 569
 570 %************************************************************************
 571 %*                                                                      *
 572                 Tuples
 573 %*                                                                      *
 574 %************************************************************************
 575
 576 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.
 577
 578 * If it has only one element, it is the identity function.
 579
 580 * If there are more elements than a big tuple can have, it nests
 581   the tuples.
 582
 583 Nesting policy.  Better a 2-tuple of 10-tuples (3 objects) than
 584 a 10-tuple of 2-tuples (11 objects).  So we want the leaves to be big.
 585
 586 \begin{code}
 587 mkTupleExpr :: [Id] -> CoreExpr
 588 mkTupleExpr ids
 589   = mk_tuple_expr (chunkify (map Var ids))
 590   where
 591     mk_tuple_expr :: [[CoreExpr]] -> CoreExpr
 592         -- Each sub-list is short enough to fit in a tuple
 593     mk_tuple_expr [exprs] = mkCoreTup exprs
 594     mk_tuple_expr exprs_s = mk_tuple_expr (chunkify (map mkCoreTup exprs_s))
 595
 596
 597 chunkify :: [a] -> [[a]]
 598 -- The sub-lists of the result all have length <= mAX_TUPLE_SIZE
 599 chunkify xs
 600   | n_xs <= mAX_TUPLE_SIZE = [xs]
 601   | otherwise              = split xs
 602   where
 603         -- n_chunks_m1 = numbe of chunks - 1
 604     n_xs        = length xs
 605     n_chunks_m1 = n_xs `div` mAX_TUPLE_SIZE
 606     chunk_size  = n_xs `div` n_chunks_m1
 607
 608     split [] = []
 609     split xs = take chunk_size xs : split (drop chunk_size xs)
 610 \end{code}
 611
 612
 613 @mkTupleSelector@ builds a selector which scrutises the given
 614 expression and extracts the one name from the list given.
 615 If you want the no-shadowing rule to apply, the caller
 616 is responsible for making sure that none of these names
 617 are in scope.
 618
 619 If there is just one id in the ``tuple'', then the selector is
 620 just the identity.
 621
 622 If it's big, it does nesting
 623         mkTupleSelector [a,b,c,d] b v e
 624           = case e of v {
 625                 (p,q) -> case p of p {
 626                            (a,b) -> b }}
 627 We use 'tpl' vars for the p,q, since shadowing does not matter.
 628
 629 In fact, it's more convenient to generate it innermost first, getting
 630
 631         case (case e of v
 632                 (p,q) -> p) of p
 633           (a,b) -> b
 634
 635 \begin{code}
 636 mkTupleSelector :: [Id]         -- The tuple args
 637                 -> Id           -- The selected one
 638                 -> Id           -- A variable of the same type as the scrutinee
 639                 -> CoreExpr     -- Scrutinee
 640                 -> CoreExpr
 641
 642 mkTupleSelector vars the_var scrut_var scrut
 643   = mk_tup_sel (chunkify vars) the_var
 644   where
 645     mk_tup_sel [vars] the_var = mkCoreSel vars the_var scrut_var scrut
 646     mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $
 647                                 mk_tup_sel (chunkify tpl_vs) tpl_v
 648         where
 649           tpl_tys = [mkTupleTy Boxed (length gp) (map idType gp) | gp <- vars_s]
 650           tpl_vs  = mkTemplateLocals tpl_tys
 651           [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
 652                                          the_var `elem` gp ]
 653 \end{code}
 654
 655
 656 %************************************************************************
 657 %*                                                                      *
 658 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 659 %*                                                                      *
 660 %************************************************************************
 661
 662 Call the constructor Ids when building explicit lists, so that they
 663 interact well with rules.
 664
 665 \begin{code}
 666 mkNilExpr :: Type -> CoreExpr
 667 mkNilExpr ty = mkConApp nilDataCon [Type ty]
 668
 669 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
 670 mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
 671
 672 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
 673 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
 674
 675 mkCoreTup :: [CoreExpr] -> CoreExpr
 676 -- Builds exactly the specified tuple.
 677 -- No fancy business for big tuples
 678 mkCoreTup []  = Var unitDataConId
 679 mkCoreTup [c] = c
 680 mkCoreTup cs  = mkConApp (tupleCon Boxed (length cs))
 681                          (map (Type . exprType) cs ++ cs)
 682
 683 mkCoreSel :: [Id]       -- The tuple args
 684           -> Id         -- The selected one
 685           -> Id         -- A variable of the same type as the scrutinee
 686           -> CoreExpr   -- Scrutinee
 687           -> CoreExpr
 688 -- mkCoreSel [x,y,z] x v e
 689 -- ===>  case e of v { (x,y,z) -> x
 690 mkCoreSel [var] should_be_the_same_var scrut_var scrut
 691   = ASSERT(var == should_be_the_same_var)
 692     scrut
 693
 694 mkCoreSel vars the_var scrut_var scrut
 695   = ASSERT( notNull vars )
 696     Case scrut scrut_var
 697          [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
 698 \end{code}
 699
 700
 701 %************************************************************************
 702 %*                                                                      *
 703 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 704 %*                                                                      *
 705 %************************************************************************
 706
 707 Generally, we handle pattern matching failure like this: let-bind a
 708 fail-variable, and use that variable if the thing fails:
 709 \begin{verbatim}
 710         let fail.33 = error "Help"
 711         in
 712         case x of
 713                 p1 -> ...
 714                 p2 -> fail.33
 715                 p3 -> fail.33
 716                 p4 -> ...
 717 \end{verbatim}
 718 Then
 719 \begin{itemize}
 720 \item
 721 If the case can't fail, then there'll be no mention of @fail.33@, and the
 722 simplifier will later discard it.
 723
 724 \item
 725 If it can fail in only one way, then the simplifier will inline it.
 726
 727 \item
 728 Only if it is used more than once will the let-binding remain.
 729 \end{itemize}
 730
 731 There's a problem when the result of the case expression is of
 732 unboxed type.  Then the type of @fail.33@ is unboxed too, and
 733 there is every chance that someone will change the let into a case:
 734 \begin{verbatim}
 735         case error "Help" of
 736           fail.33 -> case ....
 737 \end{verbatim}
 738
 739 which is of course utterly wrong.  Rather than drop the condition that
 740 only boxed types can be let-bound, we just turn the fail into a function
 741 for the primitive case:
 742 \begin{verbatim}
 743         let fail.33 :: Void -> Int#
 744             fail.33 = \_ -> error "Help"
 745         in
 746         case x of
 747                 p1 -> ...
 748                 p2 -> fail.33 void
 749                 p3 -> fail.33 void
 750                 p4 -> ...
 751 \end{verbatim}
 752
 753 Now @fail.33@ is a function, so it can be let-bound.
 754
 755 \begin{code}
 756 mkFailurePair :: CoreExpr       -- Result type of the whole case expression
 757               -> DsM (CoreBind, -- Binds the newly-created fail variable
 758                                 -- to either the expression or \ _ -> expression
 759                       CoreExpr) -- Either the fail variable, or fail variable
 760                                 -- applied to unit tuple
 761 mkFailurePair expr
 762   | isUnLiftedType ty
 763   = newFailLocalDs (unitTy `mkFunTy` ty)        `thenDs` \ fail_fun_var ->
 764     newSysLocalDs unitTy                        `thenDs` \ fail_fun_arg ->
 765     returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
 766               App (Var fail_fun_var) (Var unitDataConId))
 767
 768   | otherwise
 769   = newFailLocalDs ty           `thenDs` \ fail_var ->
 770     returnDs (NonRec fail_var expr, Var fail_var)
 771   where
 772     ty = exprType expr
 773 \end{code}
 774
 775