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