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