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