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