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