Small refactor in desugar of pattern matching
[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 {-# LANGUAGE FlexibleContexts #-}
13 {-# LANGUAGE TypeFamilies #-}
14
15 -- | Utility functions for constructing Core syntax, principally for desugaring
16 module DsUtils (
17 EquationInfo(..),
18 firstPat, shiftEqns,
19
20 MatchResult(..), CanItFail(..), CaseAlt(..),
21 cantFailMatchResult, alwaysFailMatchResult,
22 extractMatchResult, combineMatchResults,
23 adjustMatchResult, adjustMatchResultDs,
24 mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
25 matchCanFail, mkEvalMatchResult,
26 mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
27 wrapBind, wrapBinds,
28
29 mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
30
31 seqVar,
32
33 -- LHs tuples
34 mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
35 mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,
36
37 mkSelectorBinds,
38
39 selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
40 mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang
41 ) where
42
43 #include "HsVersions.h"
44
45 import GhcPrelude
46
47 import {-# SOURCE #-} Match ( matchSimply )
48 import {-# SOURCE #-} DsExpr ( dsLExpr )
49
50 import HsSyn
51 import TcHsSyn
52 import TcType( tcSplitTyConApp )
53 import CoreSyn
54 import DsMonad
55
56 import CoreUtils
57 import MkCore
58 import MkId
59 import Id
60 import Literal
61 import TyCon
62 import DataCon
63 import PatSyn
64 import Type
65 import Coercion
66 import TysPrim
67 import TysWiredIn
68 import BasicTypes
69 import ConLike
70 import UniqSet
71 import UniqSupply
72 import Module
73 import PrelNames
74 import Name( isInternalName )
75 import Outputable
76 import SrcLoc
77 import Util
78 import DynFlags
79 import FastString
80 import qualified GHC.LanguageExtensions as LangExt
81
82 import TcEvidence
83
84 import Control.Monad ( zipWithM )
85
86 {-
87 ************************************************************************
88 * *
89 \subsection{ Selecting match variables}
90 * *
91 ************************************************************************
92
93 We're about to match against some patterns. We want to make some
94 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
95 hand, which should indeed be bound to the pattern as a whole, then use it;
96 otherwise, make one up.
97 -}
98
99 selectSimpleMatchVarL :: LPat GhcTc -> DsM Id
100 -- Postcondition: the returned Id has an Internal Name
101 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
102
103 -- (selectMatchVars ps tys) chooses variables of type tys
104 -- to use for matching ps against. If the pattern is a variable,
105 -- we try to use that, to save inventing lots of fresh variables.
106 --
107 -- OLD, but interesting note:
108 -- But even if it is a variable, its type might not match. Consider
109 -- data T a where
110 -- T1 :: Int -> T Int
111 -- T2 :: a -> T a
112 --
113 -- f :: T a -> a -> Int
114 -- f (T1 i) (x::Int) = x
115 -- f (T2 i) (y::a) = 0
116 -- Then we must not choose (x::Int) as the matching variable!
117 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
118
119 selectMatchVars :: [Pat GhcTc] -> DsM [Id]
120 -- Postcondition: the returned Ids have Internal Names
121 selectMatchVars ps = mapM selectMatchVar ps
122
123 selectMatchVar :: Pat GhcTc -> DsM Id
124 -- Postcondition: the returned Id has an Internal Name
125 selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat)
126 selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat)
127 selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat)
128 selectMatchVar (VarPat _ var) = return (localiseId (unLoc var))
129 -- Note [Localise pattern binders]
130 selectMatchVar (AsPat _ var _) = return (unLoc var)
131 selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat)
132 -- OK, better make up one...
133
134 {- Note [Localise pattern binders]
135 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
136 Consider module M where
137 [Just a] = e
138 After renaming it looks like
139 module M where
140 [Just M.a] = e
141
142 We don't generalise, since it's a pattern binding, monomorphic, etc,
143 so after desugaring we may get something like
144 M.a = case e of (v:_) ->
145 case v of Just M.a -> M.a
146 Notice the "M.a" in the pattern; after all, it was in the original
147 pattern. However, after optimisation those pattern binders can become
148 let-binders, and then end up floated to top level. They have a
149 different *unique* by then (the simplifier is good about maintaining
150 proper scoping), but it's BAD to have two top-level bindings with the
151 External Name M.a, because that turns into two linker symbols for M.a.
152 It's quite rare for this to actually *happen* -- the only case I know
153 of is tc003 compiled with the 'hpc' way -- but that only makes it
154 all the more annoying.
155
156 To avoid this, we craftily call 'localiseId' in the desugarer, which
157 simply turns the External Name for the Id into an Internal one, but
158 doesn't change the unique. So the desugarer produces this:
159 M.a{r8} = case e of (v:_) ->
160 case v of Just a{r8} -> M.a{r8}
161 The unique is still 'r8', but the binding site in the pattern
162 is now an Internal Name. Now the simplifier's usual mechanisms
163 will propagate that Name to all the occurrence sites, as well as
164 un-shadowing it, so we'll get
165 M.a{r8} = case e of (v:_) ->
166 case v of Just a{s77} -> a{s77}
167 In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
168 runs on the output of the desugarer, so all is well by the end of
169 the desugaring pass.
170
171 See also Note [MatchIds] in Match.hs
172
173 ************************************************************************
174 * *
175 * type synonym EquationInfo and access functions for its pieces *
176 * *
177 ************************************************************************
178 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
179
180 The ``equation info'' used by @match@ is relatively complicated and
181 worthy of a type synonym and a few handy functions.
182 -}
183
184 firstPat :: EquationInfo -> Pat GhcTc
185 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
186
187 shiftEqns :: [EquationInfo] -> [EquationInfo]
188 -- Drop the first pattern in each equation
189 shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
190
191 -- Functions on MatchResults
192
193 matchCanFail :: MatchResult -> Bool
194 matchCanFail (MatchResult CanFail _) = True
195 matchCanFail (MatchResult CantFail _) = False
196
197 alwaysFailMatchResult :: MatchResult
198 alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
199
200 cantFailMatchResult :: CoreExpr -> MatchResult
201 cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
202
203 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
204 extractMatchResult (MatchResult CantFail match_fn) _
205 = match_fn (error "It can't fail!")
206
207 extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
208 (fail_bind, if_it_fails) <- mkFailurePair fail_expr
209 body <- match_fn if_it_fails
210 return (mkCoreLet fail_bind body)
211
212
213 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
214 combineMatchResults (MatchResult CanFail body_fn1)
215 (MatchResult can_it_fail2 body_fn2)
216 = MatchResult can_it_fail2 body_fn
217 where
218 body_fn fail = do body2 <- body_fn2 fail
219 (fail_bind, duplicatable_expr) <- mkFailurePair body2
220 body1 <- body_fn1 duplicatable_expr
221 return (Let fail_bind body1)
222
223 combineMatchResults match_result1@(MatchResult CantFail _) _
224 = match_result1
225
226 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
227 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
228 = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
229
230 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
231 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
232 = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
233
234 wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
235 wrapBinds [] e = e
236 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
237
238 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
239 wrapBind new old body -- NB: this function must deal with term
240 | new==old = body -- variables, type variables or coercion variables
241 | otherwise = Let (NonRec new (varToCoreExpr old)) body
242
243 seqVar :: Var -> CoreExpr -> CoreExpr
244 seqVar var body = Case (Var var) var (exprType body)
245 [(DEFAULT, [], body)]
246
247 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
248 mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
249
250 -- (mkViewMatchResult var' viewExpr mr) makes the expression
251 -- let var' = viewExpr in mr
252 mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
253 mkViewMatchResult var' viewExpr =
254 adjustMatchResult (mkCoreLet (NonRec var' viewExpr))
255
256 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
257 mkEvalMatchResult var ty
258 = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
259
260 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
261 mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
262 = MatchResult CanFail (\fail -> do body <- body_fn fail
263 return (mkIfThenElse pred_expr body fail))
264
265 mkCoPrimCaseMatchResult :: Id -- Scrutinee
266 -> Type -- Type of the case
267 -> [(Literal, MatchResult)] -- Alternatives
268 -> MatchResult -- Literals are all unlifted
269 mkCoPrimCaseMatchResult var ty match_alts
270 = MatchResult CanFail mk_case
271 where
272 mk_case fail = do
273 alts <- mapM (mk_alt fail) sorted_alts
274 return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
275
276 sorted_alts = sortWith fst match_alts -- Right order for a Case
277 mk_alt fail (lit, MatchResult _ body_fn)
278 = ASSERT( not (litIsLifted lit) )
279 do body <- body_fn fail
280 return (LitAlt lit, [], body)
281
282 data CaseAlt a = MkCaseAlt{ alt_pat :: a,
283 alt_bndrs :: [Var],
284 alt_wrapper :: HsWrapper,
285 alt_result :: MatchResult }
286
287 mkCoAlgCaseMatchResult
288 :: Id -- Scrutinee
289 -> Type -- Type of exp
290 -> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts)
291 -> MatchResult
292 mkCoAlgCaseMatchResult var ty match_alts
293 | isNewtype -- Newtype case; use a let
294 = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
295 mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
296
297 | otherwise
298 = mkDataConCase var ty match_alts
299 where
300 isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))
301
302 -- [Interesting: because of GADTs, we can't rely on the type of
303 -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
304
305 alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }
306 = ASSERT( notNull match_alts ) head match_alts
307 -- Stuff for newtype
308 arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
309 var_ty = idType var
310 (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
311 -- (not that splitTyConApp does, these days)
312 newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
313
314 mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
315 mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt
316
317 sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]
318 sort_alts = sortWith (dataConTag . alt_pat)
319
320 mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
321 mkPatSynCase var ty alt fail = do
322 matcher <- dsLExpr $ mkLHsWrap wrapper $
323 nlHsTyApp matcher [getRuntimeRep ty, ty]
324 let MatchResult _ mkCont = match_result
325 cont <- mkCoreLams bndrs <$> mkCont fail
326 return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
327 where
328 MkCaseAlt{ alt_pat = psyn,
329 alt_bndrs = bndrs,
330 alt_wrapper = wrapper,
331 alt_result = match_result} = alt
332 (matcher, needs_void_lam) = patSynMatcher psyn
333
334 -- See Note [Matchers and builders for pattern synonyms] in PatSyns
335 -- on these extra Void# arguments
336 ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
337 | otherwise = cont
338
339 mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
340 mkDataConCase _ _ [] = panic "mkDataConCase: no alternatives"
341 mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
342 where
343 con1 = alt_pat alt1
344 tycon = dataConTyCon con1
345 data_cons = tyConDataCons tycon
346 match_results = map alt_result alts
347
348 sorted_alts :: [CaseAlt DataCon]
349 sorted_alts = sort_alts alts
350
351 var_ty = idType var
352 (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
353 -- (not that splitTyConApp does, these days)
354
355 mk_case :: CoreExpr -> DsM CoreExpr
356 mk_case fail = do
357 alts <- mapM (mk_alt fail) sorted_alts
358 return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)
359
360 mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt
361 mk_alt fail MkCaseAlt{ alt_pat = con,
362 alt_bndrs = args,
363 alt_result = MatchResult _ body_fn }
364 = do { body <- body_fn fail
365 ; case dataConBoxer con of {
366 Nothing -> return (DataAlt con, args, body) ;
367 Just (DCB boxer) ->
368 do { us <- newUniqueSupply
369 ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
370 ; return (DataAlt con, rep_ids, mkLets binds body) } } }
371
372 mk_default :: CoreExpr -> [CoreAlt]
373 mk_default fail | exhaustive_case = []
374 | otherwise = [(DEFAULT, [], fail)]
375
376 fail_flag :: CanItFail
377 fail_flag | exhaustive_case
378 = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
379 | otherwise
380 = CanFail
381
382 mentioned_constructors = mkUniqSet $ map alt_pat alts
383 un_mentioned_constructors
384 = mkUniqSet data_cons `minusUniqSet` mentioned_constructors
385 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
386
387 {-
388 ************************************************************************
389 * *
390 \subsection{Desugarer's versions of some Core functions}
391 * *
392 ************************************************************************
393 -}
394
395 mkErrorAppDs :: Id -- The error function
396 -> Type -- Type to which it should be applied
397 -> SDoc -- The error message string to pass
398 -> DsM CoreExpr
399
400 mkErrorAppDs err_id ty msg = do
401 src_loc <- getSrcSpanDs
402 dflags <- getDynFlags
403 let
404 full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
405 core_msg = Lit (mkMachString full_msg)
406 -- mkMachString returns a result of type String#
407 return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])
408
409 {-
410 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
411
412 Note [Desugaring seq (1)] cf Trac #1031
413 ~~~~~~~~~~~~~~~~~~~~~~~~~
414 f x y = x `seq` (y `seq` (# x,y #))
415
416 The [CoreSyn let/app invariant] means that, other things being equal, because
417 the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
418
419 f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
420
421 But that is bad for two reasons:
422 (a) we now evaluate y before x, and
423 (b) we can't bind v to an unboxed pair
424
425 Seq is very, very special! So we recognise it right here, and desugar to
426 case x of _ -> case y of _ -> (# x,y #)
427
428 Note [Desugaring seq (2)] cf Trac #2273
429 ~~~~~~~~~~~~~~~~~~~~~~~~~
430 Consider
431 let chp = case b of { True -> fst x; False -> 0 }
432 in chp `seq` ...chp...
433 Here the seq is designed to plug the space leak of retaining (snd x)
434 for too long.
435
436 If we rely on the ordinary inlining of seq, we'll get
437 let chp = case b of { True -> fst x; False -> 0 }
438 case chp of _ { I# -> ...chp... }
439
440 But since chp is cheap, and the case is an alluring contet, we'll
441 inline chp into the case scrutinee. Now there is only one use of chp,
442 so we'll inline a second copy. Alas, we've now ruined the purpose of
443 the seq, by re-introducing the space leak:
444 case (case b of {True -> fst x; False -> 0}) of
445 I# _ -> ...case b of {True -> fst x; False -> 0}...
446
447 We can try to avoid doing this by ensuring that the binder-swap in the
448 case happens, so we get his at an early stage:
449 case chp of chp2 { I# -> ...chp2... }
450 But this is fragile. The real culprit is the source program. Perhaps we
451 should have said explicitly
452 let !chp2 = chp in ...chp2...
453
454 But that's painful. So the code here does a little hack to make seq
455 more robust: a saturated application of 'seq' is turned *directly* into
456 the case expression, thus:
457 x `seq` e2 ==> case x of x -> e2 -- Note shadowing!
458 e1 `seq` e2 ==> case x of _ -> e2
459
460 So we desugar our example to:
461 let chp = case b of { True -> fst x; False -> 0 }
462 case chp of chp { I# -> ...chp... }
463 And now all is well.
464
465 The reason it's a hack is because if you define mySeq=seq, the hack
466 won't work on mySeq.
467
468 Note [Desugaring seq (3)] cf Trac #2409
469 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
470 The isLocalId ensures that we don't turn
471 True `seq` e
472 into
473 case True of True { ... }
474 which stupidly tries to bind the datacon 'True'.
475 -}
476
477 -- NB: Make sure the argument is not levity polymorphic
478 mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
479 mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
480 | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]
481 = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
482 where
483 case_bndr = case arg1 of
484 Var v1 | isInternalName (idName v1)
485 -> v1 -- Note [Desugaring seq (2) and (3)]
486 _ -> mkWildValBinder ty1
487
488 mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore
489
490 -- NB: No argument can be levity polymorphic
491 mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
492 mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
493
494 mkCastDs :: CoreExpr -> Coercion -> CoreExpr
495 -- We define a desugarer-specific version of CoreUtils.mkCast,
496 -- because in the immediate output of the desugarer, we can have
497 -- apparently-mis-matched coercions: E.g.
498 -- let a = b
499 -- in (x :: a) |> (co :: b ~ Int)
500 -- Lint know about type-bindings for let and does not complain
501 -- So here we do not make the assertion checks that we make in
502 -- CoreUtils.mkCast; and we do less peephole optimisation too
503 mkCastDs e co | isReflCo co = e
504 | otherwise = Cast e co
505
506 {-
507 ************************************************************************
508 * *
509 Tuples and selector bindings
510 * *
511 ************************************************************************
512
513 This is used in various places to do with lazy patterns.
514 For each binder $b$ in the pattern, we create a binding:
515 \begin{verbatim}
516 b = case v of pat' -> b'
517 \end{verbatim}
518 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
519
520 ToDo: making these bindings should really depend on whether there's
521 much work to be done per binding. If the pattern is complex, it
522 should be de-mangled once, into a tuple (and then selected from).
523 Otherwise the demangling can be in-line in the bindings (as here).
524
525 Boring! Boring! One error message per binder. The above ToDo is
526 even more helpful. Something very similar happens for pattern-bound
527 expressions.
528
529 Note [mkSelectorBinds]
530 ~~~~~~~~~~~~~~~~~~~~~~
531 mkSelectorBinds is used to desugar a pattern binding {p = e},
532 in a binding group:
533 let { ...; p = e; ... } in body
534 where p binds x,y (this list of binders can be empty).
535 There are two cases.
536
537 ------ Special case (A) -------
538 For a pattern that is just a variable,
539 let !x = e in body
540 ==>
541 let x = e in x `seq` body
542 So we return the binding, with 'x' as the variable to seq.
543
544 ------ Special case (B) -------
545 For a pattern that is essentially just a tuple:
546 * A product type, so cannot fail
547 * Only one level, so that
548 - generating multiple matches is fine
549 - seq'ing it evaluates the same as matching it
550 Then instead we generate
551 { v = e
552 ; x = case v of p -> x
553 ; y = case v of p -> y }
554 with 'v' as the variable to force
555
556 ------ General case (C) -------
557 In the general case we generate these bindings:
558 let { ...; p = e; ... } in body
559 ==>
560 let { t = case e of p -> (x,y)
561 ; x = case t of (x,y) -> x
562 ; y = case t of (x,y) -> y }
563 in t `seq` body
564
565 Note that we return 't' as the variable to force if the pattern
566 is strict (i.e. with -XStrict or an outermost-bang-pattern)
567
568 Note that (A) /includes/ the situation where
569
570 * The pattern binds exactly one variable
571 let !(Just (Just x) = e in body
572 ==>
573 let { t = case e of Just (Just v) -> Unit v
574 ; v = case t of Unit v -> v }
575 in t `seq` body
576 The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn
577 Note that forcing 't' makes the pattern match happen,
578 but does not force 'v'.
579
580 * The pattern binds no variables
581 let !(True,False) = e in body
582 ==>
583 let t = case e of (True,False) -> ()
584 in t `seq` body
585
586
587 ------ Examples ----------
588 * !(_, (_, a)) = e
589 ==>
590 t = case e of (_, (_, a)) -> Unit a
591 a = case t of Unit a -> a
592
593 Note that
594 - Forcing 't' will force the pattern to match fully;
595 e.g. will diverge if (snd e) is bottom
596 - But 'a' itself is not forced; it is wrapped in a one-tuple
597 (see Note [One-tuples] in TysWiredIn)
598
599 * !(Just x) = e
600 ==>
601 t = case e of Just x -> Unit x
602 x = case t of Unit x -> x
603
604 Again, forcing 't' will fail if 'e' yields Nothing.
605
606 Note that even though this is rather general, the special cases
607 work out well:
608
609 * One binder, not -XStrict:
610
611 let Just (Just v) = e in body
612 ==>
613 let t = case e of Just (Just v) -> Unit v
614 v = case t of Unit v -> v
615 in body
616 ==>
617 let v = case (case e of Just (Just v) -> Unit v) of
618 Unit v -> v
619 in body
620 ==>
621 let v = case e of Just (Just v) -> v
622 in body
623
624 * Non-recursive, -XStrict
625 let p = e in body
626 ==>
627 let { t = case e of p -> (x,y)
628 ; x = case t of (x,y) -> x
629 ; y = case t of (x,y) -> x }
630 in t `seq` body
631 ==> {inline seq, float x,y bindings inwards}
632 let t = case e of p -> (x,y) in
633 case t of t' ->
634 let { x = case t' of (x,y) -> x
635 ; y = case t' of (x,y) -> x } in
636 body
637 ==> {inline t, do case of case}
638 case e of p ->
639 let t = (x,y) in
640 let { x = case t' of (x,y) -> x
641 ; y = case t' of (x,y) -> x } in
642 body
643 ==> {case-cancellation, drop dead code}
644 case e of p -> body
645
646 * Special case (B) is there to avoid fruitlessly taking the tuple
647 apart and rebuilding it. For example, consider
648 { K x y = e }
649 where K is a product constructor. Then general case (A) does:
650 { t = case e of K x y -> (x,y)
651 ; x = case t of (x,y) -> x
652 ; y = case t of (x,y) -> y }
653 In the lazy case we can't optimise out this fruitless taking apart
654 and rebuilding. Instead (B) builds
655 { v = e
656 ; x = case v of K x y -> x
657 ; y = case v of K x y -> y }
658 which is better.
659 -}
660
661 mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
662 -> LPat GhcTc -- ^ The pattern
663 -> CoreExpr -- ^ Expression to which the pattern is bound
664 -> DsM (Id,[(Id,CoreExpr)])
665 -- ^ Id the rhs is bound to, for desugaring strict
666 -- binds (see Note [Desugar Strict binds] in DsBinds)
667 -- and all the desugared binds
668
669 mkSelectorBinds ticks pat val_expr
670 | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A)
671 = return (v, [(v, val_expr)])
672
673 | is_flat_prod_lpat pat' -- Special case (B)
674 = do { let pat_ty = hsLPatType pat'
675 ; val_var <- newSysLocalDsNoLP pat_ty
676
677 ; let mk_bind tick bndr_var
678 -- (mk_bind sv bv) generates bv = case sv of { pat -> bv }
679 -- Remember, 'pat' binds 'bv'
680 = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
681 (Var bndr_var)
682 (Var bndr_var) -- Neat hack
683 -- Neat hack: since 'pat' can't fail, the
684 -- "fail-expr" passed to matchSimply is not
685 -- used. But it /is/ used for its type, and for
686 -- that bndr_var is just the ticket.
687 ; return (bndr_var, mkOptTickBox tick rhs_expr) }
688
689 ; binds <- zipWithM mk_bind ticks' binders
690 ; return ( val_var, (val_var, val_expr) : binds) }
691
692 | otherwise -- General case (C)
693 = do { tuple_var <- newSysLocalDs tuple_ty
694 ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
695 ; tuple_expr <- matchSimply val_expr PatBindRhs pat
696 local_tuple error_expr
697 ; let mk_tup_bind tick binder
698 = (binder, mkOptTickBox tick $
699 mkTupleSelector1 local_binders binder
700 tuple_var (Var tuple_var))
701 tup_binds = zipWith mk_tup_bind ticks' binders
702 ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }
703 where
704 pat' = strip_bangs pat
705 -- Strip the bangs before looking for case (A) or (B)
706 -- The incoming pattern may well have a bang on it
707
708 binders = collectPatBinders pat'
709 ticks' = ticks ++ repeat []
710
711 local_binders = map localiseId binders -- See Note [Localise pattern binders]
712 local_tuple = mkBigCoreVarTup1 binders
713 tuple_ty = exprType local_tuple
714
715 strip_bangs :: LPat a -> LPat a
716 -- Remove outermost bangs and parens
717 strip_bangs (L _ (ParPat _ p)) = strip_bangs p
718 strip_bangs (L _ (BangPat _ p)) = strip_bangs p
719 strip_bangs lp = lp
720
721 is_flat_prod_lpat :: LPat a -> Bool
722 is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
723
724 is_flat_prod_pat :: Pat a -> Bool
725 is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p
726 is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
727 is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps})
728 | RealDataCon con <- pcon
729 , isProductTyCon (dataConTyCon con)
730 = all is_triv_lpat (hsConPatArgs ps)
731 is_flat_prod_pat _ = False
732
733 is_triv_lpat :: LPat a -> Bool
734 is_triv_lpat p = is_triv_pat (unLoc p)
735
736 is_triv_pat :: Pat a -> Bool
737 is_triv_pat (VarPat {}) = True
738 is_triv_pat (WildPat{}) = True
739 is_triv_pat (ParPat _ p) = is_triv_lpat p
740 is_triv_pat _ = False
741
742
743 {- *********************************************************************
744 * *
745 Creating big tuples and their types for full Haskell expressions.
746 They work over *Ids*, and create tuples replete with their types,
747 which is whey they are not in HsUtils.
748 * *
749 ********************************************************************* -}
750
751 mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
752 mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
753 mkLHsPatTup [lpat] = lpat
754 mkLHsPatTup lpats = L (getLoc (head lpats)) $
755 mkVanillaTuplePat lpats Boxed
756
757 mkLHsVarPatTup :: [Id] -> LPat GhcTc
758 mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
759
760 mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
761 -- A vanilla tuple pattern simply gets its type from its sub-patterns
762 mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
763
764 -- The Big equivalents for the source tuple expressions
765 mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
766 mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
767
768 mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc
769 mkBigLHsTupId = mkChunkified mkLHsTupleExpr
770
771 -- The Big equivalents for the source tuple patterns
772 mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc
773 mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)
774
775 mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
776 mkBigLHsPatTupId = mkChunkified mkLHsPatTup
777
778 {-
779 ************************************************************************
780 * *
781 Code for pattern-matching and other failures
782 * *
783 ************************************************************************
784
785 Generally, we handle pattern matching failure like this: let-bind a
786 fail-variable, and use that variable if the thing fails:
787 \begin{verbatim}
788 let fail.33 = error "Help"
789 in
790 case x of
791 p1 -> ...
792 p2 -> fail.33
793 p3 -> fail.33
794 p4 -> ...
795 \end{verbatim}
796 Then
797 \begin{itemize}
798 \item
799 If the case can't fail, then there'll be no mention of @fail.33@, and the
800 simplifier will later discard it.
801
802 \item
803 If it can fail in only one way, then the simplifier will inline it.
804
805 \item
806 Only if it is used more than once will the let-binding remain.
807 \end{itemize}
808
809 There's a problem when the result of the case expression is of
810 unboxed type. Then the type of @fail.33@ is unboxed too, and
811 there is every chance that someone will change the let into a case:
812 \begin{verbatim}
813 case error "Help" of
814 fail.33 -> case ....
815 \end{verbatim}
816
817 which is of course utterly wrong. Rather than drop the condition that
818 only boxed types can be let-bound, we just turn the fail into a function
819 for the primitive case:
820 \begin{verbatim}
821 let fail.33 :: Void -> Int#
822 fail.33 = \_ -> error "Help"
823 in
824 case x of
825 p1 -> ...
826 p2 -> fail.33 void
827 p3 -> fail.33 void
828 p4 -> ...
829 \end{verbatim}
830
831 Now @fail.33@ is a function, so it can be let-bound.
832
833 We would *like* to use join points here; in fact, these "fail variables" are
834 paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as
835 CPS functions - i.e. they take "join points" as parameters. It's not impossible
836 to imagine extending our type system to allow passing join points around (very
837 carefully), but we certainly don't support it now.
838
839 99.99% of the time, the fail variables wind up as join points in short order
840 anyway, and the Void# doesn't do much harm.
841 -}
842
843 mkFailurePair :: CoreExpr -- Result type of the whole case expression
844 -> DsM (CoreBind, -- Binds the newly-created fail variable
845 -- to \ _ -> expression
846 CoreExpr) -- Fail variable applied to realWorld#
847 -- See Note [Failure thunks and CPR]
848 mkFailurePair expr
849 = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty)
850 ; fail_fun_arg <- newSysLocalDs voidPrimTy
851 ; let real_arg = setOneShotLambda fail_fun_arg
852 ; return (NonRec fail_fun_var (Lam real_arg expr),
853 App (Var fail_fun_var) (Var voidPrimId)) }
854 where
855 ty = exprType expr
856
857 {-
858 Note [Failure thunks and CPR]
859 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
860 (This note predates join points as formal entities (hence the quotation marks).
861 We can't use actual join points here (see above); if we did, this would also
862 solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR
863 join points] in WorkWrap.)
864
865 When we make a failure point we ensure that it
866 does not look like a thunk. Example:
867
868 let fail = \rw -> error "urk"
869 in case x of
870 [] -> fail realWorld#
871 (y:ys) -> case ys of
872 [] -> fail realWorld#
873 (z:zs) -> (y,z)
874
875 Reason: we know that a failure point is always a "join point" and is
876 entered at most once. Adding a dummy 'realWorld' token argument makes
877 it clear that sharing is not an issue. And that in turn makes it more
878 CPR-friendly. This matters a lot: if you don't get it right, you lose
879 the tail call property. For example, see Trac #3403.
880
881
882 ************************************************************************
883 * *
884 Ticks
885 * *
886 ********************************************************************* -}
887
888 mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
889 mkOptTickBox = flip (foldr Tick)
890
891 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
892 mkBinaryTickBox ixT ixF e = do
893 uq <- newUnique
894 this_mod <- getModule
895 let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
896 let
897 falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
898 trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId)
899 --
900 return $ Case e bndr1 boolTy
901 [ (DataAlt falseDataCon, [], falseBox)
902 , (DataAlt trueDataCon, [], trueBox)
903 ]
904
905
906
907 -- *******************************************************************
908
909 {- Note [decideBangHood]
910 ~~~~~~~~~~~~~~~~~~~~~~~~
911 With -XStrict we may make /outermost/ patterns more strict.
912 E.g.
913 let (Just x) = e in ...
914 ==>
915 let !(Just x) = e in ...
916 and
917 f x = e
918 ==>
919 f !x = e
920
921 This adjustment is done by decideBangHood,
922
923 * Just before constructing an EqnInfo, in Match
924 (matchWrapper and matchSinglePat)
925
926 * When desugaring a pattern-binding in DsBinds.dsHsBind
927
928 Note that it is /not/ done recursively. See the -XStrict
929 spec in the user manual.
930
931 Specifically:
932 ~pat => pat -- when -XStrict (even if pat = ~pat')
933 !pat => !pat -- always
934 pat => !pat -- when -XStrict
935 pat => pat -- otherwise
936 -}
937
938
939 -- | Use -XStrict to add a ! or remove a ~
940 -- See Note [decideBangHood]
941 decideBangHood :: DynFlags
942 -> LPat GhcTc -- ^ Original pattern
943 -> LPat GhcTc -- Pattern with bang if necessary
944 decideBangHood dflags lpat
945 | not (xopt LangExt.Strict dflags)
946 = lpat
947 | otherwise -- -XStrict
948 = go lpat
949 where
950 go lp@(L l p)
951 = case p of
952 ParPat x p -> L l (ParPat x (go p))
953 LazyPat _ lp' -> lp'
954 BangPat _ _ -> lp
955 _ -> L l (BangPat noExt lp)
956
957 -- | Unconditionally make a 'Pat' strict.
958 addBang :: LPat GhcTc -- ^ Original pattern
959 -> LPat GhcTc -- ^ Banged pattern
960 addBang = go
961 where
962 go lp@(L l p)
963 = case p of
964 ParPat x p -> L l (ParPat x (go p))
965 LazyPat _ lp' -> L l (BangPat noExt lp')
966 -- Should we bring the extension value over?
967 BangPat _ _ -> lp
968 _ -> L l (BangPat noExt lp)