[project @ 2002-04-05 23:24:25 by sof]
[ghc-hetmet.git] / ghc / compiler / deSugar / DsUtils.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[DsUtils]{Utilities for desugaring}
5
6 This module exports some utility functions of no great interest.
7
8 \begin{code}
9 module DsUtils (
10         CanItFail(..), EquationInfo(..), MatchResult(..),
11         EqnNo, EqnSet,
12
13         tidyLitPat, tidyNPat,
14
15         mkDsLet, mkDsLets,
16
17         cantFailMatchResult, extractMatchResult,
18         combineMatchResults, 
19         adjustMatchResult, adjustMatchResultDs,
20         mkCoLetsMatchResult, mkGuardedMatchResult, 
21         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
22
23         mkErrorAppDs, mkNilExpr, mkConsExpr,
24         mkStringLit, mkStringLitFS, mkIntegerLit, 
25
26         mkSelectorBinds, mkTupleExpr, mkTupleSelector,
27
28         selectMatchVar
29     ) where
30
31 #include "HsVersions.h"
32
33 import {-# SOURCE #-} Match ( matchSimply )
34
35 import HsSyn
36 import TcHsSyn          ( TypecheckedPat, outPatType, collectTypedPatBinders )
37 import CoreSyn
38
39 import DsMonad
40
41 import CoreUtils        ( exprType, mkIfThenElse )
42 import PrelInfo         ( iRREFUT_PAT_ERROR_ID )
43 import MkId             ( mkReboxingAlt, mkNewTypeBody )
44 import Id               ( idType, Id, mkWildId )
45 import Literal          ( Literal(..), inIntRange, tARGET_MAX_INT )
46 import TyCon            ( isNewTyCon, tyConDataCons, isRecursiveTyCon )
47 import DataCon          ( DataCon, dataConSourceArity )
48 import Type             ( mkFunTy, isUnLiftedType, Type, splitTyConApp )
49 import TcType           ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy )
50 import TysPrim          ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy )
51 import TysWiredIn       ( nilDataCon, consDataCon, 
52                           tupleCon,
53                           unitDataConId, unitTy,
54                           charTy, charDataCon, 
55                           intTy, intDataCon, smallIntegerDataCon, 
56                           floatDataCon, 
57                           doubleDataCon,
58                           stringTy, isPArrFakeCon )
59 import BasicTypes       ( Boxity(..) )
60 import UniqSet          ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
61 import PrelNames        ( unpackCStringName, unpackCStringUtf8Name, 
62                           plusIntegerName, timesIntegerName, 
63                           lengthPName, indexPName )
64 import Outputable
65 import UnicodeUtil      ( stringToUtf8 )
66 import Util             ( isSingleton, notNull )
67 \end{code}
68
69
70
71 %************************************************************************
72 %*                                                                      *
73 \subsection{Tidying lit pats}
74 %*                                                                      *
75 %************************************************************************
76
77 \begin{code}
78 tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat
79 tidyLitPat (HsChar c) pat = ConPat charDataCon   charTy [] [] [LitPat (HsCharPrim c)   charPrimTy]
80 tidyLitPat lit        pat = pat
81
82 tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat
83 tidyNPat (HsString s) _ pat
84   | _LENGTH_ s <= 1     -- Short string literals only
85   = foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
86           (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s)
87         -- The stringTy is the type of the whole pattern, not 
88         -- the type to instantiate (:) or [] with!
89   where
90     mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
91
92 tidyNPat lit lit_ty default_pat
93   | isIntTy lit_ty      = ConPat intDataCon    lit_ty [] [] [LitPat (mk_int lit)    intPrimTy]
94   | isFloatTy lit_ty    = ConPat floatDataCon  lit_ty [] [] [LitPat (mk_float lit)  floatPrimTy]
95   | isDoubleTy lit_ty   = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
96   | otherwise           = default_pat
97
98   where
99     mk_int    (HsInteger i) = HsIntPrim i
100
101     mk_float  (HsInteger i) = HsFloatPrim (fromInteger i)
102     mk_float  (HsRat f _)   = HsFloatPrim f
103
104     mk_double (HsInteger i) = HsDoublePrim (fromInteger i)
105     mk_double (HsRat f _)   = HsDoublePrim f
106 \end{code}
107
108
109 %************************************************************************
110 %*                                                                      *
111 \subsection{Building lets}
112 %*                                                                      *
113 %************************************************************************
114
115 Use case, not let for unlifted types.  The simplifier will turn some
116 back again.
117
118 \begin{code}
119 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
120 mkDsLet (NonRec bndr rhs) body
121   | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
122 mkDsLet bind body
123   = Let bind body
124
125 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
126 mkDsLets binds body = foldr mkDsLet body binds
127 \end{code}
128
129
130 %************************************************************************
131 %*                                                                      *
132 \subsection{ Selecting match variables}
133 %*                                                                      *
134 %************************************************************************
135
136 We're about to match against some patterns.  We want to make some
137 @Ids@ to use as match variables.  If a pattern has an @Id@ readily at
138 hand, which should indeed be bound to the pattern as a whole, then use it;
139 otherwise, make one up.
140
141 \begin{code}
142 selectMatchVar :: TypecheckedPat -> DsM Id
143 selectMatchVar (VarPat var)     = returnDs var
144 selectMatchVar (AsPat var pat)  = returnDs var
145 selectMatchVar (LazyPat pat)    = selectMatchVar pat
146 selectMatchVar other_pat        = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
147 \end{code}
148
149
150 %************************************************************************
151 %*                                                                      *
152 %* type synonym EquationInfo and access functions for its pieces        *
153 %*                                                                      *
154 %************************************************************************
155 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
156
157 The ``equation info'' used by @match@ is relatively complicated and
158 worthy of a type synonym and a few handy functions.
159
160 \begin{code}
161
162 type EqnNo   = Int
163 type EqnSet  = UniqSet EqnNo
164
165 data EquationInfo
166   = EqnInfo
167         EqnNo           -- The number of the equation
168
169         DsMatchContext  -- The context info is used when producing warnings
170                         -- about shadowed patterns.  It's the context
171                         -- of the *first* thing matched in this group.
172                         -- Should perhaps be a list of them all!
173
174         [TypecheckedPat]    -- The patterns for an eqn
175
176         MatchResult         -- Encapsulates the guards and bindings
177 \end{code}
178
179 \begin{code}
180 data MatchResult
181   = MatchResult
182         CanItFail       -- Tells whether the failure expression is used
183         (CoreExpr -> DsM CoreExpr)
184                         -- Takes a expression to plug in at the
185                         -- failure point(s). The expression should
186                         -- be duplicatable!
187
188 data CanItFail = CanFail | CantFail
189
190 orFail CantFail CantFail = CantFail
191 orFail _        _        = CanFail
192 \end{code}
193
194 Functions on MatchResults
195
196 \begin{code}
197 cantFailMatchResult :: CoreExpr -> MatchResult
198 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
199
200 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
201 extractMatchResult (MatchResult CantFail match_fn) fail_expr
202   = match_fn (error "It can't fail!")
203
204 extractMatchResult (MatchResult CanFail match_fn) fail_expr
205   = mkFailurePair fail_expr             `thenDs` \ (fail_bind, if_it_fails) ->
206     match_fn if_it_fails                `thenDs` \ body ->
207     returnDs (mkDsLet fail_bind body)
208
209
210 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
211 combineMatchResults (MatchResult CanFail      body_fn1)
212                     (MatchResult can_it_fail2 body_fn2)
213   = MatchResult can_it_fail2 body_fn
214   where
215     body_fn fail = body_fn2 fail                        `thenDs` \ body2 ->
216                    mkFailurePair body2                  `thenDs` \ (fail_bind, duplicatable_expr) ->
217                    body_fn1 duplicatable_expr           `thenDs` \ body1 ->
218                    returnDs (Let fail_bind body1)
219
220 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
221   = match_result1
222
223
224 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
225 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
226   = MatchResult can_it_fail (\fail -> body_fn fail      `thenDs` \ body ->
227                                       returnDs (encl_fn body))
228
229 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
230 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
231   = MatchResult can_it_fail (\fail -> body_fn fail      `thenDs` \ body ->
232                                       encl_fn body)
233
234
235 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
236 mkCoLetsMatchResult binds match_result
237   = adjustMatchResult (mkDsLets binds) match_result
238
239
240 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
241 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
242   = MatchResult CanFail (\fail -> body_fn fail  `thenDs` \ body ->
243                                   returnDs (mkIfThenElse pred_expr body fail))
244
245 mkCoPrimCaseMatchResult :: Id                           -- Scrutinee
246                     -> [(Literal, MatchResult)]         -- Alternatives
247                     -> MatchResult
248 mkCoPrimCaseMatchResult var match_alts
249   = MatchResult CanFail mk_case
250   where
251     mk_case fail
252       = mapDs (mk_alt fail) match_alts          `thenDs` \ alts ->
253         returnDs (Case (Var var) var ((DEFAULT, [], fail) : alts))
254
255     mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail     `thenDs` \ body ->
256                                                returnDs (LitAlt lit, [], body)
257
258
259 mkCoAlgCaseMatchResult :: Id                                    -- Scrutinee
260                     -> [(DataCon, [CoreBndr], MatchResult)]     -- Alternatives
261                     -> MatchResult
262
263 mkCoAlgCaseMatchResult var match_alts
264   | isNewTyCon tycon            -- Newtype case; use a let
265   = ASSERT( null (tail match_alts) && null (tail arg_ids) )
266     mkCoLetsMatchResult [NonRec arg_id newtype_rhs] match_result
267
268   | isPArrFakeAlts match_alts   -- Sugared parallel array; use a literal case 
269   = MatchResult CanFail mk_parrCase
270
271   | otherwise                   -- Datatype case; use a case
272   = MatchResult fail_flag mk_case
273   where
274         -- Common stuff
275     scrut_ty = idType var
276     tycon    = tcTyConAppTyCon scrut_ty         -- Newtypes must be opaque here
277
278         -- Stuff for newtype
279     (_, arg_ids, match_result) = head match_alts
280     arg_id                     = head arg_ids
281     newtype_rhs                = mkNewTypeBody tycon (idType arg_id) (Var var)
282                 
283         -- Stuff for data types
284     data_cons      = tyConDataCons tycon
285     match_results  = [match_result | (_,_,match_result) <- match_alts]
286
287     fail_flag | exhaustive_case
288               = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
289               | otherwise
290               = CanFail
291
292     wild_var = mkWildId (idType var)
293     mk_case fail = mapDs (mk_alt fail) match_alts       `thenDs` \ alts ->
294                    returnDs (Case (Var var) wild_var (mk_default fail ++ alts))
295
296     mk_alt fail (con, args, MatchResult _ body_fn)
297         = body_fn fail                          `thenDs` \ body ->
298           getUniquesDs                          `thenDs` \ us ->
299           returnDs (mkReboxingAlt us con args body)
300
301     mk_default fail | exhaustive_case = []
302                     | otherwise       = [(DEFAULT, [], fail)]
303
304     un_mentioned_constructors
305         = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
306     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
307
308         -- Stuff for parallel arrays
309         -- 
310         -- * the following is to desugar cases over fake constructors for
311         --   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
312         --   case
313         --
314         -- Concerning `isPArrFakeAlts':
315         --
316         -- * it is *not* sufficient to just check the type of the type
317         --   constructor, as we have to be careful not to confuse the real
318         --   representation of parallel arrays with the fake constructors;
319         --   moreover, a list of alternatives must not mix fake and real
320         --   constructors (this is checked earlier on)
321         --
322         -- FIXME: We actually go through the whole list and make sure that
323         --        either all or none of the constructors are fake parallel
324         --        array constructors.  This is to spot equations that mix fake
325         --        constructors with the real representation defined in
326         --        `PrelPArr'.  It would be nicer to spot this situation
327         --        earlier and raise a proper error message, but it can really
328         --        only happen in `PrelPArr' anyway.
329         --
330     isPArrFakeAlts [(dcon, _, _)]      = isPArrFakeCon dcon
331     isPArrFakeAlts ((dcon, _, _):alts) = 
332       case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
333         (True , True ) -> True
334         (False, False) -> False
335         _              -> 
336           panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
337     --
338     mk_parrCase fail =             
339       dsLookupGlobalValue lengthPName                   `thenDs` \lengthP  ->
340       unboxAlt                                          `thenDs` \alt      ->
341       returnDs (Case (len lengthP) (mkWildId intTy) [alt])
342       where
343         elemTy      = case splitTyConApp (idType var) of
344                         (_, [elemTy]) -> elemTy
345                         _               -> panic panicMsg
346         panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
347         len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
348         --
349         unboxAlt = 
350           newSysLocalDs intPrimTy                       `thenDs` \l        ->
351           dsLookupGlobalValue indexPName                `thenDs` \indexP   ->
352           mapDs (mkAlt indexP) match_alts               `thenDs` \alts     ->
353           returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts)))
354           where
355             wild = mkWildId intPrimTy
356             dft  = (DEFAULT, [], fail)
357         --
358         -- each alternative matches one array length (corresponding to one
359         -- fake array constructor), so the match is on a literal; each
360         -- alternative's body is extended by a local binding for each
361         -- constructor argument, which are bound to array elements starting
362         -- with the first
363         --
364         mkAlt indexP (con, args, MatchResult _ bodyFun) = 
365           bodyFun fail                                  `thenDs` \body     ->
366           returnDs (LitAlt lit, [], mkDsLets binds body)
367           where
368             lit   = MachInt $ toInteger (dataConSourceArity con)
369             binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
370             --
371             indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, toInt i]
372             toInt     i = mkConApp intDataCon [Lit $ MachInt i]
373 \end{code}
374
375
376 %************************************************************************
377 %*                                                                      *
378 \subsection{Desugarer's versions of some Core functions}
379 %*                                                                      *
380 %************************************************************************
381
382 \begin{code}
383 mkErrorAppDs :: Id              -- The error function
384              -> Type            -- Type to which it should be applied
385              -> String          -- The error message string to pass
386              -> DsM CoreExpr
387
388 mkErrorAppDs err_id ty msg
389   = getSrcLocDs                 `thenDs` \ src_loc ->
390     let
391         full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
392     in
393     mkStringLit full_msg                `thenDs` \ core_msg ->
394     returnDs (mkApps (Var err_id) [Type ty, core_msg])
395 \end{code}
396
397
398 *************************************************************
399 %*                                                                      *
400 \subsection{Making literals}
401 %*                                                                      *
402 %************************************************************************
403
404 \begin{code}
405 mkIntegerLit :: Integer -> DsM CoreExpr
406 mkIntegerLit i
407   | inIntRange i        -- Small enough, so start from an Int
408   = returnDs (mkSmallIntegerLit i)
409
410 -- Special case for integral literals with a large magnitude:
411 -- They are transformed into an expression involving only smaller
412 -- integral literals. This improves constant folding.
413
414   | otherwise           -- Big, so start from a string
415   = dsLookupGlobalValue plusIntegerName         `thenDs` \ plus_id ->
416     dsLookupGlobalValue timesIntegerName        `thenDs` \ times_id ->
417     let 
418         plus a b  = Var plus_id  `App` a `App` b
419         times a b = Var times_id `App` a `App` b
420
421         -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
422         horner :: Integer -> Integer -> CoreExpr
423         horner b i | abs q <= 1 = if r == 0 || r == i 
424                                   then mkSmallIntegerLit i 
425                                   else mkSmallIntegerLit r `plus` mkSmallIntegerLit (i-r)
426                    | r == 0     =                             horner b q `times` mkSmallIntegerLit b
427                    | otherwise  = mkSmallIntegerLit r `plus` (horner b q `times` mkSmallIntegerLit b)
428                    where
429                      (q,r) = i `quotRem` b
430
431     in
432     returnDs (horner tARGET_MAX_INT i)
433
434 mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i]
435
436 mkStringLit   :: String       -> DsM CoreExpr
437 mkStringLit str = mkStringLitFS (_PK_ str)
438
439 mkStringLitFS :: FAST_STRING  -> DsM CoreExpr
440 mkStringLitFS str
441   | _NULL_ str
442   = returnDs (mkNilExpr charTy)
443
444   | _LENGTH_ str == 1
445   = let
446         the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_INT_ str))]
447     in
448     returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
449
450   | all safeChar chars
451   = dsLookupGlobalValue unpackCStringName       `thenDs` \ unpack_id ->
452     returnDs (App (Var unpack_id) (Lit (MachStr str)))
453
454   | otherwise
455   = dsLookupGlobalValue unpackCStringUtf8Name   `thenDs` \ unpack_id ->
456     returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
457
458   where
459     chars = _UNPK_INT_ str
460     safeChar c = c >= 1 && c <= 0xFF
461 \end{code}
462
463
464 %************************************************************************
465 %*                                                                      *
466 \subsection[mkSelectorBind]{Make a selector bind}
467 %*                                                                      *
468 %************************************************************************
469
470 This is used in various places to do with lazy patterns.
471 For each binder $b$ in the pattern, we create a binding:
472 \begin{verbatim}
473     b = case v of pat' -> b'
474 \end{verbatim}
475 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
476
477 ToDo: making these bindings should really depend on whether there's
478 much work to be done per binding.  If the pattern is complex, it
479 should be de-mangled once, into a tuple (and then selected from).
480 Otherwise the demangling can be in-line in the bindings (as here).
481
482 Boring!  Boring!  One error message per binder.  The above ToDo is
483 even more helpful.  Something very similar happens for pattern-bound
484 expressions.
485
486 \begin{code}
487 mkSelectorBinds :: TypecheckedPat       -- The pattern
488                 -> CoreExpr             -- Expression to which the pattern is bound
489                 -> DsM [(Id,CoreExpr)]
490
491 mkSelectorBinds (VarPat v) val_expr
492   = returnDs [(v, val_expr)]
493
494 mkSelectorBinds pat val_expr
495   | isSingleton binders || is_simple_pat pat
496   = newSysLocalDs (exprType val_expr)   `thenDs` \ val_var ->
497
498         -- For the error message we don't use mkErrorAppDs to avoid
499         -- duplicating the string literal each time
500     newSysLocalDs stringTy                      `thenDs` \ msg_var ->
501     getSrcLocDs                                 `thenDs` \ src_loc ->
502     let
503         full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
504     in
505     mkStringLit full_msg                        `thenDs` \ core_msg -> 
506     mapDs (mk_bind val_var msg_var) binders     `thenDs` \ binds ->
507     returnDs ( (val_var, val_expr) : 
508                (msg_var, core_msg) :
509                binds )
510
511
512   | otherwise
513   = mkErrorAppDs iRREFUT_PAT_ERROR_ID 
514                  tuple_ty (showSDoc (ppr pat))                  `thenDs` \ error_expr ->
515     matchSimply val_expr PatBindRhs pat local_tuple error_expr  `thenDs` \ tuple_expr ->
516     newSysLocalDs tuple_ty                                      `thenDs` \ tuple_var ->
517     let
518         mk_tup_bind binder
519           = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
520     in
521     returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
522   where
523     binders     = collectTypedPatBinders pat
524     local_tuple = mkTupleExpr binders
525     tuple_ty    = exprType local_tuple
526
527     mk_bind scrut_var msg_var bndr_var
528     -- (mk_bind sv bv) generates
529     --          bv = case sv of { pat -> bv; other -> error-msg }
530     -- Remember, pat binds bv
531       = matchSimply (Var scrut_var) PatBindRhs pat
532                     (Var bndr_var) error_expr                   `thenDs` \ rhs_expr ->
533         returnDs (bndr_var, rhs_expr)
534       where
535         binder_ty = idType bndr_var
536         error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
537
538     is_simple_pat (TuplePat ps Boxed)  = all is_triv_pat ps
539     is_simple_pat (ConPat _ _ _ _ ps)  = all is_triv_pat ps
540     is_simple_pat (VarPat _)           = True
541     is_simple_pat (RecPat _ _ _ _ ps)  = and [is_triv_pat p | (_,p,_) <- ps]
542     is_simple_pat other                = False
543
544     is_triv_pat (VarPat v)  = True
545     is_triv_pat (WildPat _) = True
546     is_triv_pat other       = False
547 \end{code}
548
549
550 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  If it
551 has only one element, it is the identity function.
552
553 \begin{code}
554 mkTupleExpr :: [Id] -> CoreExpr
555
556 mkTupleExpr []   = Var unitDataConId
557 mkTupleExpr [id] = Var id
558 mkTupleExpr ids  = mkConApp (tupleCon Boxed (length ids))
559                             (map (Type . idType) ids ++ [ Var i | i <- ids ])
560 \end{code}
561
562
563 @mkTupleSelector@ builds a selector which scrutises the given
564 expression and extracts the one name from the list given.
565 If you want the no-shadowing rule to apply, the caller
566 is responsible for making sure that none of these names
567 are in scope.
568
569 If there is just one id in the ``tuple'', then the selector is
570 just the identity.
571
572 \begin{code}
573 mkTupleSelector :: [Id]         -- The tuple args
574                 -> Id           -- The selected one
575                 -> Id           -- A variable of the same type as the scrutinee
576                 -> CoreExpr     -- Scrutinee
577                 -> CoreExpr
578
579 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
580   = ASSERT(var == should_be_the_same_var)
581     scrut
582
583 mkTupleSelector vars the_var scrut_var scrut
584   = ASSERT( notNull vars )
585     Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
586 \end{code}
587
588
589 %************************************************************************
590 %*                                                                      *
591 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
592 %*                                                                      *
593 %************************************************************************
594
595 Call the constructor Ids when building explicit lists, so that they
596 interact well with rules.
597
598 \begin{code}
599 mkNilExpr :: Type -> CoreExpr
600 mkNilExpr ty = mkConApp nilDataCon [Type ty]
601
602 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
603 mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
604 \end{code}
605
606
607 %************************************************************************
608 %*                                                                      *
609 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
610 %*                                                                      *
611 %************************************************************************
612
613 Generally, we handle pattern matching failure like this: let-bind a
614 fail-variable, and use that variable if the thing fails:
615 \begin{verbatim}
616         let fail.33 = error "Help"
617         in
618         case x of
619                 p1 -> ...
620                 p2 -> fail.33
621                 p3 -> fail.33
622                 p4 -> ...
623 \end{verbatim}
624 Then
625 \begin{itemize}
626 \item
627 If the case can't fail, then there'll be no mention of @fail.33@, and the
628 simplifier will later discard it.
629
630 \item
631 If it can fail in only one way, then the simplifier will inline it.
632
633 \item
634 Only if it is used more than once will the let-binding remain.
635 \end{itemize}
636
637 There's a problem when the result of the case expression is of
638 unboxed type.  Then the type of @fail.33@ is unboxed too, and
639 there is every chance that someone will change the let into a case:
640 \begin{verbatim}
641         case error "Help" of
642           fail.33 -> case ....
643 \end{verbatim}
644
645 which is of course utterly wrong.  Rather than drop the condition that
646 only boxed types can be let-bound, we just turn the fail into a function
647 for the primitive case:
648 \begin{verbatim}
649         let fail.33 :: Void -> Int#
650             fail.33 = \_ -> error "Help"
651         in
652         case x of
653                 p1 -> ...
654                 p2 -> fail.33 void
655                 p3 -> fail.33 void
656                 p4 -> ...
657 \end{verbatim}
658
659 Now @fail.33@ is a function, so it can be let-bound.
660
661 \begin{code}
662 mkFailurePair :: CoreExpr       -- Result type of the whole case expression
663               -> DsM (CoreBind, -- Binds the newly-created fail variable
664                                 -- to either the expression or \ _ -> expression
665                       CoreExpr) -- Either the fail variable, or fail variable
666                                 -- applied to unit tuple
667 mkFailurePair expr
668   | isUnLiftedType ty
669   = newFailLocalDs (unitTy `mkFunTy` ty)        `thenDs` \ fail_fun_var ->
670     newSysLocalDs unitTy                        `thenDs` \ fail_fun_arg ->
671     returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
672               App (Var fail_fun_var) (Var unitDataConId))
673
674   | otherwise
675   = newFailLocalDs ty           `thenDs` \ fail_var ->
676     returnDs (NonRec fail_var expr, Var fail_var)
677   where
678     ty = exprType expr
679 \end{code}
680
681