testsuite: don't collect compiler stats in collect_runtime_residency
[ghc.git] / compiler / deSugar / DsExpr.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Desugaring expressions.
7 -}
8
9 {-# LANGUAGE CPP, MultiWayIf #-}
10 {-# LANGUAGE TypeFamilies #-}
11 {-# LANGUAGE ViewPatterns #-}
12
13 module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
14 , dsValBinds, dsLit, dsSyntaxExpr ) where
15
16 #include "HsVersions.h"
17
18 import GhcPrelude
19
20 import Match
21 import MatchLit
22 import DsBinds
23 import DsGRHSs
24 import DsListComp
25 import DsUtils
26 import DsArrows
27 import DsMonad
28 import GHC.HsToCore.PmCheck ( checkGuardMatches )
29 import Name
30 import NameEnv
31 import FamInstEnv( topNormaliseType )
32 import DsMeta
33 import GHC.Hs
34
35 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
36 -- needs to see source types
37 import TcType
38 import TcEvidence
39 import TcRnMonad
40 import Type
41 import CoreSyn
42 import CoreUtils
43 import MkCore
44
45 import DynFlags
46 import CostCentre
47 import Id
48 import MkId
49 import Module
50 import ConLike
51 import DataCon
52 import TysWiredIn
53 import PrelNames
54 import BasicTypes
55 import Maybes
56 import VarEnv
57 import SrcLoc
58 import Util
59 import Bag
60 import Outputable
61 import PatSyn
62
63 import Control.Monad
64
65 {-
66 ************************************************************************
67 * *
68 dsLocalBinds, dsValBinds
69 * *
70 ************************************************************************
71 -}
72
73 dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
74 dsLocalBinds (dL->L _ (EmptyLocalBinds _)) body = return body
75 dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
76 dsValBinds binds body
77 dsLocalBinds (dL->L _ (HsIPBinds _ binds)) body = dsIPBinds binds body
78 dsLocalBinds _ _ = panic "dsLocalBinds"
79
80 -------------------------
81 -- caller sets location
82 dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
83 dsValBinds (XValBindsLR (NValBinds binds _)) body
84 = foldrM ds_val_bind body binds
85 dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
86
87 -------------------------
88 dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
89 dsIPBinds (IPBinds ev_binds ip_binds) body
90 = do { ds_binds <- dsTcEvBinds ev_binds
91 ; let inner = mkCoreLets ds_binds body
92 -- The dict bindings may not be in
93 -- dependency order; hence Rec
94 ; foldrM ds_ip_bind inner ip_binds }
95 where
96 ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body
97 = do e' <- dsLExpr e
98 return (Let (NonRec n e') body)
99 ds_ip_bind _ _ = panic "dsIPBinds"
100 dsIPBinds (XHsIPBinds nec) _ = noExtCon nec
101
102 -------------------------
103 -- caller sets location
104 ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
105 -- Special case for bindings which bind unlifted variables
106 -- We need to do a case right away, rather than building
107 -- a tuple and doing selections.
108 -- Silently ignore INLINE and SPECIALISE pragmas...
109 ds_val_bind (NonRecursive, hsbinds) body
110 | [dL->L loc bind] <- bagToList hsbinds
111 -- Non-recursive, non-overloaded bindings only come in ones
112 -- ToDo: in some bizarre case it's conceivable that there
113 -- could be dict binds in the 'binds'. (See the notes
114 -- below. Then pattern-match would fail. Urk.)
115 , isUnliftedHsBind bind
116 = putSrcSpanDs loc $
117 -- see Note [Strict binds checks] in DsBinds
118 if is_polymorphic bind
119 then errDsCoreExpr (poly_bind_err bind)
120 -- data Ptr a = Ptr Addr#
121 -- f x = let p@(Ptr y) = ... in ...
122 -- Here the binding for 'p' is polymorphic, but does
123 -- not mix with an unlifted binding for 'y'. You should
124 -- use a bang pattern. #6078.
125
126 else do { when (looksLazyPatBind bind) $
127 warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)
128 -- Complain about a binding that looks lazy
129 -- e.g. let I# y = x in ...
130 -- Remember, in checkStrictBinds we are going to do strict
131 -- matching, so (for software engineering reasons) we insist
132 -- that the strictness is manifest on each binding
133 -- However, lone (unboxed) variables are ok
134
135
136 ; dsUnliftedBind bind body }
137 where
138 is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
139 = not (null tvs && null evs)
140 is_polymorphic _ = False
141
142 unlifted_must_be_bang bind
143 = hang (text "Pattern bindings containing unlifted types should use" $$
144 text "an outermost bang pattern:")
145 2 (ppr bind)
146
147 poly_bind_err bind
148 = hang (text "You can't mix polymorphic and unlifted bindings:")
149 2 (ppr bind) $$
150 text "Probable fix: add a type signature"
151
152 ds_val_bind (is_rec, binds) _body
153 | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in DsBinds
154 = ASSERT( isRec is_rec )
155 errDsCoreExpr $
156 hang (text "Recursive bindings for unlifted types aren't allowed:")
157 2 (vcat (map ppr (bagToList binds)))
158
159 -- Ordinary case for bindings; none should be unlifted
160 ds_val_bind (is_rec, binds) body
161 = do { MASSERT( isRec is_rec || isSingletonBag binds )
162 -- we should never produce a non-recursive list of multiple binds
163
164 ; (force_vars,prs) <- dsLHsBinds binds
165 ; let body' = foldr seqVar body force_vars
166 ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
167 case prs of
168 [] -> return body
169 _ -> return (Let (Rec prs) body') }
170 -- Use a Rec regardless of is_rec.
171 -- Why? Because it allows the binds to be all
172 -- mixed up, which is what happens in one rare case
173 -- Namely, for an AbsBind with no tyvars and no dicts,
174 -- but which does have dictionary bindings.
175 -- See notes with TcSimplify.inferLoop [NO TYVARS]
176 -- It turned out that wrapping a Rec here was the easiest solution
177 --
178 -- NB The previous case dealt with unlifted bindings, so we
179 -- only have to deal with lifted ones now; so Rec is ok
180
181 ------------------
182 dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
183 dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
184 , abs_exports = exports
185 , abs_ev_binds = ev_binds
186 , abs_binds = lbinds }) body
187 = do { let body1 = foldr bind_export body exports
188 bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
189 ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
190 body1 lbinds
191 ; ds_binds <- dsTcEvBinds_s ev_binds
192 ; return (mkCoreLets ds_binds body2) }
193
194 dsUnliftedBind (FunBind { fun_id = (dL->L l fun)
195 , fun_matches = matches
196 , fun_co_fn = co_fn
197 , fun_tick = tick }) body
198 -- Can't be a bang pattern (that looks like a PatBind)
199 -- so must be simply unboxed
200 = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun))
201 Nothing matches
202 ; MASSERT( null args ) -- Functions aren't lifted
203 ; MASSERT( isIdHsWrapper co_fn )
204 ; let rhs' = mkOptTickBox tick rhs
205 ; return (bindNonRec fun rhs' body) }
206
207 dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
208 , pat_ext = NPatBindTc _ ty }) body
209 = -- let C x# y# = rhs in body
210 -- ==> case rhs of C x# y# -> body
211 do { rhs <- dsGuarded grhss ty
212 ; checkGuardMatches PatBindGuards grhss
213 ; let upat = unLoc pat
214 eqn = EqnInfo { eqn_pats = [upat],
215 eqn_orig = FromSource,
216 eqn_rhs = cantFailMatchResult body }
217 ; var <- selectMatchVar upat
218 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
219 ; return (bindNonRec var rhs result) }
220
221 dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
222
223 {-
224 ************************************************************************
225 * *
226 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
227 * *
228 ************************************************************************
229 -}
230
231 dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
232
233 dsLExpr (dL->L loc e)
234 = putSrcSpanDs loc $
235 do { core_expr <- dsExpr e
236 -- uncomment this check to test the hsExprType function in TcHsSyn
237 -- ; MASSERT2( exprType core_expr `eqType` hsExprType e
238 -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$
239 -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )
240 ; return core_expr }
241
242 -- | Variant of 'dsLExpr' that ensures that the result is not levity
243 -- polymorphic. This should be used when the resulting expression will
244 -- be an argument to some other function.
245 -- See Note [Levity polymorphism checking] in DsMonad
246 -- See Note [Levity polymorphism invariants] in CoreSyn
247 dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
248 dsLExprNoLP (dL->L loc e)
249 = putSrcSpanDs loc $
250 do { e' <- dsExpr e
251 ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
252 ; return e' }
253
254 dsExpr :: HsExpr GhcTc -> DsM CoreExpr
255 dsExpr = ds_expr False
256
257 ds_expr :: Bool -- are we directly inside an HsWrap?
258 -- See Wrinkle in Note [Detecting forced eta expansion]
259 -> HsExpr GhcTc -> DsM CoreExpr
260 ds_expr _ (HsPar _ e) = dsLExpr e
261 ds_expr _ (ExprWithTySig _ e _) = dsLExpr e
262 ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var
263 ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
264 ds_expr w (HsConLikeOut _ con) = dsConLike w con
265 ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar"
266 ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel"
267
268 ds_expr _ (HsLit _ lit)
269 = do { warnAboutOverflowedLit lit
270 ; dsLit (convertLit lit) }
271
272 ds_expr _ (HsOverLit _ lit)
273 = do { warnAboutOverflowedOverLit lit
274 ; dsOverLit lit }
275
276 ds_expr _ (HsWrap _ co_fn e)
277 = do { e' <- ds_expr True e -- This is the one place where we recurse to
278 -- ds_expr (passing True), rather than dsExpr
279 ; wrap' <- dsHsWrapper co_fn
280 ; dflags <- getDynFlags
281 ; let wrapped_e = wrap' e'
282 wrapped_ty = exprType wrapped_e
283 ; checkForcedEtaExpansion e wrapped_ty -- See Note [Detecting forced eta expansion]
284 ; warnAboutIdentities dflags e' wrapped_ty
285 ; return wrapped_e }
286
287 ds_expr _ (NegApp _ (dL->L loc
288 (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
289 neg_expr)
290 = do { expr' <- putSrcSpanDs loc $ do
291 { warnAboutOverflowedOverLit
292 (lit { ol_val = HsIntegral (negateIntegralLit i) })
293 ; dsOverLit lit }
294 ; dsSyntaxExpr neg_expr [expr'] }
295
296 ds_expr _ (NegApp _ expr neg_expr)
297 = do { expr' <- dsLExpr expr
298 ; dsSyntaxExpr neg_expr [expr'] }
299
300 ds_expr _ (HsLam _ a_Match)
301 = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
302
303 ds_expr _ (HsLamCase _ matches)
304 = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
305 ; return $ Lam discrim_var matching_code }
306
307 ds_expr _ e@(HsApp _ fun arg)
308 = do { fun' <- dsLExpr fun
309 ; dsWhenNoErrs (dsLExprNoLP arg)
310 (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
311
312 ds_expr _ (HsAppType _ e _)
313 -- ignore type arguments here; they're in the wrappers instead at this point
314 = dsLExpr e
315
316 {-
317 Note [Desugaring vars]
318 ~~~~~~~~~~~~~~~~~~~~~~
319 In one situation we can get a *coercion* variable in a HsVar, namely
320 the support method for an equality superclass:
321 class (a~b) => C a b where ...
322 instance (blah) => C (T a) (T b) where ..
323 Then we get
324 $dfCT :: forall ab. blah => C (T a) (T b)
325 $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
326
327 $c$p1C :: forall ab. blah => (T a ~ T b)
328 $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
329
330 That 'g' in the 'in' part is an evidence variable, and when
331 converting to core it must become a CO.
332
333 Operator sections. At first it looks as if we can convert
334 \begin{verbatim}
335 (expr op)
336 \end{verbatim}
337 to
338 \begin{verbatim}
339 \x -> op expr x
340 \end{verbatim}
341
342 But no! expr might be a redex, and we can lose laziness badly this
343 way. Consider
344 \begin{verbatim}
345 map (expr op) xs
346 \end{verbatim}
347 for example. So we convert instead to
348 \begin{verbatim}
349 let y = expr in \x -> op y x
350 \end{verbatim}
351 If \tr{expr} is actually just a variable, say, then the simplifier
352 will sort it out.
353 -}
354
355 ds_expr _ e@(OpApp _ e1 op e2)
356 = -- for the type of y, we need the type of op's 2nd argument
357 do { op' <- dsLExpr op
358 ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
359 (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
360
361 ds_expr _ (SectionL _ expr op) -- Desugar (e !) to ((!) e)
362 = do { op' <- dsLExpr op
363 ; dsWhenNoErrs (dsLExprNoLP expr)
364 (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
365
366 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
367 ds_expr _ e@(SectionR _ op expr) = do
368 core_op <- dsLExpr op
369 -- for the type of x, we need the type of op's 2nd argument
370 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
371 -- See comment with SectionL
372 y_core <- dsLExpr expr
373 dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
374 (\[x_id, y_id] -> bindNonRec y_id y_core $
375 Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
376 core_op [Var x_id, Var y_id]))
377
378 ds_expr _ (ExplicitTuple _ tup_args boxity)
379 = do { let go (lam_vars, args) (dL->L _ (Missing ty))
380 -- For every missing expression, we need
381 -- another lambda in the desugaring.
382 = do { lam_var <- newSysLocalDsNoLP ty
383 ; return (lam_var : lam_vars, Var lam_var : args) }
384 go (lam_vars, args) (dL->L _ (Present _ expr))
385 -- Expressions that are present don't generate
386 -- lambdas, just arguments.
387 = do { core_expr <- dsLExprNoLP expr
388 ; return (lam_vars, core_expr : args) }
389 go _ _ = panic "ds_expr"
390
391 ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
392 -- The reverse is because foldM goes left-to-right
393 (\(lam_vars, args) -> mkCoreLams lam_vars $
394 mkCoreTupBoxity boxity args) }
395 -- See Note [Don't flatten tuples from HsSyn] in MkCore
396
397 ds_expr _ (ExplicitSum types alt arity expr)
398 = do { dsWhenNoErrs (dsLExprNoLP expr)
399 (\core_expr -> mkCoreConApps (sumDataCon alt arity)
400 (map (Type . getRuntimeRep) types ++
401 map Type types ++
402 [core_expr]) ) }
403
404 ds_expr _ (HsSCC _ _ cc expr@(dL->L loc _)) = do
405 dflags <- getDynFlags
406 if gopt Opt_SccProfilingOn dflags
407 then do
408 mod_name <- getModule
409 count <- goptM Opt_ProfCountEntries
410 let nm = sl_fs cc
411 flavour <- ExprCC <$> getCCIndexM nm
412 Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True)
413 <$> dsLExpr expr
414 else dsLExpr expr
415
416 ds_expr _ (HsCoreAnn _ _ _ expr)
417 = dsLExpr expr
418
419 ds_expr _ (HsCase _ discrim matches)
420 = do { core_discrim <- dsLExpr discrim
421 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
422 ; return (bindNonRec discrim_var core_discrim matching_code) }
423
424 -- Pepe: The binds are in scope in the body but NOT in the binding group
425 -- This is to avoid silliness in breakpoints
426 ds_expr _ (HsLet _ binds body) = do
427 body' <- dsLExpr body
428 dsLocalBinds binds body'
429
430 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
431 -- because the interpretation of `stmts' depends on what sort of thing it is.
432 --
433 ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty
434 ds_expr _ (HsDo _ DoExpr (dL->L _ stmts)) = dsDo stmts
435 ds_expr _ (HsDo _ GhciStmtCtxt (dL->L _ stmts)) = dsDo stmts
436 ds_expr _ (HsDo _ MDoExpr (dL->L _ stmts)) = dsDo stmts
437 ds_expr _ (HsDo _ MonadComp (dL->L _ stmts)) = dsMonadComp stmts
438
439 ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr)
440 = do { pred <- dsLExpr guard_expr
441 ; b1 <- dsLExpr then_expr
442 ; b2 <- dsLExpr else_expr
443 ; case mb_fun of
444 Just fun -> dsSyntaxExpr fun [pred, b1, b2]
445 Nothing -> return $ mkIfThenElse pred b1 b2 }
446
447 ds_expr _ (HsMultiIf res_ty alts)
448 | null alts
449 = mkErrorExpr
450
451 | otherwise
452 = do { match_result <- liftM (foldr1 combineMatchResults)
453 (mapM (dsGRHS IfAlt res_ty) alts)
454 ; checkGuardMatches IfAlt (GRHSs noExtField alts (noLoc emptyLocalBinds))
455 ; error_expr <- mkErrorExpr
456 ; extractMatchResult match_result error_expr }
457 where
458 mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
459 (text "multi-way if")
460
461 {-
462 \noindent
463 \underline{\bf Various data construction things}
464 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
465 -}
466
467 ds_expr _ (ExplicitList elt_ty wit xs)
468 = dsExplicitList elt_ty wit xs
469
470 ds_expr _ (ArithSeq expr witness seq)
471 = case witness of
472 Nothing -> dsArithSeq expr seq
473 Just fl -> do { newArithSeq <- dsArithSeq expr seq
474 ; dsSyntaxExpr fl [newArithSeq] }
475
476 {-
477 Static Pointers
478 ~~~~~~~~~~~~~~~
479
480 See Note [Grand plan for static forms] in StaticPtrTable for an overview.
481
482 g = ... static f ...
483 ==>
484 g = ... makeStatic loc f ...
485 -}
486
487 ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do
488 expr_ds <- dsLExprNoLP expr
489 let ty = exprType expr_ds
490 makeStaticId <- dsLookupGlobalId makeStaticName
491
492 dflags <- getDynFlags
493 let (line, col) = case loc of
494 RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
495 , srcLocCol $ realSrcSpanStart r
496 )
497 _ -> (0, 0)
498 srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
499 [ Type intTy , Type intTy
500 , mkIntExprInt dflags line, mkIntExprInt dflags col
501 ]
502
503 putSrcSpanDs loc $ return $
504 mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
505
506 {-
507 \noindent
508 \underline{\bf Record construction and update}
509 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
510 For record construction we do this (assuming T has three arguments)
511 \begin{verbatim}
512 T { op2 = e }
513 ==>
514 let err = /\a -> recConErr a
515 T (recConErr t1 "M.hs/230/op1")
516 e
517 (recConErr t1 "M.hs/230/op3")
518 \end{verbatim}
519 @recConErr@ then converts its argument string into a proper message
520 before printing it as
521 \begin{verbatim}
522 M.hs, line 230: missing field op1 was evaluated
523 \end{verbatim}
524
525 We also handle @C{}@ as valid construction syntax for an unlabelled
526 constructor @C@, setting all of @C@'s fields to bottom.
527 -}
528
529 ds_expr _ (RecordCon { rcon_flds = rbinds
530 , rcon_ext = RecordConTc { rcon_con_expr = con_expr
531 , rcon_con_like = con_like }})
532 = do { con_expr' <- dsExpr con_expr
533 ; let
534 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
535 -- A newtype in the corner should be opaque;
536 -- hence TcType.tcSplitFunTys
537
538 mk_arg (arg_ty, fl)
539 = case findField (rec_flds rbinds) (flSelector fl) of
540 (rhs:rhss) -> ASSERT( null rhss )
541 dsLExprNoLP rhs
542 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
543 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
544
545 labels = conLikeFieldLabels con_like
546
547 ; con_args <- if null labels
548 then mapM unlabelled_bottom arg_tys
549 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
550
551 ; return (mkCoreApps con_expr' con_args) }
552
553 {-
554 Record update is a little harder. Suppose we have the decl:
555 \begin{verbatim}
556 data T = T1 {op1, op2, op3 :: Int}
557 | T2 {op4, op2 :: Int}
558 | T3
559 \end{verbatim}
560 Then we translate as follows:
561 \begin{verbatim}
562 r { op2 = e }
563 ===>
564 let op2 = e in
565 case r of
566 T1 op1 _ op3 -> T1 op1 op2 op3
567 T2 op4 _ -> T2 op4 op2
568 other -> recUpdError "M.hs/230"
569 \end{verbatim}
570 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
571 RHSs, and do not generate a Core constructor application directly, because the constructor
572 might do some argument-evaluation first; and may have to throw away some
573 dictionaries.
574
575 Note [Update for GADTs]
576 ~~~~~~~~~~~~~~~~~~~~~~~
577 Consider
578 data T a b where
579 T1 :: { f1 :: a } -> T a Int
580
581 Then the wrapper function for T1 has type
582 $WT1 :: a -> T a Int
583 But if x::T a b, then
584 x { f1 = v } :: T a b (not T a Int!)
585 So we need to cast (T a Int) to (T a b). Sigh.
586
587 -}
588
589 ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
590 , rupd_ext = RecordUpdTc
591 { rupd_cons = cons_to_upd
592 , rupd_in_tys = in_inst_tys
593 , rupd_out_tys = out_inst_tys
594 , rupd_wrap = dict_req_wrap }} )
595 | null fields
596 = dsLExpr record_expr
597 | otherwise
598 = ASSERT2( notNull cons_to_upd, ppr expr )
599
600 do { record_expr' <- dsLExpr record_expr
601 ; field_binds' <- mapM ds_field fields
602 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
603 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
604
605 -- It's important to generate the match with matchWrapper,
606 -- and the right hand sides with applications of the wrapper Id
607 -- so that everything works when we are doing fancy unboxing on the
608 -- constructor arguments.
609 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
610 ; ([discrim_var], matching_code)
611 <- matchWrapper RecUpd Nothing
612 (MG { mg_alts = noLoc alts
613 , mg_ext = MatchGroupTc [in_ty] out_ty
614 , mg_origin = FromSource })
615 -- FromSource is not strictly right, but we
616 -- want incomplete pattern-match warnings
617
618 ; return (add_field_binds field_binds' $
619 bindNonRec discrim_var record_expr' matching_code) }
620 where
621 ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
622 -- Clone the Id in the HsRecField, because its Name is that
623 -- of the record selector, and we must not make that a local binder
624 -- else we shadow other uses of the record selector
625 -- Hence 'lcl_id'. Cf #2735
626 ds_field (dL->L _ rec_field)
627 = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
628 ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
629 ; lcl_id <- newSysLocalDs (idType fld_id)
630 ; return (idName fld_id, lcl_id, rhs) }
631
632 add_field_binds [] expr = expr
633 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
634
635 -- Awkwardly, for families, the match goes
636 -- from instance type to family type
637 (in_ty, out_ty) =
638 case (head cons_to_upd) of
639 RealDataCon data_con ->
640 let tycon = dataConTyCon data_con in
641 (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)
642 PatSynCon pat_syn ->
643 ( patSynInstResTy pat_syn in_inst_tys
644 , patSynInstResTy pat_syn out_inst_tys)
645 mk_alt upd_fld_env con
646 = do { let (univ_tvs, ex_tvs, eq_spec,
647 prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
648 user_tvs =
649 case con of
650 RealDataCon data_con -> dataConUserTyVars data_con
651 PatSynCon _ -> univ_tvs ++ ex_tvs
652 -- The order here is because of the order in `TcPatSyn`.
653 in_subst = zipTvSubst univ_tvs in_inst_tys
654 out_subst = zipTvSubst univ_tvs out_inst_tys
655
656 -- I'm not bothering to clone the ex_tvs
657 ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))
658 ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)
659 ; arg_ids <- newSysLocalsDs (substTysUnchecked in_subst arg_tys)
660 ; let field_labels = conLikeFieldLabels con
661 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
662 field_labels arg_ids
663 mk_val_arg fl pat_arg_id
664 = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
665
666 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con)
667 -- Reconstruct with the WrapId so that unpacking happens
668 wrap = mkWpEvVarApps theta_vars <.>
669 dict_req_wrap <.>
670 mkWpTyApps [ lookupTyVar out_subst tv
671 `orElse` mkTyVarTy tv
672 | tv <- user_tvs
673 , not (tv `elemVarEnv` wrap_subst) ]
674 -- Be sure to use user_tvs (which may be ordered
675 -- differently than `univ_tvs ++ ex_tvs) above.
676 -- See Note [DataCon user type variable binders]
677 -- in DataCon.
678 rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args
679
680 -- Tediously wrap the application in a cast
681 -- Note [Update for GADTs]
682 wrapped_rhs =
683 case con of
684 RealDataCon data_con ->
685 let
686 wrap_co =
687 mkTcTyConAppCo Nominal
688 (dataConTyCon data_con)
689 [ lookup tv ty
690 | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
691 lookup univ_tv ty =
692 case lookupVarEnv wrap_subst univ_tv of
693 Just co' -> co'
694 Nothing -> mkTcReflCo Nominal ty
695 in if null eq_spec
696 then rhs
697 else mkLHsWrap (mkWpCastN wrap_co) rhs
698 -- eq_spec is always null for a PatSynCon
699 PatSynCon _ -> rhs
700
701 wrap_subst =
702 mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
703 | (spec, eq_var) <- eq_spec `zip` eqs_vars
704 , let tv = eqSpecTyVar spec ]
705
706 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
707
708 pat = noLoc $ ConPatOut { pat_con = noLoc con
709 , pat_tvs = ex_tvs
710 , pat_dicts = eqs_vars ++ theta_vars
711 , pat_binds = emptyTcEvBinds
712 , pat_args = PrefixCon $ map nlVarPat arg_ids
713 , pat_arg_tys = in_inst_tys
714 , pat_wrap = req_wrap }
715 ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
716
717 -- Here is where we desugar the Template Haskell brackets and escapes
718
719 -- Template Haskell stuff
720
721 ds_expr _ (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut"
722 ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps
723 ds_expr _ (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
724
725 -- Arrow notation extension
726 ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd
727
728 -- Hpc Support
729
730 ds_expr _ (HsTick _ tickish e) = do
731 e' <- dsLExpr e
732 return (Tick tickish e')
733
734 -- There is a problem here. The then and else branches
735 -- have no free variables, so they are open to lifting.
736 -- We need someway of stopping this.
737 -- This will make no difference to binary coverage
738 -- (did you go here: YES or NO), but will effect accurate
739 -- tick counting.
740
741 ds_expr _ (HsBinTick _ ixT ixF e) = do
742 e2 <- dsLExpr e
743 do { ASSERT(exprType e2 `eqType` boolTy)
744 mkBinaryTickBox ixT ixF e2
745 }
746
747 ds_expr _ (HsTickPragma _ _ _ _ expr) = do
748 dflags <- getDynFlags
749 if gopt Opt_Hpc dflags
750 then panic "dsExpr:HsTickPragma"
751 else dsLExpr expr
752
753 -- HsSyn constructs that just shouldn't be here:
754 ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket"
755 ds_expr _ (HsDo {}) = panic "dsExpr:HsDo"
756 ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld"
757 ds_expr _ (XExpr nec) = noExtCon nec
758
759
760 ------------------------------
761 dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
762 dsSyntaxExpr (SyntaxExpr { syn_expr = expr
763 , syn_arg_wraps = arg_wraps
764 , syn_res_wrap = res_wrap })
765 arg_exprs
766 = do { fun <- dsExpr expr
767 ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
768 ; core_res_wrap <- dsHsWrapper res_wrap
769 ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
770 ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
771 (\_ -> core_res_wrap (mkApps fun wrapped_args)) }
772 where
773 mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
774
775 findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
776 findField rbinds sel
777 = [hsRecFieldArg fld | (dL->L _ fld) <- rbinds
778 , sel == idName (unLoc $ hsRecFieldId fld) ]
779
780 {-
781 %--------------------------------------------------------------------
782
783 Note [Desugaring explicit lists]
784 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
785 Explicit lists are desugared in a cleverer way to prevent some
786 fruitless allocations. Essentially, whenever we see a list literal
787 [x_1, ..., x_n] we generate the corresponding expression in terms of
788 build:
789
790 Explicit lists (literals) are desugared to allow build/foldr fusion when
791 beneficial. This is a bit of a trade-off,
792
793 * build/foldr fusion can generate far larger code than the corresponding
794 cons-chain (e.g. see #11707)
795
796 * even when it doesn't produce more code, build can still fail to fuse,
797 requiring that the simplifier do more work to bring the expression
798 back into cons-chain form; this costs compile time
799
800 * when it works, fusion can be a significant win. Allocations are reduced
801 by up to 25% in some nofib programs. Specifically,
802
803 Program Size Allocs Runtime CompTime
804 rewrite +0.0% -26.3% 0.02 -1.8%
805 ansi -0.3% -13.8% 0.00 +0.0%
806 lift +0.0% -8.7% 0.00 -2.3%
807
808 At the moment we use a simple heuristic to determine whether build will be
809 fruitful: for small lists we assume the benefits of fusion will be worthwhile;
810 for long lists we assume that the benefits will be outweighted by the cost of
811 code duplication. This magic length threshold is @maxBuildLength@. Also, fusion
812 won't work at all if rewrite rules are disabled, so we don't use the build-based
813 desugaring in this case.
814
815 We used to have a more complex heuristic which would try to break the list into
816 "static" and "dynamic" parts and only build-desugar the dynamic part.
817 Unfortunately, determining "static-ness" reliably is a bit tricky and the
818 heuristic at times produced surprising behavior (see #11710) so it was dropped.
819 -}
820
821 {- | The longest list length which we will desugar using @build@.
822
823 This is essentially a magic number and its setting is unfortunate rather
824 arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],
825 is to avoid deforesting large static data into large(r) code. Ideally we'd
826 want a smaller threshold with larger consumers and vice-versa, but we have no
827 way of knowing what will be consuming our list in the desugaring impossible to
828 set generally correctly.
829
830 The effect of reducing this number will be that 'build' fusion is applied
831 less often. From a runtime performance perspective, applying 'build' more
832 liberally on "moderately" sized lists should rarely hurt and will often it can
833 only expose further optimization opportunities; if no fusion is possible it will
834 eventually get rule-rewritten back to a list). We do, however, pay in compile
835 time.
836 -}
837 maxBuildLength :: Int
838 maxBuildLength = 32
839
840 dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc]
841 -> DsM CoreExpr
842 -- See Note [Desugaring explicit lists]
843 dsExplicitList elt_ty Nothing xs
844 = do { dflags <- getDynFlags
845 ; xs' <- mapM dsLExprNoLP xs
846 ; if xs' `lengthExceeds` maxBuildLength
847 -- Don't generate builds if the list is very long.
848 || null xs'
849 -- Don't generate builds when the [] constructor will do
850 || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
851 -- Don't generate a build if there are no rules to eliminate it!
852 -- See Note [Desugaring RULE left hand sides] in Desugar
853 then return $ mkListExpr elt_ty xs'
854 else mkBuildExpr elt_ty (mk_build_list xs') }
855 where
856 mk_build_list xs' (cons, _) (nil, _)
857 = return (foldr (App . App (Var cons)) (Var nil) xs')
858
859 dsExplicitList elt_ty (Just fln) xs
860 = do { list <- dsExplicitList elt_ty Nothing xs
861 ; dflags <- getDynFlags
862 ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }
863
864 dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
865 dsArithSeq expr (From from)
866 = App <$> dsExpr expr <*> dsLExprNoLP from
867 dsArithSeq expr (FromTo from to)
868 = do dflags <- getDynFlags
869 warnAboutEmptyEnumerations dflags from Nothing to
870 expr' <- dsExpr expr
871 from' <- dsLExprNoLP from
872 to' <- dsLExprNoLP to
873 return $ mkApps expr' [from', to']
874 dsArithSeq expr (FromThen from thn)
875 = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]
876 dsArithSeq expr (FromThenTo from thn to)
877 = do dflags <- getDynFlags
878 warnAboutEmptyEnumerations dflags from (Just thn) to
879 expr' <- dsExpr expr
880 from' <- dsLExprNoLP from
881 thn' <- dsLExprNoLP thn
882 to' <- dsLExprNoLP to
883 return $ mkApps expr' [from', thn', to']
884
885 {-
886 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
887 handled in DsListComp). Basically does the translation given in the
888 Haskell 98 report:
889 -}
890
891 dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr
892 dsDo stmts
893 = goL stmts
894 where
895 goL [] = panic "dsDo"
896 goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
897
898 go _ (LastStmt _ body _ _) stmts
899 = ASSERT( null stmts ) dsLExpr body
900 -- The 'return' op isn't used for 'do' expressions
901
902 go _ (BodyStmt _ rhs then_expr _) stmts
903 = do { rhs2 <- dsLExpr rhs
904 ; warnDiscardedDoBindings rhs (exprType rhs2)
905 ; rest <- goL stmts
906 ; dsSyntaxExpr then_expr [rhs2, rest] }
907
908 go _ (LetStmt _ binds) stmts
909 = do { rest <- goL stmts
910 ; dsLocalBinds binds rest }
911
912 go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts
913 = do { body <- goL stmts
914 ; rhs' <- dsLExpr rhs
915 ; var <- selectSimpleMatchVarL pat
916 ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
917 res1_ty (cantFailMatchResult body)
918 ; match_code <- handle_failure pat match fail_op
919 ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
920
921 go _ (ApplicativeStmt body_ty args mb_join) stmts
922 = do {
923 let
924 (pats, rhss) = unzip (map (do_arg . snd) args)
925
926 do_arg (ApplicativeArgOne _ pat expr _ fail_op) =
927 ((pat, fail_op), dsLExpr expr)
928 do_arg (ApplicativeArgMany _ stmts ret pat) =
929 ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
930 do_arg (XApplicativeArg nec) = noExtCon nec
931
932 ; rhss' <- sequence rhss
933
934 ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts)
935
936 ; let match_args (pat, fail_op) (vs,body)
937 = do { var <- selectSimpleMatchVarL pat
938 ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
939 body_ty (cantFailMatchResult body)
940 ; match_code <- handle_failure pat match fail_op
941 ; return (var:vs, match_code)
942 }
943
944 ; (vars, body) <- foldrM match_args ([],body') pats
945 ; let fun' = mkLams vars body
946 ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
947 ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
948 ; case mb_join of
949 Nothing -> return expr
950 Just join_op -> dsSyntaxExpr join_op [expr] }
951
952 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
953 , recS_rec_ids = rec_ids, recS_ret_fn = return_op
954 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
955 , recS_ext = RecStmtTc
956 { recS_bind_ty = bind_ty
957 , recS_rec_rets = rec_rets
958 , recS_ret_ty = body_ty} }) stmts
959 = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
960 where
961 new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
962 mfix_app bind_op
963 noSyntaxExpr -- Tuple cannot fail
964
965 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
966 tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
967 rec_tup_pats = map nlVarPat tup_ids
968 later_pats = rec_tup_pats
969 rets = map noLoc rec_rets
970 mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
971 mfix_arg = noLoc $ HsLam noExtField
972 (MG { mg_alts = noLoc [mkSimpleMatch
973 LambdaExpr
974 [mfix_pat] body]
975 , mg_ext = MatchGroupTc [tup_ty] body_ty
976 , mg_origin = Generated })
977 mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
978 body = noLoc $ HsDo body_ty
979 DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
980 ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
981 ret_stmt = noLoc $ mkLastStmt ret_app
982 -- This LastStmt will be desugared with dsDo,
983 -- which ignores the return_op in the LastStmt,
984 -- so we must apply the return_op explicitly
985
986 go _ (ParStmt {}) _ = panic "dsDo ParStmt"
987 go _ (TransStmt {}) _ = panic "dsDo TransStmt"
988 go _ (XStmtLR nec) _ = noExtCon nec
989
990 handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
991 -- In a do expression, pattern-match failure just calls
992 -- the monadic 'fail' rather than throwing an exception
993 handle_failure pat match fail_op
994 | matchCanFail match
995 = do { dflags <- getDynFlags
996 ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
997 ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
998 ; extractMatchResult match fail_expr }
999 | otherwise
1000 = extractMatchResult match (error "It can't fail")
1001
1002 mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
1003 mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
1004 showPpr dflags (getLoc pat)
1005
1006 {-
1007 ************************************************************************
1008 * *
1009 Desugaring Variables
1010 * *
1011 ************************************************************************
1012 -}
1013
1014 dsHsVar :: Bool -- are we directly inside an HsWrap?
1015 -- See Wrinkle in Note [Detecting forced eta expansion]
1016 -> Id -> DsM CoreExpr
1017 dsHsVar w var
1018 | not w
1019 , let bad_tys = badUseOfLevPolyPrimop var ty
1020 , not (null bad_tys)
1021 = do { levPolyPrimopErr var ty bad_tys
1022 ; return unitExpr } -- return something eminently safe
1023
1024 | otherwise
1025 = return (varToCoreExpr var) -- See Note [Desugaring vars]
1026
1027 where
1028 ty = idType var
1029
1030 dsConLike :: Bool -- as in dsHsVar
1031 -> ConLike -> DsM CoreExpr
1032 dsConLike w (RealDataCon dc) = dsHsVar w (dataConWrapId dc)
1033 dsConLike _ (PatSynCon ps) = return $ case patSynBuilder ps of
1034 Just (id, add_void)
1035 | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)
1036 | otherwise -> Var id
1037 _ -> pprPanic "dsConLike" (ppr ps)
1038
1039 {-
1040 ************************************************************************
1041 * *
1042 \subsection{Errors and contexts}
1043 * *
1044 ************************************************************************
1045 -}
1046
1047 -- Warn about certain types of values discarded in monadic bindings (#3263)
1048 warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
1049 warnDiscardedDoBindings rhs rhs_ty
1050 | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
1051 = do { warn_unused <- woptM Opt_WarnUnusedDoBind
1052 ; warn_wrong <- woptM Opt_WarnWrongDoBind
1053 ; when (warn_unused || warn_wrong) $
1054 do { fam_inst_envs <- dsGetFamInstEnvs
1055 ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
1056
1057 -- Warn about discarding non-() things in 'monadic' binding
1058 ; if warn_unused && not (isUnitTy norm_elt_ty)
1059 then warnDs (Reason Opt_WarnUnusedDoBind)
1060 (badMonadBind rhs elt_ty)
1061 else
1062
1063 -- Warn about discarding m a things in 'monadic' binding of the same type,
1064 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
1065 when warn_wrong $
1066 do { case tcSplitAppTy_maybe norm_elt_ty of
1067 Just (elt_m_ty, _)
1068 | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
1069 -> warnDs (Reason Opt_WarnWrongDoBind)
1070 (badMonadBind rhs elt_ty)
1071 _ -> return () } } }
1072
1073 | otherwise -- RHS does have type of form (m ty), which is weird
1074 = return () -- but at lesat this warning is irrelevant
1075
1076 badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
1077 badMonadBind rhs elt_ty
1078 = vcat [ hang (text "A do-notation statement discarded a result of type")
1079 2 (quotes (ppr elt_ty))
1080 , hang (text "Suppress this warning by saying")
1081 2 (quotes $ text "_ <-" <+> ppr rhs)
1082 ]
1083
1084 {-
1085 ************************************************************************
1086 * *
1087 Forced eta expansion and levity polymorphism
1088 * *
1089 ************************************************************************
1090
1091 Note [Detecting forced eta expansion]
1092 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1093 We cannot have levity polymorphic function arguments. See
1094 Note [Levity polymorphism invariants] in CoreSyn. But we *can* have
1095 functions that take levity polymorphic arguments, as long as these
1096 functions are eta-reduced. (See #12708 for an example.)
1097
1098 However, we absolutely cannot do this for functions that have no
1099 binding (i.e., say True to Id.hasNoBinding), like primops and unboxed
1100 tuple constructors. These get eta-expanded in CorePrep.maybeSaturate.
1101
1102 Detecting when this is about to happen is a bit tricky, though. When
1103 the desugarer is looking at the Id itself (let's be concrete and
1104 suppose we have (#,#)), we don't know whether it will be levity
1105 polymorphic. So the right spot seems to be to look after the Id has
1106 been applied to its type arguments. To make the algorithm efficient,
1107 it's important to be able to spot ((#,#) @a @b @c @d) without looking
1108 past all the type arguments. We thus require that
1109 * The body of an HsWrap is not an HsWrap.
1110 With that representation invariant, we simply look inside every HsWrap
1111 to see if its body is an HsVar whose Id hasNoBinding. Then, we look
1112 at the wrapped type. If it has any levity polymorphic arguments, reject.
1113
1114 Interestingly, this approach does not look to see whether the Id in
1115 question will be eta expanded. The logic is this:
1116 * Either the Id in question is saturated or not.
1117 * If it is, then it surely can't have levity polymorphic arguments.
1118 If its wrapped type contains levity polymorphic arguments, reject.
1119 * If it's not, then it can't be eta expanded with levity polymorphic
1120 argument. If its wrapped type contains levity polymorphic arguments, reject.
1121 So, either way, we're good to reject.
1122
1123 Wrinkle
1124 ~~~~~~~
1125 Not all polymorphic Ids are wrapped in
1126 HsWrap, due to the lazy instantiation of TypeApplications. (See "Visible type
1127 application", ESOP '16.) But if we spot a levity-polymorphic hasNoBinding Id
1128 without a wrapper, then that is surely problem and we can reject.
1129
1130 We thus have a parameter to `dsExpr` that tracks whether or not we are
1131 directly in an HsWrap. If we find a levity-polymorphic hasNoBinding Id when
1132 we're not directly in an HsWrap, reject.
1133
1134 -}
1135
1136 -- | Takes an expression and its instantiated type. If the expression is an
1137 -- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments,
1138 -- issue an error. See Note [Detecting forced eta expansion]
1139 checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
1140 checkForcedEtaExpansion expr ty
1141 | Just var <- case expr of
1142 HsVar _ (dL->L _ var) -> Just var
1143 HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)
1144 _ -> Nothing
1145 , let bad_tys = badUseOfLevPolyPrimop var ty
1146 , not (null bad_tys)
1147 = levPolyPrimopErr var ty bad_tys
1148 checkForcedEtaExpansion _ _ = return ()
1149
1150 -- | Is this a hasNoBinding Id with a levity-polymorphic type?
1151 -- Returns the arguments that are levity polymorphic if they are bad;
1152 -- or an empty list otherwise
1153 -- See Note [Detecting forced eta expansion]
1154 badUseOfLevPolyPrimop :: Id -> Type -> [Type]
1155 badUseOfLevPolyPrimop id ty
1156 | hasNoBinding id
1157 = filter isTypeLevPoly arg_tys
1158 | otherwise
1159 = []
1160 where
1161 (binders, _) = splitPiTys ty
1162 arg_tys = mapMaybe binderRelevantType_maybe binders
1163
1164 levPolyPrimopErr :: Id -> Type -> [Type] -> DsM ()
1165 levPolyPrimopErr primop ty bad_tys
1166 = errDs $ vcat
1167 [ hang (text "Cannot use function with levity-polymorphic arguments:")
1168 2 (ppr primop <+> dcolon <+> pprWithTYPE ty)
1169 , hang (text "Levity-polymorphic arguments:")
1170 2 $ vcat $ map
1171 (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t))
1172 bad_tys
1173 ]