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