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