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