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