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