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