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