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