2320ab498a013b9148e3dbadb9e459a05e3d70a4
[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 #-}
10
11 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds
12 , dsValBinds, dsLit, dsSyntaxExpr ) where
13
14 #include "HsVersions.h"
15
16 import Match
17 import MatchLit
18 import DsBinds
19 import DsGRHSs
20 import DsListComp
21 import DsUtils
22 import DsArrows
23 import DsMonad
24 import Name
25 import NameEnv
26 import FamInstEnv( topNormaliseType )
27 import DsMeta
28 import HsSyn
29
30 import Platform
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 CoreFVs
41 import MkCore
42
43 import DynFlags
44 import CostCentre
45 import Id
46 import Module
47 import VarSet
48 import ConLike
49 import DataCon
50 import TysWiredIn
51 import PrelNames
52 import BasicTypes
53 import Maybes
54 import VarEnv
55 import SrcLoc
56 import Util
57 import Bag
58 import Outputable
59 import FastString
60 import PatSyn
61
62 import IfaceEnv
63 import Data.IORef ( atomicModifyIORef', modifyIORef )
64
65 import Control.Monad
66 import GHC.Fingerprint
67
68 {-
69 ************************************************************************
70 * *
71 dsLocalBinds, dsValBinds
72 * *
73 ************************************************************************
74 -}
75
76 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
77 dsLocalBinds EmptyLocalBinds body = return body
78 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
79 dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
80
81 -------------------------
82 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
83 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
84 dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn"
85
86 -------------------------
87 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
88 dsIPBinds (IPBinds ip_binds ev_binds) body
89 = do { ds_binds <- dsTcEvBinds ev_binds
90 ; let inner = mkCoreLets ds_binds body
91 -- The dict bindings may not be in
92 -- dependency order; hence Rec
93 ; foldrM ds_ip_bind inner ip_binds }
94 where
95 ds_ip_bind (L _ (IPBind ~(Right n) e)) body
96 = do e' <- dsLExpr e
97 return (Let (NonRec n e') body)
98
99 -------------------------
100 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
101 -- Special case for bindings which bind unlifted variables
102 -- We need to do a case right away, rather than building
103 -- a tuple and doing selections.
104 -- Silently ignore INLINE and SPECIALISE pragmas...
105 ds_val_bind (NonRecursive, hsbinds) body
106 | [L loc bind] <- bagToList hsbinds,
107 -- Non-recursive, non-overloaded bindings only come in ones
108 -- ToDo: in some bizarre case it's conceivable that there
109 -- could be dict binds in the 'binds'. (See the notes
110 -- below. Then pattern-match would fail. Urk.)
111 unliftedMatchOnly bind
112 = putSrcSpanDs loc (dsUnliftedBind bind body)
113
114 -- Ordinary case for bindings; none should be unlifted
115 ds_val_bind (_is_rec, binds) body
116 = do { (force_vars,prs) <- dsLHsBinds binds
117 ; let body' = foldr seqVar body force_vars
118 ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
119 case prs of
120 [] -> return body
121 _ -> return (Let (Rec prs) body') }
122 -- Use a Rec regardless of is_rec.
123 -- Why? Because it allows the binds to be all
124 -- mixed up, which is what happens in one rare case
125 -- Namely, for an AbsBind with no tyvars and no dicts,
126 -- but which does have dictionary bindings.
127 -- See notes with TcSimplify.inferLoop [NO TYVARS]
128 -- It turned out that wrapping a Rec here was the easiest solution
129 --
130 -- NB The previous case dealt with unlifted bindings, so we
131 -- only have to deal with lifted ones now; so Rec is ok
132
133 ------------------
134 dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
135 dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
136 , abs_exports = exports
137 , abs_ev_binds = ev_binds
138 , abs_binds = lbinds }) body
139 = do { let body1 = foldr bind_export body exports
140 bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
141 ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
142 body1 lbinds
143 ; ds_binds <- dsTcEvBinds_s ev_binds
144 ; return (mkCoreLets ds_binds body2) }
145
146 dsUnliftedBind (AbsBindsSig { abs_tvs = []
147 , abs_ev_vars = []
148 , abs_sig_export = poly
149 , abs_sig_ev_bind = ev_bind
150 , abs_sig_bind = L _ bind }) body
151 = do { ds_binds <- dsTcEvBinds ev_bind
152 ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body
153 ; return (mkCoreLets ds_binds body') }
154
155 dsUnliftedBind (FunBind { fun_id = L _ fun
156 , fun_matches = matches
157 , fun_co_fn = co_fn
158 , fun_tick = tick }) body
159 -- Can't be a bang pattern (that looks like a PatBind)
160 -- so must be simply unboxed
161 = do { (args, rhs) <- matchWrapper (FunRhs (idName fun)) Nothing matches
162 ; MASSERT( null args ) -- Functions aren't lifted
163 ; MASSERT( isIdHsWrapper co_fn )
164 ; let rhs' = mkOptTickBox tick rhs
165 ; return (bindNonRec fun rhs' body) }
166
167 dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
168 = -- let C x# y# = rhs in body
169 -- ==> case rhs of C x# y# -> body
170 do { rhs <- dsGuarded grhss ty
171 ; let upat = unLoc pat
172 eqn = EqnInfo { eqn_pats = [upat],
173 eqn_rhs = cantFailMatchResult body }
174 ; var <- selectMatchVar upat
175 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
176 ; return (bindNonRec var rhs result) }
177
178 dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
179
180 ----------------------
181 unliftedMatchOnly :: HsBind Id -> Bool
182 unliftedMatchOnly (AbsBinds { abs_binds = lbinds })
183 = anyBag (unliftedMatchOnly . unLoc) lbinds
184 unliftedMatchOnly (AbsBindsSig { abs_sig_bind = L _ bind })
185 = unliftedMatchOnly bind
186 unliftedMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
187 = isUnliftedType rhs_ty
188 || isUnliftedLPat lpat
189 || any (isUnliftedType . idType) (collectPatBinders lpat)
190 unliftedMatchOnly (FunBind { fun_id = L _ id })
191 = isUnliftedType (idType id)
192 unliftedMatchOnly _ = False -- I hope! Checked immediately by caller in fact
193
194 {-
195 ************************************************************************
196 * *
197 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
198 * *
199 ************************************************************************
200 -}
201
202 dsLExpr :: LHsExpr Id -> DsM CoreExpr
203
204 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
205
206 dsExpr :: HsExpr Id -> DsM CoreExpr
207 dsExpr (HsPar e) = dsLExpr e
208 dsExpr (ExprWithTySigOut e _) = dsLExpr e
209 dsExpr (HsVar (L _ var)) = return (varToCoreExpr var)
210 -- See Note [Desugaring vars]
211 dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
212 dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"
213 dsExpr (HsOverLabel _) = panic "dsExpr: HsOverLabel"
214 dsExpr (HsLit lit) = dsLit lit
215 dsExpr (HsOverLit lit) = dsOverLit lit
216
217 dsExpr (HsWrap co_fn e)
218 = do { e' <- dsExpr e
219 ; wrapped_e <- dsHsWrapper co_fn e'
220 ; dflags <- getDynFlags
221 ; warnAboutIdentities dflags e' (exprType wrapped_e)
222 ; return wrapped_e }
223
224 dsExpr (NegApp expr neg_expr)
225 = do { expr' <- dsLExpr expr
226 ; dsSyntaxExpr neg_expr [expr'] }
227
228 dsExpr (HsLam a_Match)
229 = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
230
231 dsExpr (HsLamCase arg matches)
232 = do { arg_var <- newSysLocalDs arg
233 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
234 ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
235
236 dsExpr e@(HsApp fun arg)
237 -- ignore type arguments here; they're in the wrappers instead at this point
238 | isLHsTypeExpr arg = dsLExpr fun
239 | otherwise = mkCoreAppDs (text "HsApp" <+> ppr e)
240 <$> dsLExpr fun <*> dsLExpr arg
241
242
243 {-
244 Note [Desugaring vars]
245 ~~~~~~~~~~~~~~~~~~~~~~
246 In one situation we can get a *coercion* variable in a HsVar, namely
247 the support method for an equality superclass:
248 class (a~b) => C a b where ...
249 instance (blah) => C (T a) (T b) where ..
250 Then we get
251 $dfCT :: forall ab. blah => C (T a) (T b)
252 $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
253
254 $c$p1C :: forall ab. blah => (T a ~ T b)
255 $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
256
257 That 'g' in the 'in' part is an evidence variable, and when
258 converting to core it must become a CO.
259
260 Operator sections. At first it looks as if we can convert
261 \begin{verbatim}
262 (expr op)
263 \end{verbatim}
264 to
265 \begin{verbatim}
266 \x -> op expr x
267 \end{verbatim}
268
269 But no! expr might be a redex, and we can lose laziness badly this
270 way. Consider
271 \begin{verbatim}
272 map (expr op) xs
273 \end{verbatim}
274 for example. So we convert instead to
275 \begin{verbatim}
276 let y = expr in \x -> op y x
277 \end{verbatim}
278 If \tr{expr} is actually just a variable, say, then the simplifier
279 will sort it out.
280 -}
281
282 dsExpr e@(OpApp e1 op _ e2)
283 = -- for the type of y, we need the type of op's 2nd argument
284 mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
285
286 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
287 = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExpr expr
288
289 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
290 dsExpr e@(SectionR op expr) = do
291 core_op <- dsLExpr op
292 -- for the type of x, we need the type of op's 2nd argument
293 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
294 -- See comment with SectionL
295 y_core <- dsLExpr expr
296 x_id <- newSysLocalDs x_ty
297 y_id <- newSysLocalDs y_ty
298 return (bindNonRec y_id y_core $
299 Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id]))
300
301 dsExpr (ExplicitTuple tup_args boxity)
302 = do { let go (lam_vars, args) (L _ (Missing ty))
303 -- For every missing expression, we need
304 -- another lambda in the desugaring.
305 = do { lam_var <- newSysLocalDs ty
306 ; return (lam_var : lam_vars, Var lam_var : args) }
307 go (lam_vars, args) (L _ (Present expr))
308 -- Expressions that are present don't generate
309 -- lambdas, just arguments.
310 = do { core_expr <- dsLExpr expr
311 ; return (lam_vars, core_expr : args) }
312
313 ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
314 -- The reverse is because foldM goes left-to-right
315
316 ; return $ mkCoreLams lam_vars $
317 mkCoreTupBoxity boxity args }
318
319 dsExpr (HsSCC _ cc expr@(L loc _)) = do
320 dflags <- getDynFlags
321 if gopt Opt_SccProfilingOn dflags
322 then do
323 mod_name <- getModule
324 count <- goptM Opt_ProfCountEntries
325 uniq <- newUnique
326 Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)
327 <$> dsLExpr expr
328 else dsLExpr expr
329
330 dsExpr (HsCoreAnn _ _ expr)
331 = dsLExpr expr
332
333 dsExpr (HsCase discrim matches)
334 = do { core_discrim <- dsLExpr discrim
335 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
336 ; return (bindNonRec discrim_var core_discrim matching_code) }
337
338 -- Pepe: The binds are in scope in the body but NOT in the binding group
339 -- This is to avoid silliness in breakpoints
340 dsExpr (HsLet (L _ binds) body) = do
341 body' <- dsLExpr body
342 dsLocalBinds binds body'
343
344 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
345 -- because the interpretation of `stmts' depends on what sort of thing it is.
346 --
347 dsExpr (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty
348 dsExpr (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts)
349 dsExpr (HsDo DoExpr (L _ stmts) _) = dsDo stmts
350 dsExpr (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts
351 dsExpr (HsDo MDoExpr (L _ stmts) _) = dsDo stmts
352 dsExpr (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts
353
354 dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
355 = do { pred <- dsLExpr guard_expr
356 ; b1 <- dsLExpr then_expr
357 ; b2 <- dsLExpr else_expr
358 ; case mb_fun of
359 Just fun -> dsSyntaxExpr fun [pred, b1, b2]
360 Nothing -> return $ mkIfThenElse pred b1 b2 }
361
362 dsExpr (HsMultiIf res_ty alts)
363 | null alts
364 = mkErrorExpr
365
366 | otherwise
367 = do { match_result <- liftM (foldr1 combineMatchResults)
368 (mapM (dsGRHS IfAlt res_ty) alts)
369 ; error_expr <- mkErrorExpr
370 ; extractMatchResult match_result error_expr }
371 where
372 mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
373 (text "multi-way if")
374
375 {-
376 \noindent
377 \underline{\bf Various data construction things}
378 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
379 -}
380
381 dsExpr (ExplicitList elt_ty wit xs)
382 = dsExplicitList elt_ty wit xs
383
384 -- We desugar [:x1, ..., xn:] as
385 -- singletonP x1 +:+ ... +:+ singletonP xn
386 --
387 dsExpr (ExplicitPArr ty []) = do
388 emptyP <- dsDPHBuiltin emptyPVar
389 return (Var emptyP `App` Type ty)
390 dsExpr (ExplicitPArr ty xs) = do
391 singletonP <- dsDPHBuiltin singletonPVar
392 appP <- dsDPHBuiltin appPVar
393 xs' <- mapM dsLExpr xs
394 let unary fn x = mkApps (Var fn) [Type ty, x]
395 binary fn x y = mkApps (Var fn) [Type ty, x, y]
396
397 return . foldr1 (binary appP) $ map (unary singletonP) xs'
398
399 dsExpr (ArithSeq expr witness seq)
400 = case witness of
401 Nothing -> dsArithSeq expr seq
402 Just fl -> do { newArithSeq <- dsArithSeq expr seq
403 ; dsSyntaxExpr fl [newArithSeq] }
404
405 dsExpr (PArrSeq expr (FromTo from to))
406 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
407
408 dsExpr (PArrSeq expr (FromThenTo from thn to))
409 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
410
411 dsExpr (PArrSeq _ _)
412 = panic "DsExpr.dsExpr: Infinite parallel array!"
413 -- the parser shouldn't have generated it and the renamer and typechecker
414 -- shouldn't have let it through
415
416 {-
417 \noindent
418 \underline{\bf Static Pointers}
419 ~~~~~~~~~~~~~~~
420 \begin{verbatim}
421 g = ... static f ...
422 ==>
423 sptEntry:N = StaticPtr
424 (fingerprintString "pkgKey:module.sptEntry:N")
425 (StaticPtrInfo "current pkg key" "current module" "sptEntry:0")
426 f
427 g = ... sptEntry:N
428 \end{verbatim}
429 -}
430
431 dsExpr (HsStatic expr@(L loc _)) = do
432 expr_ds <- dsLExpr expr
433 let ty = exprType expr_ds
434 n' <- mkSptEntryName loc
435 static_binds_var <- dsGetStaticBindsVar
436
437 staticPtrTyCon <- dsLookupTyCon staticPtrTyConName
438 staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
439 staticPtrDataCon <- dsLookupDataCon staticPtrDataConName
440 fingerprintDataCon <- dsLookupDataCon fingerprintDataConName
441
442 dflags <- getDynFlags
443 let (line, col) = case loc of
444 RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
445 , srcLocCol $ realSrcSpanStart r
446 )
447 _ -> (0, 0)
448 srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
449 [ Type intTy , Type intTy
450 , mkIntExprInt dflags line, mkIntExprInt dflags col
451 ]
452 info <- mkConApp staticPtrInfoDataCon <$>
453 (++[srcLoc]) <$>
454 mapM mkStringExprFS
455 [ unitIdFS $ moduleUnitId $ nameModule n'
456 , moduleNameFS $ moduleName $ nameModule n'
457 , occNameFS $ nameOccName n'
458 ]
459 let tvars = tyCoVarsOfTypeWellScoped ty
460 speTy = ASSERT( all isTyVar tvars ) -- ty is top-level, so this is OK
461 mkInvForAllTys tvars $ mkTyConApp staticPtrTyCon [ty]
462 speId = mkExportedVanillaId n' speTy
463 fp@(Fingerprint w0 w1) = fingerprintName $ idName speId
464 fp_core = mkConApp fingerprintDataCon
465 [ mkWord64LitWordRep dflags w0
466 , mkWord64LitWordRep dflags w1
467 ]
468 sp = mkConApp staticPtrDataCon [Type ty, fp_core, info, expr_ds]
469 liftIO $ modifyIORef static_binds_var ((fp, (speId, mkLams tvars sp)) :)
470 putSrcSpanDs loc $ return $ mkTyApps (Var speId) (mkTyVarTys tvars)
471
472 where
473
474 -- | Choose either 'Word64#' or 'Word#' to represent the arguments of the
475 -- 'Fingerprint' data constructor.
476 mkWord64LitWordRep dflags
477 | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
478 | otherwise = mkWordLit dflags . toInteger
479
480 fingerprintName :: Name -> Fingerprint
481 fingerprintName n = fingerprintString $ unpackFS $ concatFS
482 [ unitIdFS $ moduleUnitId $ nameModule n
483 , fsLit ":"
484 , moduleNameFS (moduleName $ nameModule n)
485 , fsLit "."
486 , occNameFS $ occName n
487 ]
488
489 {-
490 \noindent
491 \underline{\bf Record construction and update}
492 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
493 For record construction we do this (assuming T has three arguments)
494 \begin{verbatim}
495 T { op2 = e }
496 ==>
497 let err = /\a -> recConErr a
498 T (recConErr t1 "M.hs/230/op1")
499 e
500 (recConErr t1 "M.hs/230/op3")
501 \end{verbatim}
502 @recConErr@ then converts its argument string into a proper message
503 before printing it as
504 \begin{verbatim}
505 M.hs, line 230: missing field op1 was evaluated
506 \end{verbatim}
507
508 We also handle @C{}@ as valid construction syntax for an unlabelled
509 constructor @C@, setting all of @C@'s fields to bottom.
510 -}
511
512 dsExpr (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
513 , rcon_con_like = con_like })
514 = do { con_expr' <- dsExpr con_expr
515 ; let
516 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
517 -- A newtype in the corner should be opaque;
518 -- hence TcType.tcSplitFunTys
519
520 mk_arg (arg_ty, fl)
521 = case findField (rec_flds rbinds) (flSelector fl) of
522 (rhs:rhss) -> ASSERT( null rhss )
523 dsLExpr rhs
524 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
525 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
526
527 labels = conLikeFieldLabels con_like
528
529 ; con_args <- if null labels
530 then mapM unlabelled_bottom arg_tys
531 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
532
533 ; return (mkCoreApps con_expr' con_args) }
534
535 {-
536 Record update is a little harder. Suppose we have the decl:
537 \begin{verbatim}
538 data T = T1 {op1, op2, op3 :: Int}
539 | T2 {op4, op2 :: Int}
540 | T3
541 \end{verbatim}
542 Then we translate as follows:
543 \begin{verbatim}
544 r { op2 = e }
545 ===>
546 let op2 = e in
547 case r of
548 T1 op1 _ op3 -> T1 op1 op2 op3
549 T2 op4 _ -> T2 op4 op2
550 other -> recUpdError "M.hs/230"
551 \end{verbatim}
552 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
553 RHSs, and do not generate a Core constructor application directly, because the constructor
554 might do some argument-evaluation first; and may have to throw away some
555 dictionaries.
556
557 Note [Update for GADTs]
558 ~~~~~~~~~~~~~~~~~~~~~~~
559 Consider
560 data T a b where
561 T1 :: { f1 :: a } -> T a Int
562
563 Then the wrapper function for T1 has type
564 $WT1 :: a -> T a Int
565 But if x::T a b, then
566 x { f1 = v } :: T a b (not T a Int!)
567 So we need to cast (T a Int) to (T a b). Sigh.
568
569 -}
570
571 dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
572 , rupd_cons = cons_to_upd
573 , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys
574 , rupd_wrap = dict_req_wrap } )
575 | null fields
576 = dsLExpr record_expr
577 | otherwise
578 = ASSERT2( notNull cons_to_upd, ppr expr )
579
580 do { record_expr' <- dsLExpr record_expr
581 ; field_binds' <- mapM ds_field fields
582 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
583 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
584
585 -- It's important to generate the match with matchWrapper,
586 -- and the right hand sides with applications of the wrapper Id
587 -- so that everything works when we are doing fancy unboxing on the
588 -- constructor aguments.
589 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
590 ; ([discrim_var], matching_code)
591 <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts
592 , mg_arg_tys = [in_ty]
593 , mg_res_ty = out_ty, mg_origin = FromSource })
594 -- FromSource is not strictly right, but we
595 -- want incomplete pattern-match warnings
596
597 ; return (add_field_binds field_binds' $
598 bindNonRec discrim_var record_expr' matching_code) }
599 where
600 ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr)
601 -- Clone the Id in the HsRecField, because its Name is that
602 -- of the record selector, and we must not make that a local binder
603 -- else we shadow other uses of the record selector
604 -- Hence 'lcl_id'. Cf Trac #2735
605 ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
606 ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
607 ; lcl_id <- newSysLocalDs (idType fld_id)
608 ; return (idName fld_id, lcl_id, rhs) }
609
610 add_field_binds [] expr = expr
611 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
612
613 -- Awkwardly, for families, the match goes
614 -- from instance type to family type
615 (in_ty, out_ty) =
616 case (head cons_to_upd) of
617 RealDataCon data_con ->
618 let tycon = dataConTyCon data_con in
619 (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)
620 PatSynCon pat_syn ->
621 ( patSynInstResTy pat_syn in_inst_tys
622 , patSynInstResTy pat_syn out_inst_tys)
623 mk_alt upd_fld_env con
624 = do { let (univ_tvs, ex_tvs, eq_spec,
625 prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
626 subst = zipTvSubst univ_tvs in_inst_tys
627
628 -- I'm not bothering to clone the ex_tvs
629 ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
630 ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta)
631 ; arg_ids <- newSysLocalsDs (substTysUnchecked subst arg_tys)
632 ; let field_labels = conLikeFieldLabels con
633 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
634 field_labels arg_ids
635 mk_val_arg fl pat_arg_id
636 = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
637 -- SAFE: the typechecker will complain if the synonym is
638 -- not bidirectional
639 wrap_id = expectJust "dsExpr:mk_alt" (conLikeWrapId_maybe con)
640 inst_con = noLoc $ HsWrap wrap (HsVar (noLoc wrap_id))
641 -- Reconstruct with the WrapId so that unpacking happens
642 -- The order here is because of the order in `TcPatSyn`.
643 wrap = mkWpEvVarApps theta_vars <.>
644 dict_req_wrap <.>
645 mkWpTyApps (mkTyVarTys ex_tvs) <.>
646 mkWpTyApps [ ty
647 | (tv, ty) <- univ_tvs `zip` out_inst_tys
648 , not (tv `elemVarEnv` wrap_subst) ]
649 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
650
651 -- Tediously wrap the application in a cast
652 -- Note [Update for GADTs]
653 wrapped_rhs =
654 case con of
655 RealDataCon data_con ->
656 let
657 wrap_co =
658 mkTcTyConAppCo Nominal
659 (dataConTyCon data_con)
660 [ lookup tv ty
661 | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
662 lookup univ_tv ty =
663 case lookupVarEnv wrap_subst univ_tv of
664 Just co' -> co'
665 Nothing -> mkTcReflCo Nominal ty
666 in if null eq_spec
667 then rhs
668 else mkLHsWrap (mkWpCastN wrap_co) rhs
669 -- eq_spec is always null for a PatSynCon
670 PatSynCon _ -> rhs
671
672 wrap_subst =
673 mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
674 | (spec, eq_var) <- eq_spec `zip` eqs_vars
675 , let tv = eqSpecTyVar spec ]
676
677 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
678
679 pat = noLoc $ ConPatOut { pat_con = noLoc con
680 , pat_tvs = ex_tvs
681 , pat_dicts = eqs_vars ++ theta_vars
682 , pat_binds = emptyTcEvBinds
683 , pat_args = PrefixCon $ map nlVarPat arg_ids
684 , pat_arg_tys = in_inst_tys
685 , pat_wrap = req_wrap }
686 ; return (mkSimpleMatch [pat] wrapped_rhs) }
687
688 -- Here is where we desugar the Template Haskell brackets and escapes
689
690 -- Template Haskell stuff
691
692 dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
693 dsExpr (HsTcBracketOut x ps) = dsBracket x ps
694 dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
695
696 -- Arrow notation extension
697 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
698
699 -- Hpc Support
700
701 dsExpr (HsTick tickish e) = do
702 e' <- dsLExpr e
703 return (Tick tickish e')
704
705 -- There is a problem here. The then and else branches
706 -- have no free variables, so they are open to lifting.
707 -- We need someway of stopping this.
708 -- This will make no difference to binary coverage
709 -- (did you go here: YES or NO), but will effect accurate
710 -- tick counting.
711
712 dsExpr (HsBinTick ixT ixF e) = do
713 e2 <- dsLExpr e
714 do { ASSERT(exprType e2 `eqType` boolTy)
715 mkBinaryTickBox ixT ixF e2
716 }
717
718 dsExpr (HsTickPragma _ _ _ expr) = do
719 dflags <- getDynFlags
720 if gopt Opt_Hpc dflags
721 then panic "dsExpr:HsTickPragma"
722 else dsLExpr expr
723
724 -- HsSyn constructs that just shouldn't be here:
725 dsExpr (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig"
726 dsExpr (HsBracket {}) = panic "dsExpr:HsBracket"
727 dsExpr (HsArrApp {}) = panic "dsExpr:HsArrApp"
728 dsExpr (HsArrForm {}) = panic "dsExpr:HsArrForm"
729 dsExpr (EWildPat {}) = panic "dsExpr:EWildPat"
730 dsExpr (EAsPat {}) = panic "dsExpr:EAsPat"
731 dsExpr (EViewPat {}) = panic "dsExpr:EViewPat"
732 dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat"
733 dsExpr (HsType {}) = panic "dsExpr:HsType" -- removed by typechecker
734 dsExpr (HsDo {}) = panic "dsExpr:HsDo"
735 dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld"
736
737 -- Normally handled in HsApp case, but a GHC API user might try to desugar
738 -- an HsTypeOut, since it is an HsExpr in a typechecked module after all.
739 -- (Such as ghci itself, in #11456.) So improve the error message slightly.
740 dsExpr (HsTypeOut {})
741 = panic "dsExpr: tried to desugar a naked type application argument (HsTypeOut)"
742
743 ------------------------------
744 dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
745 dsSyntaxExpr (SyntaxExpr { syn_expr = expr
746 , syn_arg_wraps = arg_wraps
747 , syn_res_wrap = res_wrap })
748 arg_exprs
749 = do { args <- zipWithM dsHsWrapper arg_wraps arg_exprs
750 ; fun <- dsExpr expr
751 ; dsHsWrapper res_wrap $ mkApps fun args }
752
753 findField :: [LHsRecField Id arg] -> Name -> [arg]
754 findField rbinds sel
755 = [hsRecFieldArg fld | L _ fld <- rbinds
756 , sel == idName (unLoc $ hsRecFieldId fld) ]
757
758 {-
759 %--------------------------------------------------------------------
760
761 Note [Desugaring explicit lists]
762 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
763 Explicit lists are desugared in a cleverer way to prevent some
764 fruitless allocations. Essentially, whenever we see a list literal
765 [x_1, ..., x_n] we:
766
767 1. Find the tail of the list that can be allocated statically (say
768 [x_k, ..., x_n]) by later stages and ensure we desugar that
769 normally: this makes sure that we don't cause a code size increase
770 by having the cons in that expression fused (see later) and hence
771 being unable to statically allocate any more
772
773 2. For the prefix of the list which cannot be allocated statically,
774 say [x_1, ..., x_(k-1)], we turn it into an expression involving
775 build so that if we find any foldrs over it it will fuse away
776 entirely!
777
778 So in this example we will desugar to:
779 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
780
781 If fusion fails to occur then build will get inlined and (since we
782 defined a RULE for foldr (:) []) we will get back exactly the
783 normal desugaring for an explicit list.
784
785 This optimisation can be worth a lot: up to 25% of the total
786 allocation in some nofib programs. Specifically
787
788 Program Size Allocs Runtime CompTime
789 rewrite +0.0% -26.3% 0.02 -1.8%
790 ansi -0.3% -13.8% 0.00 +0.0%
791 lift +0.0% -8.7% 0.00 -2.3%
792
793 Of course, if rules aren't turned on then there is pretty much no
794 point doing this fancy stuff, and it may even be harmful.
795
796 =======> Note by SLPJ Dec 08.
797
798 I'm unconvinced that we should *ever* generate a build for an explicit
799 list. See the comments in GHC.Base about the foldr/cons rule, which
800 points out that (foldr k z [a,b,c]) may generate *much* less code than
801 (a `k` b `k` c `k` z).
802
803 Furthermore generating builds messes up the LHS of RULES.
804 Example: the foldr/single rule in GHC.Base
805 foldr k z [x] = ...
806 We do not want to generate a build invocation on the LHS of this RULE!
807
808 We fix this by disabling rules in rule LHSs, and testing that
809 flag here; see Note [Desugaring RULE left hand sides] in Desugar
810
811 To test this I've added a (static) flag -fsimple-list-literals, which
812 makes all list literals be generated via the simple route.
813 -}
814
815 dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
816 -> DsM CoreExpr
817 -- See Note [Desugaring explicit lists]
818 dsExplicitList elt_ty Nothing xs
819 = do { dflags <- getDynFlags
820 ; xs' <- mapM dsLExpr xs
821 ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
822 ; if gopt Opt_SimpleListLiterals dflags -- -fsimple-list-literals
823 || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
824 -- Don't generate a build if there are no rules to eliminate it!
825 -- See Note [Desugaring RULE left hand sides] in Desugar
826 || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)!
827 then return $ mkListExpr elt_ty xs'
828 else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
829 where
830 is_static :: CoreExpr -> Bool
831 is_static e = all is_static_var (varSetElems (exprFreeVars e))
832
833 is_static_var :: Var -> Bool
834 is_static_var v
835 | isId v = isExternalName (idName v) -- Top-level things are given external names
836 | otherwise = False -- Type variables
837
838 mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
839 = do { let suffix' = mkListExpr elt_ty suffix
840 ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
841 ; return (foldr (App . App (Var c)) folded_suffix prefix) }
842
843 dsExplicitList elt_ty (Just fln) xs
844 = do { list <- dsExplicitList elt_ty Nothing xs
845 ; dflags <- getDynFlags
846 ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }
847
848 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
849 spanTail f xs = (reverse rejected, reverse satisfying)
850 where (satisfying, rejected) = span f $ reverse xs
851
852 dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr
853 dsArithSeq expr (From from)
854 = App <$> dsExpr expr <*> dsLExpr from
855 dsArithSeq expr (FromTo from to)
856 = do dflags <- getDynFlags
857 warnAboutEmptyEnumerations dflags from Nothing to
858 expr' <- dsExpr expr
859 from' <- dsLExpr from
860 to' <- dsLExpr to
861 return $ mkApps expr' [from', to']
862 dsArithSeq expr (FromThen from thn)
863 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
864 dsArithSeq expr (FromThenTo from thn to)
865 = do dflags <- getDynFlags
866 warnAboutEmptyEnumerations dflags from (Just thn) to
867 expr' <- dsExpr expr
868 from' <- dsLExpr from
869 thn' <- dsLExpr thn
870 to' <- dsLExpr to
871 return $ mkApps expr' [from', thn', to']
872
873 {-
874 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
875 handled in DsListComp). Basically does the translation given in the
876 Haskell 98 report:
877 -}
878
879 dsDo :: [ExprLStmt Id] -> DsM CoreExpr
880 dsDo stmts
881 = goL stmts
882 where
883 goL [] = panic "dsDo"
884 goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
885
886 go _ (LastStmt body _ _) stmts
887 = ASSERT( null stmts ) dsLExpr body
888 -- The 'return' op isn't used for 'do' expressions
889
890 go _ (BodyStmt rhs then_expr _ _) stmts
891 = do { rhs2 <- dsLExpr rhs
892 ; warnDiscardedDoBindings rhs (exprType rhs2)
893 ; rest <- goL stmts
894 ; dsSyntaxExpr then_expr [rhs2, rest] }
895
896 go _ (LetStmt (L _ binds)) stmts
897 = do { rest <- goL stmts
898 ; dsLocalBinds binds rest }
899
900 go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts
901 = do { body <- goL stmts
902 ; rhs' <- dsLExpr rhs
903 ; var <- selectSimpleMatchVarL pat
904 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
905 res1_ty (cantFailMatchResult body)
906 ; match_code <- handle_failure pat match fail_op
907 ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
908
909 go _ (ApplicativeStmt args mb_join body_ty) stmts
910 = do {
911 let
912 (pats, rhss) = unzip (map (do_arg . snd) args)
913
914 do_arg (ApplicativeArgOne pat expr) =
915 (pat, dsLExpr expr)
916 do_arg (ApplicativeArgMany stmts ret pat) =
917 (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
918
919 arg_tys = map hsLPatType pats
920
921 ; rhss' <- sequence rhss
922
923 ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty
924
925 ; let fun = L noSrcSpan $ HsLam $
926 MG { mg_alts = noLoc [mkSimpleMatch pats body']
927 , mg_arg_tys = arg_tys
928 , mg_res_ty = body_ty
929 , mg_origin = Generated }
930
931 ; fun' <- dsLExpr fun
932 ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
933 ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
934 ; case mb_join of
935 Nothing -> return expr
936 Just join_op -> dsSyntaxExpr join_op [expr] }
937
938 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
939 , recS_rec_ids = rec_ids, recS_ret_fn = return_op
940 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
941 , recS_bind_ty = bind_ty
942 , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
943 = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
944 where
945 new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats)
946 mfix_app bind_op
947 noSyntaxExpr -- Tuple cannot fail
948 bind_ty
949
950 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
951 tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
952 rec_tup_pats = map nlVarPat tup_ids
953 later_pats = rec_tup_pats
954 rets = map noLoc rec_rets
955 mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
956 mfix_arg = noLoc $ HsLam
957 (MG { mg_alts = noLoc [mkSimpleMatch [mfix_pat] body]
958 , mg_arg_tys = [tup_ty], mg_res_ty = body_ty
959 , mg_origin = Generated })
960 mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
961 body = noLoc $ HsDo
962 DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
963 ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
964 ret_stmt = noLoc $ mkLastStmt ret_app
965 -- This LastStmt will be desugared with dsDo,
966 -- which ignores the return_op in the LastStmt,
967 -- so we must apply the return_op explicitly
968
969 go _ (ParStmt {}) _ = panic "dsDo ParStmt"
970 go _ (TransStmt {}) _ = panic "dsDo TransStmt"
971
972 handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
973 -- In a do expression, pattern-match failure just calls
974 -- the monadic 'fail' rather than throwing an exception
975 handle_failure pat match fail_op
976 | matchCanFail match
977 = do { dflags <- getDynFlags
978 ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
979 ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
980 ; extractMatchResult match fail_expr }
981 | otherwise
982 = extractMatchResult match (error "It can't fail")
983
984 mk_fail_msg :: DynFlags -> Located e -> String
985 mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
986 showPpr dflags (getLoc pat)
987
988 {-
989 ************************************************************************
990 * *
991 \subsection{Errors and contexts}
992 * *
993 ************************************************************************
994 -}
995
996 -- Warn about certain types of values discarded in monadic bindings (#3263)
997 warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
998 warnDiscardedDoBindings rhs rhs_ty
999 | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
1000 = do { warn_unused <- woptM Opt_WarnUnusedDoBind
1001 ; warn_wrong <- woptM Opt_WarnWrongDoBind
1002 ; when (warn_unused || warn_wrong) $
1003 do { fam_inst_envs <- dsGetFamInstEnvs
1004 ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
1005
1006 -- Warn about discarding non-() things in 'monadic' binding
1007 ; if warn_unused && not (isUnitTy norm_elt_ty)
1008 then warnDs (Reason Opt_WarnUnusedDoBind)
1009 (badMonadBind rhs elt_ty)
1010 else
1011
1012 -- Warn about discarding m a things in 'monadic' binding of the same type,
1013 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
1014 when warn_wrong $
1015 do { case tcSplitAppTy_maybe norm_elt_ty of
1016 Just (elt_m_ty, _)
1017 | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
1018 -> warnDs (Reason Opt_WarnWrongDoBind)
1019 (badMonadBind rhs elt_ty)
1020 _ -> return () } } }
1021
1022 | otherwise -- RHS does have type of form (m ty), which is weird
1023 = return () -- but at lesat this warning is irrelevant
1024
1025 badMonadBind :: LHsExpr Id -> Type -> SDoc
1026 badMonadBind rhs elt_ty
1027 = vcat [ hang (text "A do-notation statement discarded a result of type")
1028 2 (quotes (ppr elt_ty))
1029 , hang (text "Suppress this warning by saying")
1030 2 (quotes $ text "_ <-" <+> ppr rhs)
1031 ]
1032
1033 {-
1034 ************************************************************************
1035 * *
1036 \subsection{Static pointers}
1037 * *
1038 ************************************************************************
1039 -}
1040
1041 -- | Creates an name for an entry in the Static Pointer Table.
1042 --
1043 -- The name has the form @sptEntry:<N>@ where @<N>@ is generated from a
1044 -- per-module counter.
1045 --
1046 mkSptEntryName :: SrcSpan -> DsM Name
1047 mkSptEntryName loc = do
1048 mod <- getModule
1049 occ <- mkWrapperName "sptEntry"
1050 newGlobalBinder mod occ loc
1051 where
1052 mkWrapperName what
1053 = do dflags <- getDynFlags
1054 thisMod <- getModule
1055 let -- Note [Generating fresh names for ccall wrapper]
1056 -- in compiler/typecheck/TcEnv.hs
1057 wrapperRef = nextWrapperNum dflags
1058 wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
1059 let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
1060 in (extendModuleEnv mod_env thisMod (num+1), num)
1061 return $ mkVarOcc $ what ++ ":" ++ show wrapperNum