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