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