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