Fix grouping for pattern synonyms
[ghc.git] / compiler / deSugar / DsUtils.hs
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
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, mkCastDs,
28
29 seqVar,
30
31 -- LHs tuples
32 mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
33 mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,
34
35 mkSelectorBinds,
36
37 selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
38 mkOptTickBox, mkBinaryTickBox, getUnBangedLPat
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 Coercion
63 import TysPrim
64 import TysWiredIn
65 import BasicTypes
66 import UniqSet
67 import UniqSupply
68 import Module
69 import PrelNames
70 import Outputable
71 import SrcLoc
72 import Util
73 import DynFlags
74 import FastString
75 import qualified GHC.LanguageExtensions as LangExt
76
77 import TcEvidence
78
79 import Control.Monad ( zipWithM )
80
81 {-
82 ************************************************************************
83 * *
84 \subsection{ Selecting match variables}
85 * *
86 ************************************************************************
87
88 We're about to match against some patterns. We want to make some
89 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
90 hand, which should indeed be bound to the pattern as a whole, then use it;
91 otherwise, make one up.
92 -}
93
94 selectSimpleMatchVarL :: LPat Id -> DsM Id
95 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
96
97 -- (selectMatchVars ps tys) chooses variables of type tys
98 -- to use for matching ps against. If the pattern is a variable,
99 -- we try to use that, to save inventing lots of fresh variables.
100 --
101 -- OLD, but interesting note:
102 -- But even if it is a variable, its type might not match. Consider
103 -- data T a where
104 -- T1 :: Int -> T Int
105 -- T2 :: a -> T a
106 --
107 -- f :: T a -> a -> Int
108 -- f (T1 i) (x::Int) = x
109 -- f (T2 i) (y::a) = 0
110 -- Then we must not choose (x::Int) as the matching variable!
111 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
112
113 selectMatchVars :: [Pat Id] -> DsM [Id]
114 selectMatchVars ps = mapM selectMatchVar ps
115
116 selectMatchVar :: Pat Id -> DsM Id
117 selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
118 selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
119 selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
120 selectMatchVar (VarPat var) = return (localiseId (unLoc var))
121 -- Note [Localise pattern binders]
122 selectMatchVar (AsPat var _) = return (unLoc var)
123 selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
124 -- OK, better make up one...
125
126 {-
127 Note [Localise pattern binders]
128 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
129 Consider module M where
130 [Just a] = e
131 After renaming it looks like
132 module M where
133 [Just M.a] = e
134
135 We don't generalise, since it's a pattern binding, monomorphic, etc,
136 so after desugaring we may get something like
137 M.a = case e of (v:_) ->
138 case v of Just M.a -> M.a
139 Notice the "M.a" in the pattern; after all, it was in the original
140 pattern. However, after optimisation those pattern binders can become
141 let-binders, and then end up floated to top level. They have a
142 different *unique* by then (the simplifier is good about maintaining
143 proper scoping), but it's BAD to have two top-level bindings with the
144 External Name M.a, because that turns into two linker symbols for M.a.
145 It's quite rare for this to actually *happen* -- the only case I know
146 of is tc003 compiled with the 'hpc' way -- but that only makes it
147 all the more annoying.
148
149 To avoid this, we craftily call 'localiseId' in the desugarer, which
150 simply turns the External Name for the Id into an Internal one, but
151 doesn't change the unique. So the desugarer produces this:
152 M.a{r8} = case e of (v:_) ->
153 case v of Just a{r8} -> M.a{r8}
154 The unique is still 'r8', but the binding site in the pattern
155 is now an Internal Name. Now the simplifier's usual mechanisms
156 will propagate that Name to all the occurrence sites, as well as
157 un-shadowing it, so we'll get
158 M.a{r8} = case e of (v:_) ->
159 case v of Just a{s77} -> a{s77}
160 In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
161 runs on the output of the desugarer, so all is well by the end of
162 the desugaring pass.
163
164
165 ************************************************************************
166 * *
167 * type synonym EquationInfo and access functions for its pieces *
168 * *
169 ************************************************************************
170 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
171
172 The ``equation info'' used by @match@ is relatively complicated and
173 worthy of a type synonym and a few handy functions.
174 -}
175
176 firstPat :: EquationInfo -> Pat Id
177 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
178
179 shiftEqns :: [EquationInfo] -> [EquationInfo]
180 -- Drop the first pattern in each equation
181 shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
182
183 -- Functions on MatchResults
184
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 (text "mkView" <+> ppr var') 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 :: [Var],
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 sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]
341 sort_alts = sortWith (dataConTag . alt_pat)
342
343 mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
344 mkPatSynCase var ty alt fail = do
345 matcher <- dsLExpr $ mkLHsWrap wrapper $
346 nlHsTyApp matcher [getLevity "mkPatSynCase" ty, ty]
347 let MatchResult _ mkCont = match_result
348 cont <- mkCoreLams bndrs <$> mkCont fail
349 return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
350 where
351 MkCaseAlt{ alt_pat = psyn,
352 alt_bndrs = bndrs,
353 alt_wrapper = wrapper,
354 alt_result = match_result} = alt
355 (matcher, needs_void_lam) = patSynMatcher psyn
356
357 -- See Note [Matchers and builders for pattern synonyms] in PatSyns
358 -- on these extra Void# arguments
359 ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
360 | otherwise = cont
361
362 mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
363 mkDataConCase _ _ [] = panic "mkDataConCase: no alternatives"
364 mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
365 where
366 con1 = alt_pat alt1
367 tycon = dataConTyCon con1
368 data_cons = tyConDataCons tycon
369 match_results = map alt_result alts
370
371 sorted_alts :: [CaseAlt DataCon]
372 sorted_alts = sort_alts alts
373
374 var_ty = idType var
375 (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
376 -- (not that splitTyConApp does, these days)
377
378 mk_case :: CoreExpr -> DsM CoreExpr
379 mk_case fail = do
380 alts <- mapM (mk_alt fail) sorted_alts
381 return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)
382
383 mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt
384 mk_alt fail MkCaseAlt{ alt_pat = con,
385 alt_bndrs = args,
386 alt_result = MatchResult _ body_fn }
387 = do { body <- body_fn fail
388 ; case dataConBoxer con of {
389 Nothing -> return (DataAlt con, args, body) ;
390 Just (DCB boxer) ->
391 do { us <- newUniqueSupply
392 ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
393 ; return (DataAlt con, rep_ids, mkLets binds body) } } }
394
395 mk_default :: CoreExpr -> [CoreAlt]
396 mk_default fail | exhaustive_case = []
397 | otherwise = [(DEFAULT, [], fail)]
398
399 fail_flag :: CanItFail
400 fail_flag | exhaustive_case
401 = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
402 | otherwise
403 = CanFail
404
405 mentioned_constructors = mkUniqSet $ map alt_pat alts
406 un_mentioned_constructors
407 = mkUniqSet data_cons `minusUniqSet` mentioned_constructors
408 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
409
410 --- Stuff for parallel arrays
411 --
412 -- * the following is to desugar cases over fake constructors for
413 -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
414 -- case
415 --
416 mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr
417 mkPArrCase dflags var ty sorted_alts fail = do
418 lengthP <- dsDPHBuiltin lengthPVar
419 alt <- unboxAlt
420 return (mkWildCase (len lengthP) intTy ty [alt])
421 where
422 elemTy = case splitTyConApp (idType var) of
423 (_, [elemTy]) -> elemTy
424 _ -> panic panicMsg
425 panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
426 len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
427 --
428 unboxAlt = do
429 l <- newSysLocalDs intPrimTy
430 indexP <- dsDPHBuiltin indexPVar
431 alts <- mapM (mkAlt indexP) sorted_alts
432 return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
433 where
434 dft = (DEFAULT, [], fail)
435
436 --
437 -- each alternative matches one array length (corresponding to one
438 -- fake array constructor), so the match is on a literal; each
439 -- alternative's body is extended by a local binding for each
440 -- constructor argument, which are bound to array elements starting
441 -- with the first
442 --
443 mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do
444 body <- bodyFun fail
445 return (LitAlt lit, [], mkCoreLets binds body)
446 where
447 lit = MachInt $ toInteger (dataConSourceArity (alt_pat alt))
448 binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)]
449 --
450 indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i]
451
452 {-
453 ************************************************************************
454 * *
455 \subsection{Desugarer's versions of some Core functions}
456 * *
457 ************************************************************************
458 -}
459
460 mkErrorAppDs :: Id -- The error function
461 -> Type -- Type to which it should be applied
462 -> SDoc -- The error message string to pass
463 -> DsM CoreExpr
464
465 mkErrorAppDs err_id ty msg = do
466 src_loc <- getSrcSpanDs
467 dflags <- getDynFlags
468 let
469 full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
470 core_msg = Lit (mkMachString full_msg)
471 -- mkMachString returns a result of type String#
472 return (mkApps (Var err_id) [Type (getLevity "mkErrorAppDs" ty), Type ty, core_msg])
473
474 {-
475 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
476
477 Note [Desugaring seq (1)] cf Trac #1031
478 ~~~~~~~~~~~~~~~~~~~~~~~~~
479 f x y = x `seq` (y `seq` (# x,y #))
480
481 The [CoreSyn let/app invariant] means that, other things being equal, because
482 the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
483
484 f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
485
486 But that is bad for two reasons:
487 (a) we now evaluate y before x, and
488 (b) we can't bind v to an unboxed pair
489
490 Seq is very, very special! So we recognise it right here, and desugar to
491 case x of _ -> case y of _ -> (# x,y #)
492
493 Note [Desugaring seq (2)] cf Trac #2273
494 ~~~~~~~~~~~~~~~~~~~~~~~~~
495 Consider
496 let chp = case b of { True -> fst x; False -> 0 }
497 in chp `seq` ...chp...
498 Here the seq is designed to plug the space leak of retaining (snd x)
499 for too long.
500
501 If we rely on the ordinary inlining of seq, we'll get
502 let chp = case b of { True -> fst x; False -> 0 }
503 case chp of _ { I# -> ...chp... }
504
505 But since chp is cheap, and the case is an alluring contet, we'll
506 inline chp into the case scrutinee. Now there is only one use of chp,
507 so we'll inline a second copy. Alas, we've now ruined the purpose of
508 the seq, by re-introducing the space leak:
509 case (case b of {True -> fst x; False -> 0}) of
510 I# _ -> ...case b of {True -> fst x; False -> 0}...
511
512 We can try to avoid doing this by ensuring that the binder-swap in the
513 case happens, so we get his at an early stage:
514 case chp of chp2 { I# -> ...chp2... }
515 But this is fragile. The real culprit is the source program. Perhaps we
516 should have said explicitly
517 let !chp2 = chp in ...chp2...
518
519 But that's painful. So the code here does a little hack to make seq
520 more robust: a saturated application of 'seq' is turned *directly* into
521 the case expression, thus:
522 x `seq` e2 ==> case x of x -> e2 -- Note shadowing!
523 e1 `seq` e2 ==> case x of _ -> e2
524
525 So we desugar our example to:
526 let chp = case b of { True -> fst x; False -> 0 }
527 case chp of chp { I# -> ...chp... }
528 And now all is well.
529
530 The reason it's a hack is because if you define mySeq=seq, the hack
531 won't work on mySeq.
532
533 Note [Desugaring seq (3)] cf Trac #2409
534 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
535 The isLocalId ensures that we don't turn
536 True `seq` e
537 into
538 case True of True { ... }
539 which stupidly tries to bind the datacon 'True'.
540 -}
541
542 mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
543 mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
544 | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]
545 = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
546 where
547 case_bndr = case arg1 of
548 Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)]
549 _ -> mkWildValBinder ty1
550
551 mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore
552
553 mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
554 mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
555
556 mkCastDs :: CoreExpr -> Coercion -> CoreExpr
557 -- We define a desugarer-specific verison of CoreUtils.mkCast,
558 -- because in the immediate output of the desugarer, we can have
559 -- apparently-mis-matched coercions: E.g.
560 -- let a = b
561 -- in (x :: a) |> (co :: b ~ Int)
562 -- Lint know about type-bindings for let and does not complain
563 -- So here we do not make the assertion checks that we make in
564 -- CoreUtils.mkCast; and we do less peephole optimisation too
565 mkCastDs e co | isReflCo co = e
566 | otherwise = Cast e co
567
568 {-
569 ************************************************************************
570 * *
571 Tuples and selector bindings
572 * *
573 ************************************************************************
574
575 This is used in various places to do with lazy patterns.
576 For each binder $b$ in the pattern, we create a binding:
577 \begin{verbatim}
578 b = case v of pat' -> b'
579 \end{verbatim}
580 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
581
582 ToDo: making these bindings should really depend on whether there's
583 much work to be done per binding. If the pattern is complex, it
584 should be de-mangled once, into a tuple (and then selected from).
585 Otherwise the demangling can be in-line in the bindings (as here).
586
587 Boring! Boring! One error message per binder. The above ToDo is
588 even more helpful. Something very similar happens for pattern-bound
589 expressions.
590
591 Note [mkSelectorBinds]
592 ~~~~~~~~~~~~~~~~~~~~~~
593 Given p = e, where p binds x,y
594 we are going to make EITHER
595
596 EITHER (A) v = e (where v is fresh)
597 x = case v of p -> x
598 y = case v of p -> y
599
600 OR (B) t = case e of p -> (x,y)
601 x = case t of (x,_) -> x
602 y = case t of (_,y) -> y
603
604 We do (A) when
605 * Matching the pattern is cheap so we don't mind
606 doing it twice.
607 * Or if the pattern binds only one variable (so we'll only
608 match once)
609 * AND the pattern can't fail (else we tiresomely get two inexhaustive
610 pattern warning messages)
611
612 Otherwise we do (B). Really (A) is just an optimisation for very common
613 cases like
614 Just x = e
615 (p,q) = e
616 -}
617
618 mkSelectorBinds :: Bool -- ^ is strict
619 -> [[Tickish Id]] -- ^ ticks to add, possibly
620 -> LPat Id -- ^ The pattern
621 -> CoreExpr -- ^ Expression to which the pattern is bound
622 -> DsM (Maybe Id,[(Id,CoreExpr)])
623 -- ^ Id the rhs is bound to, for desugaring strict
624 -- binds (see Note [Desugar Strict binds] in DsBinds)
625 -- and all the desugared binds
626
627 mkSelectorBinds _ ticks (L _ (VarPat (L _ v))) val_expr
628 = return (Just v
629 ,[(v, case ticks of
630 [t] -> mkOptTickBox t val_expr
631 _ -> val_expr)])
632
633 mkSelectorBinds is_strict ticks pat val_expr
634 | null binders, not is_strict
635 = return (Nothing, [])
636 | isSingleton binders || is_simple_lpat pat
637 -- See Note [mkSelectorBinds]
638 = do { let pat_ty = hsLPatType pat
639 ; val_var <- newSysLocalDs pat_ty
640 -- Make up 'v' in Note [mkSelectorBinds]
641 -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
642 -- This does not matter after desugaring, but there's a subtle
643 -- issue with implicit parameters. Consider
644 -- (x,y) = ?i
645 -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
646 -- to the desugarer. (Why opaque? Because newtypes have to be. Why
647 -- does it get that type? So that when we abstract over it we get the
648 -- right top-level type (?i::Int) => ...)
649 --
650 -- So to get the type of 'v', use the pattern not the rhs. Often more
651 -- efficient too.
652
653 -- For the error message we make one error-app, to avoid duplication.
654 -- But we need it at different types, so we make it polymorphic:
655 -- err_var = /\a. iRREFUT_PAT_ERR a "blah blah blah"
656 ; err_app <- mkErrorAppDs iRREFUT_PAT_ERROR_ID alphaTy (ppr pat)
657 ; err_var <- newSysLocalDs (mkInvForAllTys [alphaTyVar] alphaTy)
658 ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders
659 ; return (Just val_var
660 ,(val_var, val_expr) :
661 (err_var, Lam alphaTyVar err_app) :
662 binds) }
663
664 | otherwise
665 = do { val_var <- newSysLocalDs (hsLPatType pat)
666 ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
667 ; tuple_expr
668 <- matchSimply (Var val_var) PatBindRhs pat local_tuple error_expr
669 ; tuple_var <- newSysLocalDs tuple_ty
670 ; let mk_tup_bind tick binder
671 = (binder, mkOptTickBox tick $
672 mkTupleSelector local_binders binder
673 tuple_var (Var tuple_var))
674 -- if strict and no binders we want to force the case
675 -- expression to force an error if the pattern match
676 -- failed. See Note [Desugar Strict binds] in DsBinds.
677 ; let force_var = if null binders && is_strict
678 then tuple_var
679 else val_var
680 ; return (Just force_var
681 ,(val_var,val_expr) :
682 (tuple_var, tuple_expr) :
683 zipWith mk_tup_bind ticks' binders) }
684 where
685 binders = collectPatBinders pat
686 ticks' = ticks ++ repeat []
687
688 local_binders = map localiseId binders -- See Note [Localise pattern binders]
689 local_tuple = mkBigCoreVarTup binders
690 tuple_ty = exprType local_tuple
691
692 mk_bind scrut_var err_var tick bndr_var = do
693 -- (mk_bind sv err_var) generates
694 -- bv = case sv of { pat -> bv; other -> err_var @ type-of-bv }
695 -- Remember, pat binds bv
696 rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
697 (Var bndr_var) error_expr
698 return (bndr_var, mkOptTickBox tick rhs_expr)
699 where
700 error_expr = Var err_var `App` Type (idType bndr_var)
701
702 is_simple_lpat p = is_simple_pat (unLoc p)
703
704 is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
705 is_simple_pat pat@(ConPatOut{}) = case unLoc (pat_con pat) of
706 RealDataCon con -> isProductTyCon (dataConTyCon con)
707 && all is_triv_lpat (hsConPatArgs (pat_args pat))
708 PatSynCon _ -> False
709 is_simple_pat (VarPat _) = True
710 is_simple_pat (ParPat p) = is_simple_lpat p
711 is_simple_pat _ = False
712
713 is_triv_lpat p = is_triv_pat (unLoc p)
714
715 is_triv_pat (VarPat _) = True
716 is_triv_pat (WildPat _) = True
717 is_triv_pat (ParPat p) = is_triv_lpat p
718 is_triv_pat _ = False
719
720 {-
721 Creating big tuples and their types for full Haskell expressions.
722 They work over *Ids*, and create tuples replete with their types,
723 which is whey they are not in HsUtils.
724 -}
725
726 mkLHsPatTup :: [LPat Id] -> LPat Id
727 mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
728 mkLHsPatTup [lpat] = lpat
729 mkLHsPatTup lpats = L (getLoc (head lpats)) $
730 mkVanillaTuplePat lpats Boxed
731
732 mkLHsVarPatTup :: [Id] -> LPat Id
733 mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
734
735 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
736 -- A vanilla tuple pattern simply gets its type from its sub-patterns
737 mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
738
739 -- The Big equivalents for the source tuple expressions
740 mkBigLHsVarTupId :: [Id] -> LHsExpr Id
741 mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
742
743 mkBigLHsTupId :: [LHsExpr Id] -> LHsExpr Id
744 mkBigLHsTupId = mkChunkified mkLHsTupleExpr
745
746 -- The Big equivalents for the source tuple patterns
747 mkBigLHsVarPatTupId :: [Id] -> LPat Id
748 mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)
749
750 mkBigLHsPatTupId :: [LPat Id] -> LPat Id
751 mkBigLHsPatTupId = mkChunkified mkLHsPatTup
752
753 {-
754 ************************************************************************
755 * *
756 Code for pattern-matching and other failures
757 * *
758 ************************************************************************
759
760 Generally, we handle pattern matching failure like this: let-bind a
761 fail-variable, and use that variable if the thing fails:
762 \begin{verbatim}
763 let fail.33 = error "Help"
764 in
765 case x of
766 p1 -> ...
767 p2 -> fail.33
768 p3 -> fail.33
769 p4 -> ...
770 \end{verbatim}
771 Then
772 \begin{itemize}
773 \item
774 If the case can't fail, then there'll be no mention of @fail.33@, and the
775 simplifier will later discard it.
776
777 \item
778 If it can fail in only one way, then the simplifier will inline it.
779
780 \item
781 Only if it is used more than once will the let-binding remain.
782 \end{itemize}
783
784 There's a problem when the result of the case expression is of
785 unboxed type. Then the type of @fail.33@ is unboxed too, and
786 there is every chance that someone will change the let into a case:
787 \begin{verbatim}
788 case error "Help" of
789 fail.33 -> case ....
790 \end{verbatim}
791
792 which is of course utterly wrong. Rather than drop the condition that
793 only boxed types can be let-bound, we just turn the fail into a function
794 for the primitive case:
795 \begin{verbatim}
796 let fail.33 :: Void -> Int#
797 fail.33 = \_ -> error "Help"
798 in
799 case x of
800 p1 -> ...
801 p2 -> fail.33 void
802 p3 -> fail.33 void
803 p4 -> ...
804 \end{verbatim}
805
806 Now @fail.33@ is a function, so it can be let-bound.
807 -}
808
809 mkFailurePair :: CoreExpr -- Result type of the whole case expression
810 -> DsM (CoreBind, -- Binds the newly-created fail variable
811 -- to \ _ -> expression
812 CoreExpr) -- Fail variable applied to realWorld#
813 -- See Note [Failure thunks and CPR]
814 mkFailurePair expr
815 = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty)
816 ; fail_fun_arg <- newSysLocalDs voidPrimTy
817 ; let real_arg = setOneShotLambda fail_fun_arg
818 ; return (NonRec fail_fun_var (Lam real_arg expr),
819 App (Var fail_fun_var) (Var voidPrimId)) }
820 where
821 ty = exprType expr
822
823 {-
824 Note [Failure thunks and CPR]
825 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
826 When we make a failure point we ensure that it
827 does not look like a thunk. Example:
828
829 let fail = \rw -> error "urk"
830 in case x of
831 [] -> fail realWorld#
832 (y:ys) -> case ys of
833 [] -> fail realWorld#
834 (z:zs) -> (y,z)
835
836 Reason: we know that a failure point is always a "join point" and is
837 entered at most once. Adding a dummy 'realWorld' token argument makes
838 it clear that sharing is not an issue. And that in turn makes it more
839 CPR-friendly. This matters a lot: if you don't get it right, you lose
840 the tail call property. For example, see Trac #3403.
841
842
843 ************************************************************************
844 * *
845 Ticks
846 * *
847 ********************************************************************* -}
848
849 mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
850 mkOptTickBox = flip (foldr Tick)
851
852 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
853 mkBinaryTickBox ixT ixF e = do
854 uq <- newUnique
855 this_mod <- getModule
856 let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
857 let
858 falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
859 trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId)
860 --
861 return $ Case e bndr1 boolTy
862 [ (DataAlt falseDataCon, [], falseBox)
863 , (DataAlt trueDataCon, [], trueBox)
864 ]
865
866
867
868 -- *******************************************************************
869
870
871 -- | Remove any bang from a pattern and say if it is a strict bind,
872 -- also make irrefutable patterns ordinary patterns if -XStrict.
873 --
874 -- Example:
875 -- ~pat => False, pat -- when -XStrict
876 -- ~pat => False, ~pat -- without -XStrict
877 -- ~(~pat) => False, ~pat -- when -XStrict
878 -- pat => True, pat -- when -XStrict
879 -- !pat => True, pat -- always
880 getUnBangedLPat :: DynFlags
881 -> LPat id -- ^ Original pattern
882 -> (Bool, LPat id) -- is bind strict?, pattern without bangs
883 getUnBangedLPat dflags (L l (ParPat p))
884 = let (is_strict, p') = getUnBangedLPat dflags p
885 in (is_strict, L l (ParPat p'))
886 getUnBangedLPat _ (L _ (BangPat p))
887 = (True,p)
888 getUnBangedLPat dflags (L _ (LazyPat p))
889 | xopt LangExt.Strict dflags
890 = (False,p)
891 getUnBangedLPat dflags p
892 = (xopt LangExt.Strict dflags,p)