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