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