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