Merge ../HEAD
[ghc.git] / compiler / deSugar / DsUtils.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 Utilities for desugaring
7
8 This module exports some utility functions of no great interest.
9
10 \begin{code}
11 {-# OPTIONS -fno-warn-tabs #-}
12 -- The above warning supression flag is a temporary kludge.
13 -- While working on this module you are encouraged to remove it and
14 -- detab the module (please do the detabbing in a separate patch). See
15 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
16 -- for details
17
18 -- | Utility functions for constructing Core syntax, principally for desugaring
19 module DsUtils (
20         EquationInfo(..), 
21         firstPat, shiftEqns,
22
23         MatchResult(..), CanItFail(..), 
24         cantFailMatchResult, alwaysFailMatchResult,
25         extractMatchResult, combineMatchResults, 
26         adjustMatchResult,  adjustMatchResultDs,
27         mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, 
28         matchCanFail, mkEvalMatchResult,
29         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
30         wrapBind, wrapBinds,
31
32         mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs,
33
34         seqVar,
35
36         -- LHs tuples
37         mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
38         mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
39
40         mkSelectorBinds,
41
42         dsSyntaxTable, lookupEvidence,
43
44         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
45         mkOptTickBox, mkBinaryTickBox
46     ) where
47
48 #include "HsVersions.h"
49
50 import {-# SOURCE #-}   Match ( matchSimply )
51 import {-# SOURCE #-}   DsExpr( dsExpr )
52
53 import HsSyn
54 import TcHsSyn
55 import TcType( tcSplitTyConApp )
56 import CoreSyn
57 import DsMonad
58
59 import CoreUtils
60 import MkCore
61 import MkId
62 import Id
63 import Name
64 import Literal
65 import TyCon
66 import DataCon
67 import Type
68 import Coercion
69 import TysPrim
70 import TysWiredIn
71 import BasicTypes
72 import UniqSet
73 import UniqSupply
74 import PrelNames
75 import Outputable
76 import SrcLoc
77 import Util
78 import ListSetOps
79 import DynFlags
80 import FastString
81
82 import Control.Monad    ( zipWithM )
83 \end{code}
84
85
86 %************************************************************************
87 %*                                                                      *
88                 Rebindable syntax
89 %*                                                                      *
90 %************************************************************************
91
92 \begin{code}
93 dsSyntaxTable :: SyntaxTable Id 
94                -> DsM ([CoreBind],      -- Auxiliary bindings
95                        [(Name,Id)])     -- Maps the standard name to its value
96
97 dsSyntaxTable rebound_ids = do
98     (binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids
99     return (concat binds_s, prs)
100   where
101         -- The cheapo special case can happen when we 
102         -- make an intermediate HsDo when desugaring a RecStmt
103     mk_bind (std_name, HsVar id) = return ([], (std_name, id))
104     mk_bind (std_name, expr) = do
105            rhs <- dsExpr expr
106            id <- newSysLocalDs (exprType rhs)
107            return ([NonRec id rhs], (std_name, id))
108
109 lookupEvidence :: [(Name, Id)] -> Name -> Id
110 lookupEvidence prs std_name
111   = assocDefault (mk_panic std_name) prs std_name
112   where
113     mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name)
114 \end{code}
115
116 %************************************************************************
117 %*                                                                      *
118 \subsection{ Selecting match variables}
119 %*                                                                      *
120 %************************************************************************
121
122 We're about to match against some patterns.  We want to make some
123 @Ids@ to use as match variables.  If a pattern has an @Id@ readily at
124 hand, which should indeed be bound to the pattern as a whole, then use it;
125 otherwise, make one up.
126
127 \begin{code}
128 selectSimpleMatchVarL :: LPat Id -> DsM Id
129 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
130
131 -- (selectMatchVars ps tys) chooses variables of type tys
132 -- to use for matching ps against.  If the pattern is a variable,
133 -- we try to use that, to save inventing lots of fresh variables.
134 --
135 -- OLD, but interesting note:
136 --    But even if it is a variable, its type might not match.  Consider
137 --      data T a where
138 --        T1 :: Int -> T Int
139 --        T2 :: a   -> T a
140 --
141 --      f :: T a -> a -> Int
142 --      f (T1 i) (x::Int) = x
143 --      f (T2 i) (y::a)   = 0
144 --    Then we must not choose (x::Int) as the matching variable!
145 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
146
147 selectMatchVars :: [Pat Id] -> DsM [Id]
148 selectMatchVars ps = mapM selectMatchVar ps
149
150 selectMatchVar :: Pat Id -> DsM Id
151 selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
152 selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
153 selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)
154 selectMatchVar (VarPat var)  = return (localiseId var)  -- Note [Localise pattern binders]
155 selectMatchVar (AsPat var _) = return (unLoc var)
156 selectMatchVar other_pat     = newSysLocalDs (hsPatType other_pat)
157                                   -- OK, better make up one...
158 \end{code}
159
160 Note [Localise pattern binders]
161 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
162 Consider     module M where
163                [Just a] = e
164 After renaming it looks like
165              module M where
166                [Just M.a] = e
167
168 We don't generalise, since it's a pattern binding, monomorphic, etc,
169 so after desugaring we may get something like
170              M.a = case e of (v:_) ->
171                    case v of Just M.a -> M.a
172 Notice the "M.a" in the pattern; after all, it was in the original
173 pattern.  However, after optimisation those pattern binders can become
174 let-binders, and then end up floated to top level.  They have a
175 different *unique* by then (the simplifier is good about maintaining
176 proper scoping), but it's BAD to have two top-level bindings with the
177 External Name M.a, because that turns into two linker symbols for M.a.
178 It's quite rare for this to actually *happen* -- the only case I know
179 of is tc003 compiled with the 'hpc' way -- but that only makes it 
180 all the more annoying.
181
182 To avoid this, we craftily call 'localiseId' in the desugarer, which
183 simply turns the External Name for the Id into an Internal one, but
184 doesn't change the unique.  So the desugarer produces this:
185              M.a{r8} = case e of (v:_) ->
186                        case v of Just a{r8} -> M.a{r8}
187 The unique is still 'r8', but the binding site in the pattern
188 is now an Internal Name.  Now the simplifier's usual mechanisms
189 will propagate that Name to all the occurrence sites, as well as
190 un-shadowing it, so we'll get
191              M.a{r8} = case e of (v:_) ->
192                        case v of Just a{s77} -> a{s77}
193 In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
194 runs on the output of the desugarer, so all is well by the end of
195 the desugaring pass.
196
197
198 %************************************************************************
199 %*                                                                      *
200 %* type synonym EquationInfo and access functions for its pieces        *
201 %*                                                                      *
202 %************************************************************************
203 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
204
205 The ``equation info'' used by @match@ is relatively complicated and
206 worthy of a type synonym and a few handy functions.
207
208 \begin{code}
209 firstPat :: EquationInfo -> Pat Id
210 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
211
212 shiftEqns :: [EquationInfo] -> [EquationInfo]
213 -- Drop the first pattern in each equation
214 shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
215 \end{code}
216
217 Functions on MatchResults
218
219 \begin{code}
220 matchCanFail :: MatchResult -> Bool
221 matchCanFail (MatchResult CanFail _)  = True
222 matchCanFail (MatchResult CantFail _) = False
223
224 alwaysFailMatchResult :: MatchResult
225 alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
226
227 cantFailMatchResult :: CoreExpr -> MatchResult
228 cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
229
230 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
231 extractMatchResult (MatchResult CantFail match_fn) _
232   = match_fn (error "It can't fail!")
233
234 extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
235     (fail_bind, if_it_fails) <- mkFailurePair fail_expr
236     body <- match_fn if_it_fails
237     return (mkCoreLet fail_bind body)
238
239
240 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
241 combineMatchResults (MatchResult CanFail      body_fn1)
242                     (MatchResult can_it_fail2 body_fn2)
243   = MatchResult can_it_fail2 body_fn
244   where
245     body_fn fail = do body2 <- body_fn2 fail
246                       (fail_bind, duplicatable_expr) <- mkFailurePair body2
247                       body1 <- body_fn1 duplicatable_expr
248                       return (Let fail_bind body1)
249
250 combineMatchResults match_result1@(MatchResult CantFail _) _
251   = match_result1
252
253 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
254 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
255   = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
256
257 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
258 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
259   = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
260
261 wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
262 wrapBinds [] e = e
263 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
264
265 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
266 wrapBind new old body   -- NB: this function must deal with term
267   | new==old    = body  -- variables, type variables or coercion variables
268   | otherwise   = Let (NonRec new (varToCoreExpr old)) body
269
270 seqVar :: Var -> CoreExpr -> CoreExpr
271 seqVar var body = Case (Var var) var (exprType body)
272                         [(DEFAULT, [], body)]
273
274 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
275 mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
276
277 -- (mkViewMatchResult var' viewExpr var mr) makes the expression
278 -- let var' = viewExpr var in mr
279 mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
280 mkViewMatchResult var' viewExpr var = 
281     adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))
282
283 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
284 mkEvalMatchResult var ty
285   = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) 
286
287 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
288 mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
289   = MatchResult CanFail (\fail -> do body <- body_fn fail
290                                      return (mkIfThenElse pred_expr body fail))
291
292 mkCoPrimCaseMatchResult :: Id                           -- Scrutinee
293                     -> Type                             -- Type of the case
294                     -> [(Literal, MatchResult)]         -- Alternatives
295                     -> MatchResult                      -- Literals are all unlifted
296 mkCoPrimCaseMatchResult var ty match_alts
297   = MatchResult CanFail mk_case
298   where
299     mk_case fail = do
300         alts <- mapM (mk_alt fail) sorted_alts
301         return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
302
303     sorted_alts = sortWith fst match_alts       -- Right order for a Case
304     mk_alt fail (lit, MatchResult _ body_fn)
305        = ASSERT( not (litIsLifted lit) )
306          do body <- body_fn fail
307             return (LitAlt lit, [], body)
308
309
310 mkCoAlgCaseMatchResult 
311   :: Id                                    -- Scrutinee
312   -> Type                                  -- Type of exp
313   -> [(DataCon, [CoreBndr], MatchResult)]  -- Alternatives (bndrs *include* tyvars, dicts)
314   -> MatchResult
315 mkCoAlgCaseMatchResult var ty match_alts 
316   | isNewTyCon tycon            -- Newtype case; use a let
317   = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
318     mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
319
320   | isPArrFakeAlts match_alts   -- Sugared parallel array; use a literal case 
321   = MatchResult CanFail mk_parrCase
322
323   | otherwise                   -- Datatype case; use a case
324   = MatchResult fail_flag mk_case
325   where
326     tycon = dataConTyCon con1
327         -- [Interesting: becuase of GADTs, we can't rely on the type of 
328         --  the scrutinised Id to be sufficiently refined to have a TyCon in it]
329
330         -- Stuff for newtype
331     (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
332     arg_id1     = ASSERT( notNull arg_ids1 ) head arg_ids1
333     var_ty      = idType var
334     (tc, ty_args) = tcSplitTyConApp var_ty      -- Don't look through newtypes
335                                                 -- (not that splitTyConApp does, these days)
336     newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
337                 
338         -- Stuff for data types
339     data_cons      = tyConDataCons tycon
340     match_results  = [match_result | (_,_,match_result) <- match_alts]
341
342     fail_flag | exhaustive_case
343               = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
344               | otherwise
345               = CanFail
346
347     sorted_alts  = sortWith get_tag match_alts
348     get_tag (con, _, _) = dataConTag con
349     mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
350                       return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
351
352     mk_alt fail (con, args, MatchResult _ body_fn) = do
353           body <- body_fn fail
354           us <- newUniqueSupply
355           return (mkReboxingAlt (uniqsFromSupply us) con args body)
356
357     mk_default fail | exhaustive_case = []
358                     | otherwise       = [(DEFAULT, [], fail)]
359
360     un_mentioned_constructors
361         = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
362     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
363
364         -- Stuff for parallel arrays
365         -- 
366         --  * the following is to desugar cases over fake constructors for
367         --   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
368         --   case
369         --
370         -- Concerning `isPArrFakeAlts':
371         --
372         --  * it is *not* sufficient to just check the type of the type
373         --   constructor, as we have to be careful not to confuse the real
374         --   representation of parallel arrays with the fake constructors;
375         --   moreover, a list of alternatives must not mix fake and real
376         --   constructors (this is checked earlier on)
377         --
378         -- FIXME: We actually go through the whole list and make sure that
379         --        either all or none of the constructors are fake parallel
380         --        array constructors.  This is to spot equations that mix fake
381         --        constructors with the real representation defined in
382         --        `PrelPArr'.  It would be nicer to spot this situation
383         --        earlier and raise a proper error message, but it can really
384         --        only happen in `PrelPArr' anyway.
385         --
386     isPArrFakeAlts [(dcon, _, _)]      = isPArrFakeCon dcon
387     isPArrFakeAlts ((dcon, _, _):alts) = 
388       case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
389         (True , True ) -> True
390         (False, False) -> False
391         _              -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
392     isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
393     --
394     mk_parrCase fail = do
395       lengthP <- dsDPHBuiltin lengthPVar
396       alt <- unboxAlt
397       return (mkWildCase (len lengthP) intTy ty [alt])
398       where
399         elemTy      = case splitTyConApp (idType var) of
400                         (_, [elemTy]) -> elemTy
401                         _               -> panic panicMsg
402         panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
403         len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
404         --
405         unboxAlt = do
406           l      <- newSysLocalDs intPrimTy
407           indexP <- dsDPHBuiltin indexPVar
408           alts   <- mapM (mkAlt indexP) sorted_alts
409           return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
410           where
411             dft  = (DEFAULT, [], fail)
412         --
413         -- each alternative matches one array length (corresponding to one
414         -- fake array constructor), so the match is on a literal; each
415         -- alternative's body is extended by a local binding for each
416         -- constructor argument, which are bound to array elements starting
417         -- with the first
418         --
419         mkAlt indexP (con, args, MatchResult _ bodyFun) = do
420           body <- bodyFun fail
421           return (LitAlt lit, [], mkCoreLets binds body)
422           where
423             lit   = MachInt $ toInteger (dataConSourceArity con)
424             binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
425             --
426             indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
427 \end{code}
428
429 %************************************************************************
430 %*                                                                      *
431 \subsection{Desugarer's versions of some Core functions}
432 %*                                                                      *
433 %************************************************************************
434
435 \begin{code}
436 mkErrorAppDs :: Id              -- The error function
437              -> Type            -- Type to which it should be applied
438              -> SDoc            -- The error message string to pass
439              -> DsM CoreExpr
440
441 mkErrorAppDs err_id ty msg = do
442     src_loc <- getSrcSpanDs
443     dflags <- getDynFlags
444     let
445         full_msg = showSDoc dflags (hcat [ppr src_loc, text "|", msg])
446         core_msg = Lit (mkMachString full_msg)
447         -- mkMachString returns a result of type String#
448     return (mkApps (Var err_id) [Type ty, core_msg])
449 \end{code}
450
451 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
452
453 Note [Desugaring seq (1)]  cf Trac #1031
454 ~~~~~~~~~~~~~~~~~~~~~~~~~
455    f x y = x `seq` (y `seq` (# x,y #))
456
457 The [CoreSyn let/app invariant] means that, other things being equal, because 
458 the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
459
460    f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
461
462 But that is bad for two reasons: 
463   (a) we now evaluate y before x, and 
464   (b) we can't bind v to an unboxed pair
465
466 Seq is very, very special!  So we recognise it right here, and desugar to
467         case x of _ -> case y of _ -> (# x,y #)
468
469 Note [Desugaring seq (2)]  cf Trac #2273
470 ~~~~~~~~~~~~~~~~~~~~~~~~~
471 Consider
472    let chp = case b of { True -> fst x; False -> 0 }
473    in chp `seq` ...chp...
474 Here the seq is designed to plug the space leak of retaining (snd x)
475 for too long.
476
477 If we rely on the ordinary inlining of seq, we'll get
478    let chp = case b of { True -> fst x; False -> 0 }
479    case chp of _ { I# -> ...chp... }
480
481 But since chp is cheap, and the case is an alluring contet, we'll
482 inline chp into the case scrutinee.  Now there is only one use of chp,
483 so we'll inline a second copy.  Alas, we've now ruined the purpose of
484 the seq, by re-introducing the space leak:
485     case (case b of {True -> fst x; False -> 0}) of
486       I# _ -> ...case b of {True -> fst x; False -> 0}...
487
488 We can try to avoid doing this by ensuring that the binder-swap in the
489 case happens, so we get his at an early stage:
490    case chp of chp2 { I# -> ...chp2... }
491 But this is fragile.  The real culprit is the source program.  Perhaps we
492 should have said explicitly
493    let !chp2 = chp in ...chp2...
494
495 But that's painful.  So the code here does a little hack to make seq
496 more robust: a saturated application of 'seq' is turned *directly* into
497 the case expression, thus:
498    x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!
499    e1 `seq` e2 ==> case x of _ -> e2
500
501 So we desugar our example to:
502    let chp = case b of { True -> fst x; False -> 0 }
503    case chp of chp { I# -> ...chp... }
504 And now all is well.
505
506 The reason it's a hack is because if you define mySeq=seq, the hack
507 won't work on mySeq.  
508
509 Note [Desugaring seq (3)] cf Trac #2409
510 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
511 The isLocalId ensures that we don't turn 
512         True `seq` e
513 into
514         case True of True { ... }
515 which stupidly tries to bind the datacon 'True'. 
516
517 \begin{code}
518 mkCoreAppDs  :: CoreExpr -> CoreExpr -> CoreExpr
519 mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
520   | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]
521   = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
522   where
523     case_bndr = case arg1 of
524                    Var v1 | isLocalId v1 -> v1        -- Note [Desugaring seq (2) and (3)]
525                    _                     -> mkWildValBinder ty1
526
527 mkCoreAppDs fun arg = mkCoreApp fun arg  -- The rest is done in MkCore
528
529 mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
530 mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
531 \end{code}
532
533
534 %************************************************************************
535 %*                                                                      *
536 \subsection[mkSelectorBind]{Make a selector bind}
537 %*                                                                      *
538 %************************************************************************
539
540 This is used in various places to do with lazy patterns.
541 For each binder $b$ in the pattern, we create a binding:
542 \begin{verbatim}
543     b = case v of pat' -> b'
544 \end{verbatim}
545 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
546
547 ToDo: making these bindings should really depend on whether there's
548 much work to be done per binding.  If the pattern is complex, it
549 should be de-mangled once, into a tuple (and then selected from).
550 Otherwise the demangling can be in-line in the bindings (as here).
551
552 Boring!  Boring!  One error message per binder.  The above ToDo is
553 even more helpful.  Something very similar happens for pattern-bound
554 expressions.
555
556 Note [mkSelectorBinds]
557 ~~~~~~~~~~~~~~~~~~~~~~
558 Given   p = e, where p binds x,y
559 we are going to make EITHER
560
561 EITHER (A)   v = e   (where v is fresh)
562              x = case v of p -> x
563              y = case v of p -> y
564
565 OR (B)       t = case e of p -> (x,y)
566              x = case t of (x,_) -> x
567              y = case t of (_,y) -> y
568
569 We do (A) when 
570  * Matching the pattern is cheap so we don't mind
571    doing it twice.  
572  * Or if the pattern binds only one variable (so we'll only
573    match once)
574  * AND the pattern can't fail (else we tiresomely get two inexhaustive 
575    pattern warning messages)
576
577 Otherwise we do (B).  Really (A) is just an optimisation for very common
578 cases like
579      Just x = e
580      (p,q) = e
581
582 \begin{code}
583 mkSelectorBinds :: [Maybe (Tickish Id)]  -- ticks to add, possibly
584                 -> LPat Id      -- The pattern
585                 -> CoreExpr     -- Expression to which the pattern is bound
586                 -> DsM [(Id,CoreExpr)]
587
588 mkSelectorBinds ticks (L _ (VarPat v)) val_expr
589   = return [(v, case ticks of
590                   [t] -> mkOptTickBox t val_expr
591                   _   -> val_expr)]
592
593 mkSelectorBinds ticks pat val_expr
594   | null binders 
595   = return []
596
597   | isSingleton binders || is_simple_lpat pat
598     -- See Note [mkSelectorBinds]
599   = do { val_var <- newSysLocalDs (hsLPatType pat)
600         -- Make up 'v' in Note [mkSelectorBinds]
601         -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
602         -- This does not matter after desugaring, but there's a subtle 
603         -- issue with implicit parameters. Consider
604         --      (x,y) = ?i
605         -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
606         -- to the desugarer.  (Why opaque?  Because newtypes have to be.  Why
607         -- does it get that type?  So that when we abstract over it we get the
608         -- right top-level type  (?i::Int) => ...)
609         --
610         -- So to get the type of 'v', use the pattern not the rhs.  Often more
611         -- efficient too.
612
613         -- For the error message we make one error-app, to avoid duplication.
614         -- But we need it at different types... so we use coerce for that
615        ; err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID  unitTy (ppr pat)
616        ; err_var <- newSysLocalDs unitTy
617        ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders
618        ; return ( (val_var, val_expr) : 
619                   (err_var, err_expr) :
620                   binds ) }
621
622   | otherwise
623   = do { error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID   tuple_ty (ppr pat)
624        ; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
625        ; tuple_var <- newSysLocalDs tuple_ty
626        ; let mk_tup_bind tick binder
627               = (binder, mkOptTickBox tick $
628                             mkTupleSelector local_binders binder
629                                             tuple_var (Var tuple_var))
630        ; return ( (tuple_var, tuple_expr) : zipWith mk_tup_bind ticks' binders ) }
631   where
632     binders       = collectPatBinders pat
633     ticks'        = ticks ++ repeat Nothing
634
635     local_binders = map localiseId binders      -- See Note [Localise pattern binders]
636     local_tuple   = mkBigCoreVarTup binders
637     tuple_ty      = exprType local_tuple
638
639     mk_bind scrut_var err_var tick bndr_var = do
640     -- (mk_bind sv err_var) generates
641     --          bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
642     -- Remember, pat binds bv
643         rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
644                                 (Var bndr_var) error_expr
645         return (bndr_var, mkOptTickBox tick rhs_expr)
646       where
647         error_expr = mkCast (Var err_var) co
648         co         = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
649
650     is_simple_lpat p = is_simple_pat (unLoc p)
651
652     is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
653     is_simple_pat pat@(ConPatOut{})     =  isProductTyCon (dataConTyCon (unLoc (pat_con pat)))
654                                         && all is_triv_lpat (hsConPatArgs (pat_args pat))
655     is_simple_pat (VarPat _)                   = True
656     is_simple_pat (ParPat p)                   = is_simple_lpat p
657     is_simple_pat _                                    = False
658
659     is_triv_lpat p = is_triv_pat (unLoc p)
660
661     is_triv_pat (VarPat _)  = True
662     is_triv_pat (WildPat _) = True
663     is_triv_pat (ParPat p)  = is_triv_lpat p
664     is_triv_pat _           = False
665 \end{code}
666
667 Creating big tuples and their types for full Haskell expressions.
668 They work over *Ids*, and create tuples replete with their types,
669 which is whey they are not in HsUtils.
670
671 \begin{code}
672 mkLHsPatTup :: [LPat Id] -> LPat Id
673 mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
674 mkLHsPatTup [lpat] = lpat
675 mkLHsPatTup lpats  = L (getLoc (head lpats)) $ 
676                      mkVanillaTuplePat lpats Boxed
677
678 mkLHsVarPatTup :: [Id] -> LPat Id
679 mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
680
681 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
682 -- A vanilla tuple pattern simply gets its type from its sub-patterns
683 mkVanillaTuplePat pats box 
684   = TuplePat pats box (mkTupleTy (boxityNormalTupleSort box) (map hsLPatType pats))
685
686 -- The Big equivalents for the source tuple expressions
687 mkBigLHsVarTup :: [Id] -> LHsExpr Id
688 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
689
690 mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
691 mkBigLHsTup = mkChunkified mkLHsTupleExpr
692
693 -- The Big equivalents for the source tuple patterns
694 mkBigLHsVarPatTup :: [Id] -> LPat Id
695 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
696
697 mkBigLHsPatTup :: [LPat Id] -> LPat Id
698 mkBigLHsPatTup = mkChunkified mkLHsPatTup
699 \end{code}
700
701 %************************************************************************
702 %*                                                                      *
703 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
704 %*                                                                      *
705 %************************************************************************
706
707 Generally, we handle pattern matching failure like this: let-bind a
708 fail-variable, and use that variable if the thing fails:
709 \begin{verbatim}
710         let fail.33 = error "Help"
711         in
712         case x of
713                 p1 -> ...
714                 p2 -> fail.33
715                 p3 -> fail.33
716                 p4 -> ...
717 \end{verbatim}
718 Then
719 \begin{itemize}
720 \item
721 If the case can't fail, then there'll be no mention of @fail.33@, and the
722 simplifier will later discard it.
723
724 \item
725 If it can fail in only one way, then the simplifier will inline it.
726
727 \item
728 Only if it is used more than once will the let-binding remain.
729 \end{itemize}
730
731 There's a problem when the result of the case expression is of
732 unboxed type.  Then the type of @fail.33@ is unboxed too, and
733 there is every chance that someone will change the let into a case:
734 \begin{verbatim}
735         case error "Help" of
736           fail.33 -> case ....
737 \end{verbatim}
738
739 which is of course utterly wrong.  Rather than drop the condition that
740 only boxed types can be let-bound, we just turn the fail into a function
741 for the primitive case:
742 \begin{verbatim}
743         let fail.33 :: Void -> Int#
744             fail.33 = \_ -> error "Help"
745         in
746         case x of
747                 p1 -> ...
748                 p2 -> fail.33 void
749                 p3 -> fail.33 void
750                 p4 -> ...
751 \end{verbatim}
752
753 Now @fail.33@ is a function, so it can be let-bound.
754
755 \begin{code}
756 mkFailurePair :: CoreExpr       -- Result type of the whole case expression
757               -> DsM (CoreBind, -- Binds the newly-created fail variable
758                                 -- to \ _ -> expression
759                       CoreExpr) -- Fail variable applied to realWorld#
760 -- See Note [Failure thunks and CPR]
761 mkFailurePair expr
762   = do { fail_fun_var <- newFailLocalDs (realWorldStatePrimTy `mkFunTy` ty)
763        ; fail_fun_arg <- newSysLocalDs realWorldStatePrimTy
764        ; return (NonRec fail_fun_var (Lam fail_fun_arg expr),
765                  App (Var fail_fun_var) (Var realWorldPrimId)) }
766   where
767     ty = exprType expr
768 \end{code}
769
770 Note [Failure thunks and CPR]
771 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
772 When we make a failure point we ensure that it
773 does not look like a thunk. Example:
774
775    let fail = \rw -> error "urk"
776    in case x of 
777         [] -> fail realWorld#
778         (y:ys) -> case ys of
779                     [] -> fail realWorld#  
780                     (z:zs) -> (y,z)
781
782 Reason: we know that a failure point is always a "join point" and is
783 entered at most once.  Adding a dummy 'realWorld' token argument makes
784 it clear that sharing is not an issue.  And that in turn makes it more
785 CPR-friendly.  This matters a lot: if you don't get it right, you lose
786 the tail call property.  For example, see Trac #3403.
787
788 \begin{code}
789 mkOptTickBox :: Maybe (Tickish Id) -> CoreExpr -> CoreExpr
790 mkOptTickBox Nothing e        = e
791 mkOptTickBox (Just tickish) e = Tick tickish e
792
793 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
794 mkBinaryTickBox ixT ixF e = do
795        uq <- newUnique  
796        this_mod <- getModuleDs
797        let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
798        let
799            falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
800            trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)
801        --
802        return $ Case e bndr1 boolTy
803                        [ (DataAlt falseDataCon, [], falseBox)
804                        , (DataAlt trueDataCon,  [], trueBox)
805                        ]
806 \end{code}